From 1ce9df6ad6758aa12d25b7c180efc461b1f4fb71 Mon Sep 17 00:00:00 2001 From: Benjamin Vedder Date: Fri, 26 Jul 2024 11:58:45 +0200 Subject: [PATCH] Squashed 'lispBM/lispBM/' changes from 9d85c18f..2b5f30cd 2b5f30cd version 0.25.0 f68282ee exposed the lbm_request_gc_ function in the eval_cps interface bcde5f97 adding profiling script to repl directory git-subtree-dir: lispBM/lispBM git-subtree-split: 2b5f30cdbe94c7ef48798dc7382f87578c7fe76e --- include/eval_cps.h | 5 +- include/lbm_version.h | 11 +- repl/profile.sh | 12 + .../failing_gc_unit_tests_log_0.25.0.txt | 616 ++ .../failing_unit_tests_log_0.25.0.txt | 616 ++ .../failing_unit_tests_log_64_0.25.0.txt | 616 ++ .../gc_unit_tests_log_0.25.0.txt | 82 + test_reports/version_0.25.0/infer_0.25.0.txt | 984 +++ .../2024-07-23-152344-239046-1/index.html | 150 + .../report-0007d3.html | 6558 +++++++++++++++++ .../report-3e0f11.html | 6552 ++++++++++++++++ .../report-47103f.html | 6553 ++++++++++++++++ .../report-49137f.html | 5543 ++++++++++++++ .../report-4a8c88.html | 5576 ++++++++++++++ .../report-4accd4.html | 5548 ++++++++++++++ .../report-52eee6.html | 6543 ++++++++++++++++ .../report-6504f5.html | 6543 ++++++++++++++++ .../report-79ea5f.html | 6537 ++++++++++++++++ .../report-9d5914.html | 6556 ++++++++++++++++ .../report-a60707.html | 5548 ++++++++++++++ .../report-cb7c37.html | 6545 ++++++++++++++++ .../report-ce8d59.html | 2797 +++++++ .../report-e1a01d.html | 6534 ++++++++++++++++ .../report-ebe0ba.html | 2797 +++++++ .../report-f2a4bc.html | 6533 ++++++++++++++++ .../report-f53f44.html | 6556 ++++++++++++++++ .../report-f5608d.html | 6533 ++++++++++++++++ .../report-fac31c.html | 5548 ++++++++++++++ .../2024-07-23-152344-239046-1/scanview.css | 62 + .../2024-07-23-152344-239046-1/sorttable.js | 492 ++ .../version_0.25.0/unit_tests_log_0.25.0.txt | 78 + .../unit_tests_log_64_0.25.0.txt | 78 + 32 files changed, 115699 insertions(+), 3 deletions(-) create mode 100755 repl/profile.sh create mode 100644 test_reports/version_0.25.0/failing_gc_unit_tests_log_0.25.0.txt create mode 100644 test_reports/version_0.25.0/failing_unit_tests_log_0.25.0.txt create mode 100644 test_reports/version_0.25.0/failing_unit_tests_log_64_0.25.0.txt create mode 100644 test_reports/version_0.25.0/gc_unit_tests_log_0.25.0.txt create mode 100644 test_reports/version_0.25.0/infer_0.25.0.txt create mode 100644 test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/index.html create mode 100644 test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-0007d3.html create mode 100644 test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-3e0f11.html create mode 100644 test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-47103f.html create mode 100644 test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-49137f.html create mode 100644 test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-4a8c88.html create mode 100644 test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-4accd4.html create mode 100644 test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-52eee6.html create mode 100644 test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-6504f5.html create mode 100644 test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-79ea5f.html create mode 100644 test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-9d5914.html create mode 100644 test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-a60707.html create mode 100644 test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-cb7c37.html create mode 100644 test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-ce8d59.html create mode 100644 test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-e1a01d.html create mode 100644 test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-ebe0ba.html create mode 100644 test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-f2a4bc.html create mode 100644 test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-f53f44.html create mode 100644 test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-f5608d.html create mode 100644 test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-fac31c.html create mode 100644 test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/scanview.css create mode 100644 test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/sorttable.js create mode 100644 test_reports/version_0.25.0/unit_tests_log_0.25.0.txt create mode 100644 test_reports/version_0.25.0/unit_tests_log_64_0.25.0.txt diff --git a/include/eval_cps.h b/include/eval_cps.h index 686f4658..ed78e559 100644 --- a/include/eval_cps.h +++ b/include/eval_cps.h @@ -371,7 +371,10 @@ lbm_value lbm_find_receiver_and_send(lbm_cid cid, lbm_value msg); * \return 1 on success */ int lbm_perform_gc(void); - +/** Request that the runtime system performs a garbage collection on its earliers convenience. + * Can be called from any thread and does NOT require that the evaluator is paused. + */ +void lbm_request_gc(void); #ifdef __cplusplus } #endif diff --git a/include/lbm_version.h b/include/lbm_version.h index 36241ea1..a7ff404e 100644 --- a/include/lbm_version.h +++ b/include/lbm_version.h @@ -27,14 +27,21 @@ extern "C" { /** LBM major version */ #define LBM_MAJOR_VERSION 0 /** LBM minor version */ -#define LBM_MINOR_VERSION 24 +#define LBM_MINOR_VERSION 25 /** LBM patch revision */ #define LBM_PATCH_VERSION 0 -#define LBM_VERSION_STRING "0.24.0" +#define LBM_VERSION_STRING "0.25.0" /*! \page changelog Changelog +JUL 23 2024: Version 0.25.0 + - Multiple bugfixes. + - Trap function on expressions. + - Reference manual updates. + - New String operations (Thanks Rasmus S) + - Order of writes changed when writing to flash. + APR 28 2024: Version 0.24.0 - Cleaning of lispbm repository. less to maintain. - Lots of improvements to documentation. diff --git a/repl/profile.sh b/repl/profile.sh new file mode 100755 index 00000000..a4d01080 --- /dev/null +++ b/repl/profile.sh @@ -0,0 +1,12 @@ +#!/bin/bash + +src=$1 + +valgrind --toggle-collect=lbm_run_eval --tool=callgrind --callgrind-out-file=cg.out ./repl --terminate -s $src + +gprof2dot -f callgrind cg.out -o cg.dot + +dot -Tpdf cg.dot -o cg.pdf + +rm cg.out +rm cg.dot diff --git a/test_reports/version_0.25.0/failing_gc_unit_tests_log_0.25.0.txt b/test_reports/version_0.25.0/failing_gc_unit_tests_log_0.25.0.txt new file mode 100644 index 00000000..7cad18a9 --- /dev/null +++ b/test_reports/version_0.25.0/failing_gc_unit_tests_log_0.25.0.txt @@ -0,0 +1,616 @@ +------------------------------------------------------------ +Heap size: 1024 +Streaming source: no +Incremental read: no +------------------------------------------------------------ +Opening file: tests/test_take_iota_0.lisp +Memory initialized. +LBM Initialized +Constants memory initialized +Events initialized. +Array extensions initialized. +Math extensions initialized. +String extensions initialized. +Runtime extensions initialized. +Matvec extensions initialized. +Random extensions initialized. +Loop extensions initialized. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Result check extension added. +extension load extension added. +LBM memory free: 3599 words, 14396 bytes +Wait for pause init +Wait for pause init +test_cid = 497 +Program loaded +*** Error: out_of_memory +*** In: take +*** After: 100 + + + In context: 497 + Current intermediate result: 100 + + Current local environment: + + + Current global environment: + iota = (closure (n) (range 0 n) nil) + + + Stack: + CONT[0] + CONT[0] + check + nil + nil + 1u + CONT[5] + eq + nil + ((iota 100)) + 1u + CONT[5] + take + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 + 100 +Thread 497 finished: out_of_memory +experiment failed due to taking longer than 25 seconds +------------------------------------------------------------ +Heap size: 1024 +Streaming source: no +Incremental read: yes +------------------------------------------------------------ +Opening file: tests/test_take_iota_0.lisp +Memory initialized. +LBM Initialized +Constants memory initialized +Events initialized. +Array extensions initialized. +Math extensions initialized. +String extensions initialized. +Runtime extensions initialized. +Matvec extensions initialized. +Random extensions initialized. +Loop extensions initialized. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Result check extension added. +extension load extension added. +LBM memory free: 3599 words, 14396 bytes +Wait for pause init +Wait for pause init +test_cid = 497 +Program loaded +*** Error: out_of_memory +*** In: take +*** After: 100 + + + In context: 497 + Current intermediate result: 100 + + Current local environment: + + + Current global environment: + iota = (closure (n) (range 0 n) nil) + + + Stack: + CONT[0] + 0u + ~CHANNEL~ + CONT[20] + ~CHANNEL~ + nil + CONT[17] + ~CHANNEL~ + 1u + CONT[15] + check + nil + nil + 1u + CONT[5] + eq + nil + ((iota 100)) + 1u + CONT[5] + take + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 + 100 +Thread 497 finished: out_of_memory +experiment failed due to taking longer than 25 seconds +------------------------------------------------------------ +Heap size: 1024 +Streaming source: yes +Incremental read: no +------------------------------------------------------------ +Opening file: tests/test_take_iota_0.lisp +Memory initialized. +LBM Initialized +Constants memory initialized +Events initialized. +Array extensions initialized. +Math extensions initialized. +String extensions initialized. +Runtime extensions initialized. +Matvec extensions initialized. +Random extensions initialized. +Loop extensions initialized. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Result check extension added. +extension load extension added. +LBM memory free: 3599 words, 14396 bytes +Wait for pause init +Wait for pause init +test_cid = 497 +Program loaded +*** Error: out_of_memory +*** In: take +*** After: 100 + + + In context: 497 + Current intermediate result: 100 + + Current local environment: + + + Current global environment: + iota = (closure (n) (range 0 n) nil) + + + Stack: + CONT[0] + CONT[0] + check + nil + nil + 1u + CONT[5] + eq + nil + ((iota 100)) + 1u + CONT[5] + take + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 + 100 +Thread 497 finished: out_of_memory +experiment failed due to taking longer than 25 seconds +------------------------------------------------------------ +Heap size: 1024 +Streaming source: yes +Incremental read: yes +------------------------------------------------------------ +Opening file: tests/test_take_iota_0.lisp +Memory initialized. +LBM Initialized +Constants memory initialized +Events initialized. +Array extensions initialized. +Math extensions initialized. +String extensions initialized. +Runtime extensions initialized. +Matvec extensions initialized. +Random extensions initialized. +Loop extensions initialized. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Result check extension added. +extension load extension added. +LBM memory free: 3599 words, 14396 bytes +Wait for pause init +Wait for pause init +test_cid = 497 +Program loaded +*** Error: out_of_memory +*** In: take +*** After: 100 + + + In context: 497 + Current intermediate result: 100 + + Current local environment: + + + Current global environment: + iota = (closure (n) (range 0 n) nil) + + + Stack: + CONT[0] + 0u + ~CHANNEL~ + CONT[20] + ~CHANNEL~ + nil + CONT[17] + ~CHANNEL~ + 1u + CONT[15] + check + nil + nil + 1u + CONT[5] + eq + nil + ((iota 100)) + 1u + CONT[5] + take + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 + 100 +Thread 497 finished: out_of_memory +experiment failed due to taking longer than 25 seconds +------------------------------------------------------------ +Heap size: 512 +Streaming source: no +Incremental read: no +------------------------------------------------------------ +Opening file: tests/test_take_iota_0.lisp +Memory initialized. +LBM Initialized +Constants memory initialized +Events initialized. +Array extensions initialized. +Math extensions initialized. +String extensions initialized. +Runtime extensions initialized. +Matvec extensions initialized. +Random extensions initialized. +Loop extensions initialized. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Result check extension added. +extension load extension added. +LBM memory free: 3599 words, 14396 bytes +Wait for pause init +Wait for pause init +test_cid = 497 +Program loaded +*** Error: out_of_memory +*** In: range +*** After: n + + + In context: 497 + Current intermediate result: n + + Current local environment: + n = 1000 + + + Current global environment: + iota = (closure (n) (range 0 n) nil) + + + Stack: + CONT[0] + CONT[0] + check + nil + nil + 1u + CONT[5] + eq + nil + ((iota 100)) + 1u + CONT[5] + take + nil + (100) + 1u + CONT[5] + range + 0 + 1000 +Thread 497 finished: out_of_memory +experiment failed due to taking longer than 25 seconds +------------------------------------------------------------ +Heap size: 512 +Streaming source: no +Incremental read: yes +------------------------------------------------------------ +Opening file: tests/test_take_iota_0.lisp +Memory initialized. +LBM Initialized +Constants memory initialized +Events initialized. +Array extensions initialized. +Math extensions initialized. +String extensions initialized. +Runtime extensions initialized. +Matvec extensions initialized. +Random extensions initialized. +Loop extensions initialized. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Result check extension added. +extension load extension added. +LBM memory free: 3599 words, 14396 bytes +Wait for pause init +Wait for pause init +test_cid = 497 +Program loaded +*** Error: out_of_memory +*** In: range +*** After: n + + + In context: 497 + Current intermediate result: n + + Current local environment: + n = 1000 + + + Current global environment: + iota = (closure (n) (range 0 n) nil) + + + Stack: + CONT[0] + 0u + ~CHANNEL~ + CONT[20] + ~CHANNEL~ + nil + CONT[17] + ~CHANNEL~ + 1u + CONT[15] + check + nil + nil + 1u + CONT[5] + eq + nil + ((iota 100)) + 1u + CONT[5] + take + nil + (100) + 1u + CONT[5] + range + 0 + 1000 +Thread 497 finished: out_of_memory +experiment failed due to taking longer than 25 seconds +------------------------------------------------------------ +Heap size: 512 +Streaming source: yes +Incremental read: no +------------------------------------------------------------ +Opening file: tests/test_take_iota_0.lisp +Memory initialized. +LBM Initialized +Constants memory initialized +Events initialized. +Array extensions initialized. +Math extensions initialized. +String extensions initialized. +Runtime extensions initialized. +Matvec extensions initialized. +Random extensions initialized. +Loop extensions initialized. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Result check extension added. +extension load extension added. +LBM memory free: 3599 words, 14396 bytes +Wait for pause init +Wait for pause init +test_cid = 497 +Program loaded +*** Error: out_of_memory +*** In: range +*** After: n + + + In context: 497 + Current intermediate result: n + + Current local environment: + n = 1000 + + + Current global environment: + iota = (closure (n) (range 0 n) nil) + + + Stack: + CONT[0] + CONT[0] + check + nil + nil + 1u + CONT[5] + eq + nil + ((iota 100)) + 1u + CONT[5] + take + nil + (100) + 1u + CONT[5] + range + 0 + 1000 +Thread 497 finished: out_of_memory +experiment failed due to taking longer than 25 seconds +------------------------------------------------------------ +Heap size: 512 +Streaming source: yes +Incremental read: yes +------------------------------------------------------------ +Opening file: tests/test_take_iota_0.lisp +Memory initialized. +LBM Initialized +Constants memory initialized +Events initialized. +Array extensions initialized. +Math extensions initialized. +String extensions initialized. +Runtime extensions initialized. +Matvec extensions initialized. +Random extensions initialized. +Loop extensions initialized. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Result check extension added. +extension load extension added. +LBM memory free: 3599 words, 14396 bytes +Wait for pause init +Wait for pause init +test_cid = 497 +Program loaded +*** Error: out_of_memory +*** In: range +*** After: n + + + In context: 497 + Current intermediate result: n + + Current local environment: + n = 1000 + + + Current global environment: + iota = (closure (n) (range 0 n) nil) + + + Stack: + CONT[0] + 0u + ~CHANNEL~ + CONT[20] + ~CHANNEL~ + nil + CONT[17] + ~CHANNEL~ + 1u + CONT[15] + check + nil + nil + 1u + CONT[5] + eq + nil + ((iota 100)) + 1u + CONT[5] + take + nil + (100) + 1u + CONT[5] + range + 0 + 1000 +Thread 497 finished: out_of_memory +experiment failed due to taking longer than 25 seconds diff --git a/test_reports/version_0.25.0/failing_unit_tests_log_0.25.0.txt b/test_reports/version_0.25.0/failing_unit_tests_log_0.25.0.txt new file mode 100644 index 00000000..c4f853f0 --- /dev/null +++ b/test_reports/version_0.25.0/failing_unit_tests_log_0.25.0.txt @@ -0,0 +1,616 @@ +------------------------------------------------------------ +Heap size: 1024 +Streaming source: no +Incremental read: no +------------------------------------------------------------ +Opening file: tests/test_take_iota_0.lisp +Memory initialized. +LBM Initialized +Constants memory initialized +Events initialized. +Array extensions initialized. +Math extensions initialized. +String extensions initialized. +Runtime extensions initialized. +Matvec extensions initialized. +Random extensions initialized. +Loop extensions initialized. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Result check extension added. +extension load extension added. +LBM memory free: 3599 words, 14396 bytes +Wait for pause init +Wait for pause init +test_cid = 497 +Program loaded +*** Error: out_of_memory +*** In: take +*** After: 100 + + + In context: 497 + Current intermediate result: 100 + + Current local environment: + + + Current global environment: + iota = (closure (n) (range 0 n) nil) + + + Stack: + CONT[0] + CONT[0] + check + nil + nil + 1u + CONT[5] + eq + nil + ((iota 100)) + 1u + CONT[5] + take + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 + 100 +Thread 497 finished: out_of_memory +experiment failed due to taking longer than 10 seconds +------------------------------------------------------------ +Heap size: 1024 +Streaming source: no +Incremental read: yes +------------------------------------------------------------ +Opening file: tests/test_take_iota_0.lisp +Memory initialized. +LBM Initialized +Constants memory initialized +Events initialized. +Array extensions initialized. +Math extensions initialized. +String extensions initialized. +Runtime extensions initialized. +Matvec extensions initialized. +Random extensions initialized. +Loop extensions initialized. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Result check extension added. +extension load extension added. +LBM memory free: 3599 words, 14396 bytes +Wait for pause init +Wait for pause init +test_cid = 497 +Program loaded +*** Error: out_of_memory +*** In: take +*** After: 100 + + + In context: 497 + Current intermediate result: 100 + + Current local environment: + + + Current global environment: + iota = (closure (n) (range 0 n) nil) + + + Stack: + CONT[0] + 0u + ~CHANNEL~ + CONT[20] + ~CHANNEL~ + nil + CONT[17] + ~CHANNEL~ + 1u + CONT[15] + check + nil + nil + 1u + CONT[5] + eq + nil + ((iota 100)) + 1u + CONT[5] + take + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 + 100 +Thread 497 finished: out_of_memory +experiment failed due to taking longer than 10 seconds +------------------------------------------------------------ +Heap size: 1024 +Streaming source: yes +Incremental read: no +------------------------------------------------------------ +Opening file: tests/test_take_iota_0.lisp +Memory initialized. +LBM Initialized +Constants memory initialized +Events initialized. +Array extensions initialized. +Math extensions initialized. +String extensions initialized. +Runtime extensions initialized. +Matvec extensions initialized. +Random extensions initialized. +Loop extensions initialized. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Result check extension added. +extension load extension added. +LBM memory free: 3599 words, 14396 bytes +Wait for pause init +Wait for pause init +test_cid = 497 +Program loaded +*** Error: out_of_memory +*** In: take +*** After: 100 + + + In context: 497 + Current intermediate result: 100 + + Current local environment: + + + Current global environment: + iota = (closure (n) (range 0 n) nil) + + + Stack: + CONT[0] + CONT[0] + check + nil + nil + 1u + CONT[5] + eq + nil + ((iota 100)) + 1u + CONT[5] + take + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 + 100 +Thread 497 finished: out_of_memory +experiment failed due to taking longer than 10 seconds +------------------------------------------------------------ +Heap size: 1024 +Streaming source: yes +Incremental read: yes +------------------------------------------------------------ +Opening file: tests/test_take_iota_0.lisp +Memory initialized. +LBM Initialized +Constants memory initialized +Events initialized. +Array extensions initialized. +Math extensions initialized. +String extensions initialized. +Runtime extensions initialized. +Matvec extensions initialized. +Random extensions initialized. +Loop extensions initialized. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Result check extension added. +extension load extension added. +LBM memory free: 3599 words, 14396 bytes +Wait for pause init +Wait for pause init +test_cid = 497 +Program loaded +*** Error: out_of_memory +*** In: take +*** After: 100 + + + In context: 497 + Current intermediate result: 100 + + Current local environment: + + + Current global environment: + iota = (closure (n) (range 0 n) nil) + + + Stack: + CONT[0] + 0u + ~CHANNEL~ + CONT[20] + ~CHANNEL~ + nil + CONT[17] + ~CHANNEL~ + 1u + CONT[15] + check + nil + nil + 1u + CONT[5] + eq + nil + ((iota 100)) + 1u + CONT[5] + take + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 + 100 +Thread 497 finished: out_of_memory +experiment failed due to taking longer than 10 seconds +------------------------------------------------------------ +Heap size: 512 +Streaming source: no +Incremental read: no +------------------------------------------------------------ +Opening file: tests/test_take_iota_0.lisp +Memory initialized. +LBM Initialized +Constants memory initialized +Events initialized. +Array extensions initialized. +Math extensions initialized. +String extensions initialized. +Runtime extensions initialized. +Matvec extensions initialized. +Random extensions initialized. +Loop extensions initialized. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Result check extension added. +extension load extension added. +LBM memory free: 3599 words, 14396 bytes +Wait for pause init +Wait for pause init +test_cid = 497 +Program loaded +*** Error: out_of_memory +*** In: range +*** After: n + + + In context: 497 + Current intermediate result: n + + Current local environment: + n = 1000 + + + Current global environment: + iota = (closure (n) (range 0 n) nil) + + + Stack: + CONT[0] + CONT[0] + check + nil + nil + 1u + CONT[5] + eq + nil + ((iota 100)) + 1u + CONT[5] + take + nil + (100) + 1u + CONT[5] + range + 0 + 1000 +Thread 497 finished: out_of_memory +experiment failed due to taking longer than 10 seconds +------------------------------------------------------------ +Heap size: 512 +Streaming source: no +Incremental read: yes +------------------------------------------------------------ +Opening file: tests/test_take_iota_0.lisp +Memory initialized. +LBM Initialized +Constants memory initialized +Events initialized. +Array extensions initialized. +Math extensions initialized. +String extensions initialized. +Runtime extensions initialized. +Matvec extensions initialized. +Random extensions initialized. +Loop extensions initialized. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Result check extension added. +extension load extension added. +LBM memory free: 3599 words, 14396 bytes +Wait for pause init +Wait for pause init +test_cid = 497 +Program loaded +*** Error: out_of_memory +*** In: range +*** After: n + + + In context: 497 + Current intermediate result: n + + Current local environment: + n = 1000 + + + Current global environment: + iota = (closure (n) (range 0 n) nil) + + + Stack: + CONT[0] + 0u + ~CHANNEL~ + CONT[20] + ~CHANNEL~ + nil + CONT[17] + ~CHANNEL~ + 1u + CONT[15] + check + nil + nil + 1u + CONT[5] + eq + nil + ((iota 100)) + 1u + CONT[5] + take + nil + (100) + 1u + CONT[5] + range + 0 + 1000 +Thread 497 finished: out_of_memory +experiment failed due to taking longer than 10 seconds +------------------------------------------------------------ +Heap size: 512 +Streaming source: yes +Incremental read: no +------------------------------------------------------------ +Opening file: tests/test_take_iota_0.lisp +Memory initialized. +LBM Initialized +Constants memory initialized +Events initialized. +Array extensions initialized. +Math extensions initialized. +String extensions initialized. +Runtime extensions initialized. +Matvec extensions initialized. +Random extensions initialized. +Loop extensions initialized. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Result check extension added. +extension load extension added. +LBM memory free: 3599 words, 14396 bytes +Wait for pause init +Wait for pause init +test_cid = 497 +Program loaded +*** Error: out_of_memory +*** In: range +*** After: n + + + In context: 497 + Current intermediate result: n + + Current local environment: + n = 1000 + + + Current global environment: + iota = (closure (n) (range 0 n) nil) + + + Stack: + CONT[0] + CONT[0] + check + nil + nil + 1u + CONT[5] + eq + nil + ((iota 100)) + 1u + CONT[5] + take + nil + (100) + 1u + CONT[5] + range + 0 + 1000 +Thread 497 finished: out_of_memory +experiment failed due to taking longer than 10 seconds +------------------------------------------------------------ +Heap size: 512 +Streaming source: yes +Incremental read: yes +------------------------------------------------------------ +Opening file: tests/test_take_iota_0.lisp +Memory initialized. +LBM Initialized +Constants memory initialized +Events initialized. +Array extensions initialized. +Math extensions initialized. +String extensions initialized. +Runtime extensions initialized. +Matvec extensions initialized. +Random extensions initialized. +Loop extensions initialized. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Result check extension added. +extension load extension added. +LBM memory free: 3599 words, 14396 bytes +Wait for pause init +Wait for pause init +test_cid = 497 +Program loaded +*** Error: out_of_memory +*** In: range +*** After: n + + + In context: 497 + Current intermediate result: n + + Current local environment: + n = 1000 + + + Current global environment: + iota = (closure (n) (range 0 n) nil) + + + Stack: + CONT[0] + 0u + ~CHANNEL~ + CONT[20] + ~CHANNEL~ + nil + CONT[17] + ~CHANNEL~ + 1u + CONT[15] + check + nil + nil + 1u + CONT[5] + eq + nil + ((iota 100)) + 1u + CONT[5] + take + nil + (100) + 1u + CONT[5] + range + 0 + 1000 +Thread 497 finished: out_of_memory +experiment failed due to taking longer than 10 seconds diff --git a/test_reports/version_0.25.0/failing_unit_tests_log_64_0.25.0.txt b/test_reports/version_0.25.0/failing_unit_tests_log_64_0.25.0.txt new file mode 100644 index 00000000..c4f853f0 --- /dev/null +++ b/test_reports/version_0.25.0/failing_unit_tests_log_64_0.25.0.txt @@ -0,0 +1,616 @@ +------------------------------------------------------------ +Heap size: 1024 +Streaming source: no +Incremental read: no +------------------------------------------------------------ +Opening file: tests/test_take_iota_0.lisp +Memory initialized. +LBM Initialized +Constants memory initialized +Events initialized. +Array extensions initialized. +Math extensions initialized. +String extensions initialized. +Runtime extensions initialized. +Matvec extensions initialized. +Random extensions initialized. +Loop extensions initialized. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Result check extension added. +extension load extension added. +LBM memory free: 3599 words, 14396 bytes +Wait for pause init +Wait for pause init +test_cid = 497 +Program loaded +*** Error: out_of_memory +*** In: take +*** After: 100 + + + In context: 497 + Current intermediate result: 100 + + Current local environment: + + + Current global environment: + iota = (closure (n) (range 0 n) nil) + + + Stack: + CONT[0] + CONT[0] + check + nil + nil + 1u + CONT[5] + eq + nil + ((iota 100)) + 1u + CONT[5] + take + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 + 100 +Thread 497 finished: out_of_memory +experiment failed due to taking longer than 10 seconds +------------------------------------------------------------ +Heap size: 1024 +Streaming source: no +Incremental read: yes +------------------------------------------------------------ +Opening file: tests/test_take_iota_0.lisp +Memory initialized. +LBM Initialized +Constants memory initialized +Events initialized. +Array extensions initialized. +Math extensions initialized. +String extensions initialized. +Runtime extensions initialized. +Matvec extensions initialized. +Random extensions initialized. +Loop extensions initialized. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Result check extension added. +extension load extension added. +LBM memory free: 3599 words, 14396 bytes +Wait for pause init +Wait for pause init +test_cid = 497 +Program loaded +*** Error: out_of_memory +*** In: take +*** After: 100 + + + In context: 497 + Current intermediate result: 100 + + Current local environment: + + + Current global environment: + iota = (closure (n) (range 0 n) nil) + + + Stack: + CONT[0] + 0u + ~CHANNEL~ + CONT[20] + ~CHANNEL~ + nil + CONT[17] + ~CHANNEL~ + 1u + CONT[15] + check + nil + nil + 1u + CONT[5] + eq + nil + ((iota 100)) + 1u + CONT[5] + take + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 + 100 +Thread 497 finished: out_of_memory +experiment failed due to taking longer than 10 seconds +------------------------------------------------------------ +Heap size: 1024 +Streaming source: yes +Incremental read: no +------------------------------------------------------------ +Opening file: tests/test_take_iota_0.lisp +Memory initialized. +LBM Initialized +Constants memory initialized +Events initialized. +Array extensions initialized. +Math extensions initialized. +String extensions initialized. +Runtime extensions initialized. +Matvec extensions initialized. +Random extensions initialized. +Loop extensions initialized. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Result check extension added. +extension load extension added. +LBM memory free: 3599 words, 14396 bytes +Wait for pause init +Wait for pause init +test_cid = 497 +Program loaded +*** Error: out_of_memory +*** In: take +*** After: 100 + + + In context: 497 + Current intermediate result: 100 + + Current local environment: + + + Current global environment: + iota = (closure (n) (range 0 n) nil) + + + Stack: + CONT[0] + CONT[0] + check + nil + nil + 1u + CONT[5] + eq + nil + ((iota 100)) + 1u + CONT[5] + take + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 + 100 +Thread 497 finished: out_of_memory +experiment failed due to taking longer than 10 seconds +------------------------------------------------------------ +Heap size: 1024 +Streaming source: yes +Incremental read: yes +------------------------------------------------------------ +Opening file: tests/test_take_iota_0.lisp +Memory initialized. +LBM Initialized +Constants memory initialized +Events initialized. +Array extensions initialized. +Math extensions initialized. +String extensions initialized. +Runtime extensions initialized. +Matvec extensions initialized. +Random extensions initialized. +Loop extensions initialized. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Result check extension added. +extension load extension added. +LBM memory free: 3599 words, 14396 bytes +Wait for pause init +Wait for pause init +test_cid = 497 +Program loaded +*** Error: out_of_memory +*** In: take +*** After: 100 + + + In context: 497 + Current intermediate result: 100 + + Current local environment: + + + Current global environment: + iota = (closure (n) (range 0 n) nil) + + + Stack: + CONT[0] + 0u + ~CHANNEL~ + CONT[20] + ~CHANNEL~ + nil + CONT[17] + ~CHANNEL~ + 1u + CONT[15] + check + nil + nil + 1u + CONT[5] + eq + nil + ((iota 100)) + 1u + CONT[5] + take + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 + 100 +Thread 497 finished: out_of_memory +experiment failed due to taking longer than 10 seconds +------------------------------------------------------------ +Heap size: 512 +Streaming source: no +Incremental read: no +------------------------------------------------------------ +Opening file: tests/test_take_iota_0.lisp +Memory initialized. +LBM Initialized +Constants memory initialized +Events initialized. +Array extensions initialized. +Math extensions initialized. +String extensions initialized. +Runtime extensions initialized. +Matvec extensions initialized. +Random extensions initialized. +Loop extensions initialized. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Result check extension added. +extension load extension added. +LBM memory free: 3599 words, 14396 bytes +Wait for pause init +Wait for pause init +test_cid = 497 +Program loaded +*** Error: out_of_memory +*** In: range +*** After: n + + + In context: 497 + Current intermediate result: n + + Current local environment: + n = 1000 + + + Current global environment: + iota = (closure (n) (range 0 n) nil) + + + Stack: + CONT[0] + CONT[0] + check + nil + nil + 1u + CONT[5] + eq + nil + ((iota 100)) + 1u + CONT[5] + take + nil + (100) + 1u + CONT[5] + range + 0 + 1000 +Thread 497 finished: out_of_memory +experiment failed due to taking longer than 10 seconds +------------------------------------------------------------ +Heap size: 512 +Streaming source: no +Incremental read: yes +------------------------------------------------------------ +Opening file: tests/test_take_iota_0.lisp +Memory initialized. +LBM Initialized +Constants memory initialized +Events initialized. +Array extensions initialized. +Math extensions initialized. +String extensions initialized. +Runtime extensions initialized. +Matvec extensions initialized. +Random extensions initialized. +Loop extensions initialized. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Result check extension added. +extension load extension added. +LBM memory free: 3599 words, 14396 bytes +Wait for pause init +Wait for pause init +test_cid = 497 +Program loaded +*** Error: out_of_memory +*** In: range +*** After: n + + + In context: 497 + Current intermediate result: n + + Current local environment: + n = 1000 + + + Current global environment: + iota = (closure (n) (range 0 n) nil) + + + Stack: + CONT[0] + 0u + ~CHANNEL~ + CONT[20] + ~CHANNEL~ + nil + CONT[17] + ~CHANNEL~ + 1u + CONT[15] + check + nil + nil + 1u + CONT[5] + eq + nil + ((iota 100)) + 1u + CONT[5] + take + nil + (100) + 1u + CONT[5] + range + 0 + 1000 +Thread 497 finished: out_of_memory +experiment failed due to taking longer than 10 seconds +------------------------------------------------------------ +Heap size: 512 +Streaming source: yes +Incremental read: no +------------------------------------------------------------ +Opening file: tests/test_take_iota_0.lisp +Memory initialized. +LBM Initialized +Constants memory initialized +Events initialized. +Array extensions initialized. +Math extensions initialized. +String extensions initialized. +Runtime extensions initialized. +Matvec extensions initialized. +Random extensions initialized. +Loop extensions initialized. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Result check extension added. +extension load extension added. +LBM memory free: 3599 words, 14396 bytes +Wait for pause init +Wait for pause init +test_cid = 497 +Program loaded +*** Error: out_of_memory +*** In: range +*** After: n + + + In context: 497 + Current intermediate result: n + + Current local environment: + n = 1000 + + + Current global environment: + iota = (closure (n) (range 0 n) nil) + + + Stack: + CONT[0] + CONT[0] + check + nil + nil + 1u + CONT[5] + eq + nil + ((iota 100)) + 1u + CONT[5] + take + nil + (100) + 1u + CONT[5] + range + 0 + 1000 +Thread 497 finished: out_of_memory +experiment failed due to taking longer than 10 seconds +------------------------------------------------------------ +Heap size: 512 +Streaming source: yes +Incremental read: yes +------------------------------------------------------------ +Opening file: tests/test_take_iota_0.lisp +Memory initialized. +LBM Initialized +Constants memory initialized +Events initialized. +Array extensions initialized. +Math extensions initialized. +String extensions initialized. +Runtime extensions initialized. +Matvec extensions initialized. +Random extensions initialized. +Loop extensions initialized. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Extension added. +Result check extension added. +extension load extension added. +LBM memory free: 3599 words, 14396 bytes +Wait for pause init +Wait for pause init +test_cid = 497 +Program loaded +*** Error: out_of_memory +*** In: range +*** After: n + + + In context: 497 + Current intermediate result: n + + Current local environment: + n = 1000 + + + Current global environment: + iota = (closure (n) (range 0 n) nil) + + + Stack: + CONT[0] + 0u + ~CHANNEL~ + CONT[20] + ~CHANNEL~ + nil + CONT[17] + ~CHANNEL~ + 1u + CONT[15] + check + nil + nil + 1u + CONT[5] + eq + nil + ((iota 100)) + 1u + CONT[5] + take + nil + (100) + 1u + CONT[5] + range + 0 + 1000 +Thread 497 finished: out_of_memory +experiment failed due to taking longer than 10 seconds diff --git a/test_reports/version_0.25.0/gc_unit_tests_log_0.25.0.txt b/test_reports/version_0.25.0/gc_unit_tests_log_0.25.0.txt new file mode 100644 index 00000000..e003c4f8 --- /dev/null +++ b/test_reports/version_0.25.0/gc_unit_tests_log_0.25.0.txt @@ -0,0 +1,82 @@ +BUILDING +rm *.exe +rm test_lisp_code_cps +gcc -g -O2 -Wall -Wextra -Wshadow -Wconversion -Wclobbered -pedantic -std=c99 -m32 ..//src/env.c ..//src/fundamental.c ..//src/heap.c ..//src/lbm_memory.c ..//src/print.c ..//src/stack.c ..//src/symrepr.c ..//src/tokpar.c ..//src/extensions.c ..//src/lispbm.c ..//src/eval_cps.c ..//src/lbm_c_interop.c ..//src/lbm_custom_type.c ..//src/lbm_channel.c ..//src/lbm_flat_value.c ..//src/lbm_flags.c ..//src/lbm_prof.c ..//src/extensions/array_extensions.c ..//src/extensions/string_extensions.c ..//src/extensions/math_extensions.c ..//src/extensions/runtime_extensions.c ..//src/extensions/matvec_extensions.c ..//src/extensions/random_extensions.c ..//src/extensions/loop_extensions.c ..//src/extensions/set_extensions.c ..//platform/linux/src/platform_mutex.c -lm test_lisp_code_cps.c -o test_lisp_code_cps.exe -I../include -I..//platform/linux/include -lpthread -lm +gcc -g -O2 -Wall -Wextra -Wshadow -Wconversion -Wclobbered -pedantic -std=c99 -m32 ..//src/env.c ..//src/fundamental.c ..//src/heap.c ..//src/lbm_memory.c ..//src/print.c ..//src/stack.c ..//src/symrepr.c ..//src/tokpar.c ..//src/extensions.c ..//src/lispbm.c ..//src/eval_cps.c ..//src/lbm_c_interop.c ..//src/lbm_custom_type.c ..//src/lbm_channel.c ..//src/lbm_flat_value.c ..//src/lbm_flags.c ..//src/lbm_prof.c ..//src/extensions/array_extensions.c ..//src/extensions/string_extensions.c ..//src/extensions/math_extensions.c ..//src/extensions/runtime_extensions.c ..//src/extensions/matvec_extensions.c ..//src/extensions/random_extensions.c ..//src/extensions/loop_extensions.c ..//src/extensions/set_extensions.c ..//platform/linux/src/platform_mutex.c -lm test_enc_dec.c -o test_enc_dec.exe -I../include -I..//platform/linux/include -lpthread -lm +gcc -g -O2 -Wall -Wextra -Wshadow -Wconversion -Wclobbered -pedantic -std=c99 -m32 ..//src/env.c ..//src/fundamental.c ..//src/heap.c ..//src/lbm_memory.c ..//src/print.c ..//src/stack.c ..//src/symrepr.c ..//src/tokpar.c ..//src/extensions.c ..//src/lispbm.c ..//src/eval_cps.c ..//src/lbm_c_interop.c ..//src/lbm_custom_type.c ..//src/lbm_channel.c ..//src/lbm_flat_value.c ..//src/lbm_flags.c ..//src/lbm_prof.c ..//src/extensions/array_extensions.c ..//src/extensions/string_extensions.c ..//src/extensions/math_extensions.c ..//src/extensions/runtime_extensions.c ..//src/extensions/matvec_extensions.c ..//src/extensions/random_extensions.c ..//src/extensions/loop_extensions.c ..//src/extensions/set_extensions.c ..//platform/linux/src/platform_mutex.c -lm test_heap_alloc.c -o test_heap_alloc.exe -I../include -I..//platform/linux/include -lpthread -lm +mv test_lisp_code_cps.exe test_lisp_code_cps +PERFORMING TESTS: 2024-07-23_15-17 +DEC/ENC 0: ok +DEC/ENC 1: ok +DEC/ENC 2: ok +DEC/ENC 3: ok +DEC/ENC 4: ok +DEC/ENC 5: ok +DEC/ENC 6: ok +DEC/ENC 7: ok +DEC/ENC 8: ok +DEC/ENC 9: ok +DEC/ENC 10: ok +DEC/ENC 11: ok +DEC/ENC 12: ok +DEC/ENC 13: ok +DEC/ENC 14: ok +DEC/ENC 15: ok +------------------------------------------------------------ +test_enc_dec.exe SUCCESS +------------------------------------------------------------ +Initialized symrepr: OK +Initialized heap: OK +Allocated 1048576 heap cells: OK +HEAP allocation when full test: OK +------------------------------------------------------------ +test_heap_alloc.exe SUCCESS +------------------------------------------------------------ +Configuration: -t 25 -h 32768 +Configuration: -t 25 -i -h 32768 +Configuration: -t 25 -s -h 32768 +Configuration: -t 25 -i -s -h 32768 +Configuration: -t 25 -h 16384 +Configuration: -t 25 -i -h 16384 +Configuration: -t 25 -s -h 16384 +Configuration: -t 25 -i -s -h 16384 +Configuration: -t 25 -h 8192 +Configuration: -t 25 -i -h 8192 +Configuration: -t 25 -s -h 8192 +Configuration: -t 25 -i -s -h 8192 +Configuration: -t 25 -h 4096 +Configuration: -t 25 -i -h 4096 +Configuration: -t 25 -s -h 4096 +Configuration: -t 25 -i -s -h 4096 +Configuration: -t 25 -h 2048 +Configuration: -t 25 -i -h 2048 +Configuration: -t 25 -s -h 2048 +Configuration: -t 25 -i -s -h 2048 +Configuration: -t 25 -h 1024 +tests/test_take_iota_0.lisp FAILED +Configuration: -t 25 -i -h 1024 +tests/test_take_iota_0.lisp FAILED +Configuration: -t 25 -s -h 1024 +tests/test_take_iota_0.lisp FAILED +Configuration: -t 25 -i -s -h 1024 +tests/test_take_iota_0.lisp FAILED +Configuration: -t 25 -h 512 +tests/test_take_iota_0.lisp FAILED +Configuration: -t 25 -i -h 512 +tests/test_take_iota_0.lisp FAILED +Configuration: -t 25 -s -h 512 +tests/test_take_iota_0.lisp FAILED +Configuration: -t 25 -i -s -h 512 +tests/test_take_iota_0.lisp FAILED +(OK - expected to fail) test_lisp_code_cps -t 25 -h 1024 tests/test_take_iota_0.lisp +(OK - expected to fail) test_lisp_code_cps -t 25 -i -h 1024 tests/test_take_iota_0.lisp +(OK - expected to fail) test_lisp_code_cps -t 25 -s -h 1024 tests/test_take_iota_0.lisp +(OK - expected to fail) test_lisp_code_cps -t 25 -i -s -h 1024 tests/test_take_iota_0.lisp +(OK - expected to fail) test_lisp_code_cps -t 25 -h 512 tests/test_take_iota_0.lisp +(OK - expected to fail) test_lisp_code_cps -t 25 -i -h 512 tests/test_take_iota_0.lisp +(OK - expected to fail) test_lisp_code_cps -t 25 -s -h 512 tests/test_take_iota_0.lisp +(OK - expected to fail) test_lisp_code_cps -t 25 -i -s -h 512 tests/test_take_iota_0.lisp +Tests passed: 17410 +Tests failed: 8 +Expected fails: 8 +Actual fails: 0 diff --git a/test_reports/version_0.25.0/infer_0.25.0.txt b/test_reports/version_0.25.0/infer_0.25.0.txt new file mode 100644 index 00000000..2b891de5 --- /dev/null +++ b/test_reports/version_0.25.0/infer_0.25.0.txt @@ -0,0 +1,984 @@ +#0 +src/print.c:67: error: Null Dereference + pointer `array` last assigned on line 61 could be null and is dereferenced at line 67, column 28. + 65. // Highly unlikely that array is a recognizable NULL though. + 66. // If it is incorrect, it is most likely arbitrary. + 67. char *c_data = (char *)array->data; + ^ + 68. if (array->size == 1) { + 69. *str = c_data; + +#1 +include/lbm_custom_type.h:69: error: Null Dereference + pointer `m` last assigned on line 68 could be null and is dereferenced at line 69, column 25. + 67. if (lbm_type_of(value) == LBM_TYPE_CUSTOM) { + 68. lbm_uint *m = (lbm_uint*)lbm_dec_custom(value); + 69. return (const char*)m[CUSTOM_TYPE_DESCRIPTOR]; + ^ + 70. } + 71. return NULL; + +#2 +include/lbm_custom_type.h:76: error: Null Dereference + pointer `m` last assigned on line 75 could be null and is dereferenced at line 76, column 10. + 74. static inline lbm_uint lbm_get_custom_value(lbm_value value) { + 75. lbm_uint *m = (lbm_uint*)lbm_dec_custom(value); + 76. return m[CUSTOM_TYPE_VALUE]; + ^ + 77. } + 78. + +#3 +src/extensions/array_extensions.c:105: error: Null Dereference + pointer `array` last assigned on line 104 could be null and is dereferenced at line 105, column 29. + 103. } + 104. lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]); + 105. if (lbm_memory_ptr_inside(array->data)) { + ^ + 106. lbm_memory_free((lbm_uint *)array->data); + 107. lbm_uint ptr = lbm_dec_ptr(args[0]); + +#4 +src/extensions/array_extensions.c:131: error: Null Dereference + pointer `array` last assigned on line 127 could be null and is dereferenced at line 131, column 18. + 129. lbm_int value = lbm_dec_as_i32(args[2]); + 130. + 131. if (index >= array->size) { + ^ + 132. return res; + 133. } + +#5 +src/heap.c:128: error: Dead Store + The value written to `&res` (type `unsigned int`) is never used. + 126. + 127. static lbm_value enc_64_on_32(uint8_t *source, lbm_uint type_qual, lbm_uint type) { + 128. lbm_value res = ENC_SYM_MERROR; + ^ + 129. res = lbm_cons(ENC_SYM_NIL,ENC_SYM_NIL); + 130. if (lbm_type_of(res) != LBM_TYPE_SYMBOL) { + +#6 +src/heap.c:197: error: Null Dereference + pointer `data` last assigned on line 196 could be null and is dereferenced by call to `memcpy()` at line 197, column 3. + 195. double d; + 196. uint32_t *data = (uint32_t*)lbm_car(x); + 197. memcpy(&d, data, sizeof(double)); + ^ + 198. return d; + 199. #else + +#7 +src/heap.c:211: error: Null Dereference + pointer `data` last assigned on line 210 could be null and is dereferenced by call to `memcpy()` at line 211, column 3. + 209. uint64_t u; + 210. uint32_t *data = (uint32_t*)lbm_car(x); + 211. memcpy(&u, data, 8); + ^ + 212. return u; + 213. #else + +#8 +src/heap.c:222: error: Null Dereference + pointer `data` last assigned on line 221 could be null and is dereferenced by call to `memcpy()` at line 222, column 3. + 220. int64_t i; + 221. uint32_t *data = (uint32_t*)lbm_car(x); + 222. memcpy(&i, data, 8); + ^ + 223. return i; + 224. #else + +#9 +src/heap.c:234: error: Null Dereference + pointer `array` last assigned on line 233 could be null and is dereferenced at line 234, column 19. + 232. if (lbm_is_array_r(val)) { + 233. lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(val); + 234. res = (char *)array->data; + ^ + 235. } + 236. return res; + +#10 +src/lbm_flat_value.c:277: error: Null Dereference + pointer `header` last assigned on line 276 could be null and is dereferenced at line 277, column 38. + 275. int sum = 4 + 1; // sizeof(uint32_t) + 1; + 276. lbm_array_header_t *header = (lbm_array_header_t*)lbm_car(v); + 277. lbm_value *arrdata = (lbm_value*)header->data; + ^ + 278. lbm_uint size = header->size / sizeof(lbm_value); + 279. for (lbm_uint i = 0; i < size; i ++ ) { + +#11 +src/fundamental.c:263: error: Null Dereference + pointer `a_` last assigned on line 255 could be null and is dereferenced at line 263, column 9. + 261. // if (a_ == NULL || b_ == NULL) return false; // Not possible to properly report error from here. + 262. + 263. if (a_->size == b_->size) { + ^ + 264. return (memcmp((char*)a_->data, (char*)b_->data, a_->size) == 0); + 265. } + +#12 +src/fundamental.c:263: error: Null Dereference + pointer `b_` last assigned on line 256 could be null and is dereferenced at line 263, column 21. + 261. // if (a_ == NULL || b_ == NULL) return false; // Not possible to properly report error from here. + 262. + 263. if (a_->size == b_->size) { + ^ + 264. return (memcmp((char*)a_->data, (char*)b_->data, a_->size) == 0); + 265. } + +#13 +src/print.c:270: error: Null Dereference + pointer `array` last assigned on line 269 could be null and is dereferenced by call to `print_emit_array_data()` at line 270, column 10. + 268. + 269. lbm_array_header_t *array = (lbm_array_header_t*)lbm_car(v); + 270. return print_emit_array_data(chan, array); + ^ + 271. } + 272. + +#14 +src/fundamental.c:274: error: Null Dereference + pointer `a_` last assigned on line 272 could be null and is dereferenced at line 274, column 36. + 272. lbm_array_header_t *a_ = (lbm_array_header_t*)lbm_car(a); + 273. lbm_array_header_t *b_ = (lbm_array_header_t*)lbm_car(b); + 274. lbm_value *adata = (lbm_value*)a_->data; + ^ + 275. lbm_value *bdata = (lbm_value*)b_->data; + 276. if ( a_->size == b_->size) { + +#15 +src/fundamental.c:275: error: Null Dereference + pointer `b_` last assigned on line 273 could be null and is dereferenced at line 275, column 36. + 273. lbm_array_header_t *b_ = (lbm_array_header_t*)lbm_car(b); + 274. lbm_value *adata = (lbm_value*)a_->data; + 275. lbm_value *bdata = (lbm_value*)b_->data; + ^ + 276. if ( a_->size == b_->size) { + 277. uint32_t size = a_->size / (sizeof(lbm_value)); + +#16 +src/extensions/array_extensions.c:300: error: Null Dereference + pointer `array` last assigned on line 295 could be null and is dereferenced at line 300, column 18. + 298. lbm_uint value = lbm_dec_as_u32(args[2]); + 299. + 300. if (index >= array->size) { + ^ + 301. return res; + 302. } + +#17 +src/lbm_c_interop.c:292: error: Null Dereference + pointer `array` last assigned on line 291 could be null and is dereferenced at line 292, column 11. + 290. + 291. lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(fv); + 292. *size = array->size; + ^ + 293. *data = array->data; + 294. return true; + +#18 +src/lbm_flat_value.c:350: error: Null Dereference + pointer `header` last assigned on line 349 could be null and is dereferenced at line 350, column 38. + 348. case LBM_TYPE_LISPARRAY: { + 349. lbm_array_header_t *header = (lbm_array_header_t*)lbm_car(v); + 350. lbm_value *arrdata = (lbm_value*)header->data; + ^ + 351. lbm_uint size = header->size / sizeof(lbm_value); + 352. if (!f_lisp_array(fv, size)) return FLATTEN_VALUE_ERROR_NOT_ENOUGH_MEMORY; + +#19 +src/extensions/string_extensions.c:548: error: Null Dereference + pointer `array` last assigned on line 546 could be null and is dereferenced at line 548, column 41. + 546. lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]); + 547. + 548. return lbm_enc_i((int)strlen_max(str, array->size)); + ^ + 549. } + 550. + +#20 +src/extensions/array_extensions.c:565: error: Null Dereference + pointer `array` last assigned on line 560 could be null and is dereferenced at line 565, column 18. + 563. lbm_uint value = 0; + 564. + 565. if (index >= array->size) { + ^ + 566. return res; + 567. } + +#21 +src/extensions/array_extensions.c:598: error: Null Dereference + pointer `array` last assigned on line 593 could be null and is dereferenced at line 598, column 20. + 596. lbm_uint value = 0; + 597. + 598. if (index+1 >= array->size) { + ^ + 599. return res; + 600. } + +#22 +src/extensions/string_extensions.c:630: error: Null Dereference + pointer `header` last assigned on line 627 could be null and is dereferenced at line 630, column 30. + 628. (lbm_array_header_t *)lbm_car(lbm_car(current)); + 629. + 630. lbm_int len = (lbm_int)header->size - 1; + ^ + 631. if (len < 0) { + 632. // substr is zero length array + +#23 +src/extensions/string_extensions.c:595: error: Null Dereference + pointer `str_header` last assigned on line 594 could be null and is dereferenced at line 595, column 37. + 593. + 594. lbm_array_header_t *str_header = (lbm_array_header_t *)lbm_car(args[0]); + 595. const char *str = (const char *)str_header->data; + ^ + 596. lbm_int str_size = (lbm_int)str_header->size; + 597. + +#24 +src/extensions/array_extensions.c:643: error: Null Dereference + pointer `array` last assigned on line 638 could be null and is dereferenced at line 643, column 20. + 641. uint32_t value = 0; + 642. + 643. if (index+3 >= array->size) { + ^ + 644. return res; + 645. } + +#25 +src/extensions/array_extensions.c:684: error: Null Dereference + pointer `array` last assigned on line 679 could be null and is dereferenced at line 684, column 18. + 682. lbm_int value = 0; + 683. + 684. if (index >= array->size) { + ^ + 685. return res; + 686. } + +#26 +src/extensions/array_extensions.c:718: error: Null Dereference + pointer `array` last assigned on line 713 could be null and is dereferenced at line 718, column 20. + 716. lbm_int value = 0; + 717. + 718. if (index+1 >= array->size) { + ^ + 719. return res; + 720. } + +#27 +src/extensions/array_extensions.c:763: error: Null Dereference + pointer `array` last assigned on line 758 could be null and is dereferenced at line 763, column 20. + 761. lbm_int value = 0; + 762. + 763. if (index+2 >= array->size) { + ^ + 764. return res; + 765. } + +#28 +src/extensions/array_extensions.c:811: error: Null Dereference + pointer `array` last assigned on line 806 could be null and is dereferenced at line 811, column 20. + 809. uint32_t value = 0; + 810. + 811. if (index+3 >= array->size) { + ^ + 812. return res; + 813. } + +#29 +src/extensions/array_extensions.c:860: error: Null Dereference + pointer `array` last assigned on line 855 could be null and is dereferenced at line 860, column 20. + 858. uint32_t value = 0; + 859. + 860. if (index+3 >= array->size) { + ^ + 861. return res; + 862. } + +#30 +src/fundamental.c:854: error: Null Dereference + pointer `arr` last assigned on line 849 could be null and is dereferenced at line 854, column 25. + 852. // Check that array points into lbm_memory. + 853. // Additionally check that it is a zero-terminated string. + 854. char *str = (char *)arr->data; + ^ + 855. lbm_uint sym; + 856. if (lbm_get_symbol_by_name(str, &sym)) { + +#31 +src/extensions/array_extensions.c:892: error: Null Dereference + pointer `array` last assigned on line 891 could be null and is dereferenced at line 892, column 30. + 890. lbm_is_array_r(args[0])) { + 891. lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]); + 892. res = lbm_enc_i((lbm_int)array->size); + ^ + 893. } + 894. return res; + +#32 +src/fundamental.c:940: error: Null Dereference + pointer `header` last assigned on line 939 could be null and is dereferenced at line 940, column 40. + 938. lbm_value val = args[2]; + 939. lbm_array_header_t *header = (lbm_array_header_t*)lbm_car(args[0]); + 940. lbm_value *arrdata = (lbm_value*)header->data; + ^ + 941. lbm_uint size = header->size / sizeof(lbm_value); + 942. if (index < size) { + +#33 +src/eval_cps.c:1004: error: Null Dereference + pointer `sptr` last assigned on line 1003 could be null and is dereferenced at line 1004, column 21. + 1002. if (v == EXCEPTION_HANDLER) { + 1003. lbm_value *sptr = get_stack_ptr(ctx_running, 2); + 1004. lbm_set_car(sptr[0], ENC_SYM_EXIT_ERROR); + ^ + 1005. stack_reserve(ctx_running, 1)[0] = EXCEPTION_HANDLER; + 1006. ctx_running->app_cont = true; + +#34 +src/heap.c:1259: error: Null Dereference + pointer `header` last assigned on line 1258 could be null and is dereferenced at line 1259, column 19. + 1257. if (lbm_is_array_r(arr)) { + 1258. lbm_array_header_t *header = (lbm_array_header_t*)lbm_car(arr); + 1259. r = (uint8_t*)header->data; + ^ + 1260. } + 1261. return r; + +#35 +src/heap.c:1268: error: Null Dereference + pointer `header` last assigned on line 1267 could be null and is dereferenced at line 1268, column 19. + 1266. if (lbm_is_array_rw(arr)) { + 1267. lbm_array_header_t *header = (lbm_array_header_t*)lbm_car(arr); + 1268. r = (uint8_t*)header->data; + ^ + 1269. } + 1270. return r; + +#36 +src/fundamental.c:1380: error: Null Dereference + pointer `header` last assigned on line 1379 could be null and is dereferenced at line 1380, column 38. + 1378. if (nargs == 1 && lbm_is_lisp_array_r(args[0])) { + 1379. lbm_array_header_t *header = (lbm_array_header_t*)lbm_car(args[0]); + 1380. lbm_value *arrdata = (lbm_value*)header->data; + ^ + 1381. lbm_uint size = (header->size / sizeof(lbm_uint)); + 1382. res = lbm_heap_allocate_list(size); + +#37 +src/eval_cps.c:1585: error: Null Dereference + pointer `sptr` last assigned on line 1584 could be null and is dereferenced at line 1585, column 5. + 1583. } + 1584. lbm_value *sptr = stack_reserve(ctx, 3); + 1585. sptr[0] = ctx->curr_exp; + ^ + 1586. sptr[1] = ctx->curr_env; + 1587. sptr[2] = RESUME; + +#38 +src/eval_cps.c:1629: error: Null Dereference + pointer `sptr` last assigned on line 1628 could be null and is dereferenced at line 1629, column 5. + 1627. if (lbm_is_cons(exps)) { + 1628. lbm_uint *sptr = stack_reserve(ctx, 4); + 1629. sptr[0] = ctx->curr_env; // env to restore between expressions in progn + ^ + 1630. sptr[1] = lbm_enc_u(0); // Has env been copied (needed for progn local bindings) + 1631. sptr[3] = PROGN_REST; + +#39 +src/eval_cps.c:1685: error: Null Dereference + pointer `sptr` last assigned on line 1682 could be null and is dereferenced at line 1685, column 5. + 1683. if (lbm_is_symbol(parts[KEY]) && lbm_is_symbol_nil(rest)) { + 1684. lbm_uint sym_val = lbm_dec_sym(parts[KEY]); + 1685. sptr[0] = parts[KEY]; + ^ + 1686. if (sym_val >= RUNTIME_SYMBOLS_START) { + 1687. sptr[1] = SET_GLOBAL_ENV; + +#40 +src/eval_cps.c:1744: error: Null Dereference + pointer `sptr` last assigned on line 1743 could be null and is dereferenced at line 1744, column 3. + 1742. lbm_value cdr = get_cdr(ctx->curr_exp); + 1743. lbm_value *sptr = stack_reserve(ctx, 3); + 1744. sptr[0] = get_cdr(cdr); + ^ + 1745. sptr[1] = ctx->curr_env; + 1746. sptr[2] = IF; + +#41 +src/eval_cps.c:1867: error: Null Dereference + pointer `sptr` last assigned on line 1866 could be null and is dereferenced at line 1867, column 3. + 1865. + 1866. lbm_uint *sptr = stack_reserve(ctx, 5); + 1867. sptr[0] = exp; + ^ + 1868. sptr[1] = cdr_binds; + 1869. sptr[2] = env; + +#42 +src/eval_cps.c:1929: error: Null Dereference + pointer `sptr` last assigned on line 1928 could be null and is dereferenced at line 1929, column 3. + 1927. extract_n(ctx->curr_exp, parts, 3); + 1928. lbm_value *sptr = stack_reserve(ctx, 3); + 1929. sptr[0] = ctx->curr_env; + ^ + 1930. sptr[1] = parts[1]; + 1931. sptr[2] = SETQ; + +#43 +src/eval_cps.c:1938: error: Null Dereference + pointer `sptr` last assigned on line 1937 could be null and is dereferenced at line 1938, column 3. + 1936. lbm_value args = get_cdr(ctx->curr_exp); + 1937. lbm_value *sptr = stack_reserve(ctx,2); + 1938. sptr[0] = args; + ^ + 1939. sptr[1] = MOVE_TO_FLASH; + 1940. ctx->app_cont = true; + +#44 +src/eval_cps.c:1951: error: Null Dereference + pointer `sptr` last assigned on line 1950 could be null and is dereferenced at line 1951, column 3. + 1949. extract_n(get_cdr(ctx->curr_exp), parts, 3); + 1950. lbm_value *sptr = stack_reserve(ctx, 3); + 1951. sptr[0] = parts[LOOP_BODY]; + ^ + 1952. sptr[1] = parts[LOOP_COND]; + 1953. sptr[2] = LOOP_CONDITION; + +#45 +src/eval_cps.c:1995: error: Null Dereference + pointer `sptr` last assigned on line 1994 could be null and is dereferenced at line 1995, column 5. + 1993. } else { + 1994. lbm_value *sptr = stack_reserve(ctx, 3); + 1995. sptr[0] = ctx->curr_env; + ^ + 1996. sptr[1] = get_cdr(rest); + 1997. sptr[2] = AND; + +#46 +src/eval_cps.c:2010: error: Null Dereference + pointer `sptr` last assigned on line 2009 could be null and is dereferenced at line 2010, column 5. + 2008. } else { + 2009. lbm_value *sptr = stack_reserve(ctx, 3); + 2010. sptr[0] = ctx->curr_env; + ^ + 2011. sptr[1] = get_cdr(rest); + 2012. sptr[2] = OR; + +#47 +src/eval_cps.c:2042: error: Null Dereference + pointer `sptr` last assigned on line 2041 could be null and is dereferenced at line 2042, column 5. + 2040. get_car_and_cdr(rest, &ctx->curr_exp, &cdr_rest); + 2041. lbm_value *sptr = stack_reserve(ctx, 3); + 2042. sptr[0] = cdr_rest; + ^ + 2043. sptr[1] = ctx->curr_env; + 2044. sptr[2] = MATCH; + +#48 +src/eval_cps.c:2158: error: Null Dereference + pointer `sptr` last assigned on line 2156 could be null and is dereferenced at line 2158, column 20. + 2156. lbm_value *sptr = get_stack_ptr(ctx, 3); + 2157. + 2158. lbm_value rest = sptr[2]; + ^ + 2159. lbm_value env = sptr[0]; + 2160. + +#49 +src/eval_cps.c:2404: error: Null Dereference + pointer `sptr` last assigned on line 2403 could be null and is dereferenced at line 2404, column 5. + 2402. lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]); + 2403. lbm_value *sptr = get_stack_ptr(ctx, 2); + 2404. sptr[0] = lbm_enc_i(cid); + ^ + 2405. sptr[1] = WAIT; + 2406. ctx->r = ENC_SYM_TRUE; + +#50 +src/eval_cps.c:2592: error: Null Dereference + pointer `array` last assigned on line 2589 could be null and is dereferenced at line 2592, column 24. + 2590. + 2591. lbm_flat_value_t fv; + 2592. fv.buf = (uint8_t*)array->data; + ^ + 2593. fv.buf_size = array->size; + 2594. fv.buf_pos = 0; + +#51 +src/eval_cps.c:2853: error: Dead Store + The value written to `&ls` (type `unsigned int`) is never used. + 2851. if (nargs == 2 && lbm_is_list(args[0]) && lbm_is_number(args[1])) { + 2852. int len = -1; + 2853. lbm_value ls = ENC_SYM_NIL; + ^ + 2854. WITH_GC(ls, lbm_list_copy(&len, args[0])); + 2855. int dist = lbm_dec_as_i32(args[1]); + +#52 +src/eval_cps.c:2979: error: Null Dereference + pointer `sptr` last assigned on line 2977 could be null and is dereferenced at line 2979, column 34. + 2977. lbm_uint* sptr = get_stack_ptr(ctx, 5); + 2978. + 2979. lbm_value arg_env = (lbm_value)sptr[0]; + ^ + 2980. lbm_value exp = (lbm_value)sptr[1]; + 2981. lbm_value clo_env = (lbm_value)sptr[2]; + +#53 +src/eval_cps.c:3024: error: Null Dereference + pointer `sptr` last assigned on line 3023 could be null and is dereferenced at line 3024, column 34. + 3022. static void cont_closure_args_rest(eval_context_t *ctx) { + 3023. lbm_uint* sptr = get_stack_ptr(ctx, 5); + 3024. lbm_value arg_env = (lbm_value)sptr[0]; + ^ + 3025. lbm_value exp = (lbm_value)sptr[1]; + 3026. lbm_value clo_env = (lbm_value)sptr[2]; + +#54 +src/eval_cps.c:3073: error: Null Dereference + pointer `rptr` last assigned on line 3072 could be null and is dereferenced at line 3073, column 5. + 3071. sptr[2] = cell->cdr; + 3072. lbm_value *rptr = stack_reserve(ctx,2); + 3073. rptr[0] = count + (1 << LBM_VAL_SHIFT); + ^ + 3074. rptr[1] = APPLICATION_ARGS; + 3075. ctx->curr_exp = cell->car; + +#55 +src/eval_cps.c:3062: error: Null Dereference + pointer `sptr` last assigned on line 3060 could be null and is dereferenced at line 3062, column 19. + 3060. lbm_uint *sptr = get_stack_ptr(ctx, 3); + 3061. + 3062. lbm_value env = sptr[0]; + ^ + 3063. lbm_value rest = sptr[1]; + 3064. lbm_value count = sptr[2]; + +#56 +src/eval_cps.c:3097: error: Null Dereference + pointer `sptr` last assigned on line 3096 could be null and is dereferenced at line 3097, column 5. + 3095. } else { + 3096. lbm_value *sptr = stack_reserve(ctx, 3); + 3097. sptr[0] = env; + ^ + 3098. sptr[1] = get_cdr(rest); + 3099. sptr[2] = AND; + +#57 +src/eval_cps.c:3117: error: Null Dereference + pointer `sptr` last assigned on line 3116 could be null and is dereferenced at line 3117, column 5. + 3115. } else { + 3116. lbm_value *sptr = stack_reserve(ctx, 3); + 3117. sptr[0] = env; + ^ + 3118. sptr[1] = get_cdr(rest); + 3119. sptr[2] = OR; + +#58 +src/eval_cps.c:3145: error: Null Dereference + pointer `sptr` last assigned on line 3143 could be null and is dereferenced at line 3145, column 20. + 3143. lbm_value *sptr = get_stack_ptr(ctx, 4); + 3144. + 3145. lbm_value rest = sptr[1]; + ^ + 3146. lbm_value env = sptr[2]; + 3147. lbm_value key = sptr[3]; + +#59 +src/eval_cps.c:3178: error: Null Dereference + pointer `sptr` last assigned on line 3176 could be null and is dereferenced at line 3178, column 19. + 3176. lbm_value *sptr = pop_stack_ptr(ctx, 2); + 3177. + 3178. ctx->curr_env = sptr[1]; + ^ + 3179. if (lbm_is_symbol_nil(arg)) { + 3180. ctx->curr_exp = get_cadr(sptr[0]); // else branch + +#60 +src/eval_cps.c:3191: error: Null Dereference + pointer `sptr` last assigned on line 3190 could be null and is dereferenced at line 3191, column 35. + 3189. + 3190. lbm_uint *sptr = get_stack_ptr(ctx, 2); + 3191. lbm_value patterns = (lbm_value)sptr[0]; + ^ + 3192. lbm_value orig_env = (lbm_value)sptr[1]; // restore enclosing environment. + 3193. lbm_value new_env = orig_env; + +#61 +src/eval_cps.c:3262: error: Null Dereference + pointer `sptr` last assigned on line 3260 could be null and is dereferenced at line 3262, column 19. + 3260. lbm_value *sptr = get_stack_ptr(ctx, 6); + 3261. + 3262. lbm_value ls = sptr[0]; + ^ + 3263. lbm_value env = sptr[1]; + 3264. lbm_value t = sptr[3]; + +#62 +src/eval_cps.c:3311: error: Null Dereference + pointer `sptr` last assigned on line 3309 could be null and is dereferenced at line 3311, column 19. + 3309. lbm_value *sptr = get_stack_ptr(ctx, 2); + 3310. stack_reserve(ctx,1)[0] = LOOP_CONDITION; + 3311. ctx->curr_exp = sptr[1]; + ^ + 3312. } + 3313. + +#63 +src/eval_cps.c:3322: error: Null Dereference + pointer `sptr` last assigned on line 3320 could be null and is dereferenced at line 3322, column 19. + 3320. lbm_value *sptr = get_stack_ptr(ctx, 2); + 3321. stack_reserve(ctx,1)[0] = LOOP; + 3322. ctx->curr_exp = sptr[0]; + ^ + 3323. } + 3324. + +#64 +src/eval_cps.c:3340: error: Null Dereference + pointer `sptr` last assigned on line 3326 could be null and is dereferenced at line 3340, column 17. + 3338. // else + 3339. // Set up for a new comparator evaluation and recurse. + 3340. lbm_value a = sptr[2]; + ^ + 3341. lbm_value b = lbm_cdr(a); + 3342. lbm_set_cdr(a, ENC_SYM_NIL); // terminate 1 element list + +#65 +src/eval_cps.c:3422: error: Null Dereference + pointer `sptr` last assigned on line 3421 could be null and is dereferenced at line 3422, column 29. + 3420. static void cont_merge_layer(eval_context_t *ctx) { + 3421. lbm_uint *sptr = get_stack_ptr(ctx, 9); + 3422. lbm_int layer = lbm_dec_i(sptr[7]); + ^ + 3423. lbm_int len = lbm_dec_i(sptr[8]); + 3424. + +#66 +src/eval_cps.c:3610: error: Null Dereference + pointer `chan` last assigned on line 3605 could be null and is dereferenced by call to `lbm_channel_more()` at line 3610, column 8. + 3608. } + 3609. + 3610. if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) { + ^ + 3611. lbm_stack_drop(&ctx->K, 2); + 3612. read_finish(chan, ctx); + +#67 +src/eval_cps.c:3602: error: Null Dereference + pointer `sptr` last assigned on line 3601 could be null and is dereferenced at line 3602, column 22. + 3600. static void cont_read_next_token(eval_context_t *ctx) { + 3601. lbm_value *sptr = get_stack_ptr(ctx, 2); + 3602. lbm_value stream = sptr[0]; + ^ + 3603. lbm_value grab_row0 = sptr[1]; + 3604. + +#68 +src/eval_cps.c:3920: error: Null Dereference + pointer `sptr` last assigned on line 3919 could be null and is dereferenced at line 3920, column 22. + 3918. static void cont_read_start_array(eval_context_t *ctx) { + 3919. lbm_value *sptr = get_stack_ptr(ctx, 1); + 3920. lbm_value stream = sptr[0]; + ^ + 3921. + 3922. lbm_char_channel_t *str = lbm_dec_channel(stream); + +#69 +src/eval_cps.c:3934: error: Null Dereference + pointer `str` last assigned on line 3922 could be null and is dereferenced by call to `lbm_channel_reader_close()` at line 3934, column 7. + 3932. initial_size = (lbm_uint)((float)num_free * 0.9); + 3933. if (initial_size == 0) { + 3934. lbm_channel_reader_close(str); + ^ + 3935. error_ctx(ENC_SYM_MERROR); + 3936. } + +#70 +src/eval_cps.c:3959: error: Null Dereference + pointer `str` last assigned on line 3922 could be null and is dereferenced by call to `lbm_channel_reader_close()` at line 3959, column 5. + 3957. ctx->app_cont = true; + 3958. } else { + 3959. lbm_channel_reader_close(str); + ^ + 3960. read_error_ctx(lbm_channel_row(str), lbm_channel_column(str)); + 3961. } + +#71 +src/eval_cps.c:3967: error: Null Dereference + pointer `sptr` last assigned on line 3965 could be null and is dereferenced at line 3967, column 22. + 3965. lbm_uint *sptr = get_stack_ptr(ctx, 4); + 3966. + 3967. lbm_value array = sptr[0]; + ^ + 3968. lbm_value size = lbm_dec_as_u32(sptr[1]); + 3969. lbm_value ix = lbm_dec_as_u32(sptr[2]); + +#72 +src/eval_cps.c:4036: error: Null Dereference + pointer `rptr` last assigned on line 4035 could be null and is dereferenced at line 4036, column 7. + 4034. case ENC_SYM_DOT: { + 4035. lbm_value *rptr = stack_reserve(ctx, 4); + 4036. rptr[0] = READ_DOT_TERMINATE; + ^ + 4037. rptr[1] = stream; + 4038. rptr[2] = lbm_enc_u(0); + +#73 +src/eval_cps.c:4060: error: Null Dereference + pointer `rptr` last assigned on line 4059 could be null and is dereferenced at line 4060, column 3. + 4058. sptr[2] = stream; // unchanged. + 4059. lbm_value *rptr = stack_reserve(ctx, 4); + 4060. rptr[0] = READ_APPEND_CONTINUE; + ^ + 4061. rptr[1] = stream; + 4062. rptr[2] = lbm_enc_u(0); + +#74 +src/eval_cps.c:4011: error: Null Dereference + pointer `sptr` last assigned on line 4009 could be null and is dereferenced at line 4011, column 26. + 4009. lbm_value *sptr = get_stack_ptr(ctx, 3); + 4010. + 4011. lbm_value first_cell = sptr[0]; + ^ + 4012. lbm_value last_cell = sptr[1]; + 4013. lbm_value stream = sptr[2]; + +#75 +src/eval_cps.c:4046: error: Null Dereference + pointer `str` last assigned on line 4015 could be null and is dereferenced by call to `lbm_channel_reader_close()` at line 4046, column 5. + 4044. lbm_value new_cell = cons_with_gc(ctx->r, ENC_SYM_NIL, ENC_SYM_NIL); + 4045. if (lbm_is_symbol_merror(new_cell)) { + 4046. lbm_channel_reader_close(str); + ^ + 4047. read_error_ctx(lbm_channel_row(str), lbm_channel_column(str)); + 4048. return; + +#76 +src/eval_cps.c:4089: error: Null Dereference + pointer `rptr` last assigned on line 4088 could be null and is dereferenced at line 4089, column 7. + 4087. // A dot, may in reality be an error in this location. + 4088. lbm_value *rptr = stack_reserve(ctx, 4); + 4089. rptr[0] = READ_DOT_TERMINATE; + ^ + 4090. rptr[1] = stream; + 4091. rptr[2] = lbm_enc_u(0); + +#77 +src/eval_cps.c:4099: error: Null Dereference + pointer `rptr` last assigned on line 4098 could be null and is dereferenced at line 4099, column 3. + 4097. + 4098. lbm_value *rptr = stack_reserve(ctx, 6); + 4099. rptr[0] = stream; + ^ + 4100. rptr[1] = env; + 4101. rptr[2] = READ_EVAL_CONTINUE; + +#78 +src/eval_cps.c:4077: error: Null Dereference + pointer `str` last assigned on line 4072 could be null and is dereferenced at line 4077, column 24. + 4075. } + 4076. + 4077. ctx->row1 = (lbm_int)str->row(str); + ^ + 4078. + 4079. if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL) { + +#79 +src/eval_cps.c:4127: error: Null Dereference + pointer `str` last assigned on line 4117 could be null and is dereferenced by call to `lbm_channel_reader_close()` at line 4127, column 5. + 4125. ctx->app_cont = true; + 4126. } else { + 4127. lbm_channel_reader_close(str); + ^ + 4128. lbm_set_error_reason((char*)lbm_error_str_parse_close); + 4129. read_error_ctx(lbm_channel_row(str), lbm_channel_column(str)); + +#80 +src/eval_cps.c:4158: error: Null Dereference + pointer `rptr` last assigned on line 4157 could be null and is dereferenced at line 4158, column 7. + 4156. ctx->r = first_cell; + 4157. lbm_value *rptr = stack_reserve(ctx, 6); + 4158. rptr[0] = stream; + ^ + 4159. rptr[1] = ctx->r; + 4160. rptr[2] = READ_EXPECT_CLOSEPAR; + +#81 +src/eval_cps.c:4136: error: Null Dereference + pointer `sptr` last assigned on line 4134 could be null and is dereferenced at line 4136, column 26. + 4134. lbm_value *sptr = get_stack_ptr(ctx, 3); + 4135. + 4136. lbm_value first_cell = sptr[0]; + ^ + 4137. lbm_value last_cell = sptr[1]; + 4138. lbm_value stream = sptr[2]; + +#82 +src/eval_cps.c:4150: error: Null Dereference + pointer `str` last assigned on line 4140 could be null and is dereferenced by call to `lbm_channel_reader_close()` at line 4150, column 5. + 4148. (ctx->r == ENC_SYM_CLOSEPAR || + 4149. ctx->r == ENC_SYM_DOT)) { + 4150. lbm_channel_reader_close(str); + ^ + 4151. lbm_set_error_reason((char*)lbm_error_str_parse_dot); + 4152. read_error_ctx(lbm_channel_row(str), lbm_channel_column(str)); + +#83 +src/eval_cps.c:4166: error: Null Dereference + pointer `str` last assigned on line 4140 could be null and is dereferenced by call to `lbm_channel_reader_close()` at line 4166, column 7. + 4164. ctx->app_cont = true; + 4165. } else { + 4166. lbm_channel_reader_close(str); + ^ + 4167. lbm_set_error_reason((char*)lbm_error_str_parse_dot); + 4168. read_error_ctx(lbm_channel_row(str), lbm_channel_column(str)); + +#84 +src/eval_cps.c:4187: error: Null Dereference + pointer `str` last assigned on line 4182 could be null and is dereferenced by call to `lbm_channel_reader_close()` at line 4187, column 3. + 4185. } + 4186. + 4187. lbm_channel_reader_close(str); + ^ + 4188. if (lbm_is_symbol(ctx->r)) { + 4189. lbm_uint sym_val = lbm_dec_sym(ctx->r); + +#85 +src/eval_cps.c:4236: error: Null Dereference + pointer `sptr` last assigned on line 4235 could be null and is dereferenced at line 4236, column 33. + 4234. } else if (lbm_is_cons(ctx->r)) { + 4235. lbm_uint *sptr = get_stack_ptr(ctx, 2); + 4236. lbm_value args = (lbm_value)sptr[1]; + ^ + 4237. switch (get_car(ctx->r)) { + 4238. case ENC_SYM_CLOSURE: { + +#86 +src/eval_cps.c:4420: error: Null Dereference + pointer `rptr1` last assigned on line 4419 could be null and is dereferenced at line 4420, column 7. + 4418. (!(val & LBM_PTR_TO_CONSTANT_BIT))) { + 4419. lbm_value * rptr1 = stack_reserve(ctx, 3); + 4420. rptr1[0] = first_arg; + ^ + 4421. rptr1[1] = SET_GLOBAL_ENV; + 4422. rptr1[2] = MOVE_VAL_TO_FLASH_DISPATCH; + +#87 +src/eval_cps.c:4415: error: Null Dereference + pointer `rptr` last assigned on line 4414 could be null and is dereferenced at line 4415, column 5. + 4413. // Prepare to copy the rest of the arguments when done with first. + 4414. lbm_value *rptr = stack_reserve(ctx, 2); + 4415. rptr[0] = rest; + ^ + 4416. rptr[1] = MOVE_TO_FLASH; + 4417. if (lbm_is_ptr(val) && + +#88 +src/eval_cps.c:4437: error: Null Dereference + pointer `rptr` last assigned on line 4436 could be null and is dereferenced at line 4437, column 5. + 4435. if (lbm_is_cons(val)) { + 4436. lbm_value *rptr = stack_reserve(ctx, 5); + 4437. rptr[0] = ENC_SYM_NIL; // fst cell of list + ^ + 4438. rptr[1] = ENC_SYM_NIL; // last cell of list + 4439. rptr[2] = get_cdr(val); + +#89 +src/eval_cps.c:4542: error: Null Dereference + pointer `sptr` last assigned on line 4540 could be null and is dereferenced at line 4542, column 19. + 4540. lbm_value *sptr = get_stack_ptr(ctx, 3); + 4541. + 4542. lbm_value fst = sptr[0]; + ^ + 4543. lbm_value lst = sptr[1]; + 4544. lbm_value val = sptr[2]; + +#90 +src/eval_cps.c:4594: error: Null Dereference + pointer `sptr` last assigned on line 4590 could be null and is dereferenced at line 4594, column 62. + 4592. // sptr[1] = current index + 4593. // sptr[0] = target array in flash + 4594. lbm_array_header_t *src_arr = (lbm_array_header_t*)get_car(sptr[2]); + ^ + 4595. lbm_uint size = src_arr->size / sizeof(lbm_uint); + 4596. lbm_value *srcdata = (lbm_value *)src_arr->data; + +#91 +src/eval_cps.c:4595: error: Null Dereference + pointer `src_arr` last assigned on line 4594 could be null and is dereferenced at line 4595, column 19. + 4593. // sptr[0] = target array in flash + 4594. lbm_array_header_t *src_arr = (lbm_array_header_t*)get_car(sptr[2]); + 4595. lbm_uint size = src_arr->size / sizeof(lbm_uint); + ^ + 4596. lbm_value *srcdata = (lbm_value *)src_arr->data; + 4597. + +#92 +src/eval_cps.c:4599: error: Null Dereference + pointer `tgt_arr` last assigned on line 4598 could be null and is dereferenced at line 4599, column 36. + 4597. + 4598. lbm_array_header_t *tgt_arr = (lbm_array_header_t*)get_car(sptr[0]); + 4599. lbm_uint *tgtdata = (lbm_value *)tgt_arr->data; + ^ + 4600. lbm_uint ix = lbm_dec_as_u32(sptr[1]); + 4601. handle_flash_status(lbm_const_write(&tgtdata[ix], ctx->r)); + +#93 +src/eval_cps.c:4619: error: Null Dereference + pointer `rptr` last assigned on line 4618 could be null and is dereferenced at line 4619, column 3. + 4617. static void cont_qq_expand_start(eval_context_t *ctx) { + 4618. lbm_value *rptr = stack_reserve(ctx, 2); + 4619. rptr[0] = ctx->r; + ^ + 4620. rptr[1] = QQ_EXPAND; + 4621. ctx->r = ENC_SYM_NIL; + +#94 +src/eval_cps.c:4707: error: Null Dereference + pointer `rptr` last assigned on line 4706 could be null and is dereferenced at line 4707, column 7. + 4705. } else { + 4706. lbm_value *rptr = stack_reserve(ctx, 6); + 4707. rptr[0] = ctx->r; + ^ + 4708. rptr[1] = QQ_APPEND; + 4709. rptr[2] = cdr_val; + +#95 +src/eval_cps.c:4771: error: Null Dereference + pointer `rptr` last assigned on line 4770 could be null and is dereferenced at line 4771, column 7. + 4769. } else { + 4770. lbm_value *rptr = stack_reserve(ctx, 7); + 4771. rptr[0] = QQ_LIST; + ^ + 4772. rptr[1] = ctx->r; + 4773. rptr[2] = QQ_APPEND; + +#96 +src/eval_cps.c:4815: error: Null Dereference + pointer `sptr` last assigned on line 4814 could be null and is dereferenced at line 4815, column 22. + 4813. static void cont_exception_handler(eval_context_t *ctx) { + 4814. lbm_value *sptr = pop_stack_ptr(ctx, 2); + 4815. lbm_value retval = sptr[0]; + ^ + 4816. lbm_value flags = sptr[1]; + 4817. lbm_set_car(get_cdr(retval), ctx->r); + +#97 +src/eval_cps.c:4952: error: Null Dereference + pointer `reserved` last assigned on line 4951 could be null and is dereferenced at line 4952, column 5. + 4950. */ + 4951. lbm_value *reserved = stack_reserve(ctx, 3); + 4952. reserved[0] = ctx->curr_env; + ^ + 4953. reserved[1] = cell->cdr; + 4954. reserved[2] = APPLICATION_START; + +Found 98 issues + Issue Type(ISSUED_TYPE_ID): # + Null Dereference(NULL_DEREFERENCE): 96 + Dead Store(DEAD_STORE): 2 diff --git a/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/index.html b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/index.html new file mode 100644 index 00000000..5d67a9e7 --- /dev/null +++ b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/index.html @@ -0,0 +1,150 @@ + + +lispbm - scan-build results + + + + + + +

lispbm - scan-build results

+ + + + + + + +
User:joels@joels-ThinkStation-P340
Working Directory:/home/joels/Current/lispbm
Command Line:make -j4
Clang Version:clang version 10.0.0-4ubuntu1 +
Date:Tue Jul 23 15:23:44 2024
+

Bug Summary

+ + + + + + +
Bug TypeQuantityDisplay?
All Bugs19
Logic error
Assigned value is garbage or undefined6
Dereference of null pointer10
Uninitialized argument value3
+

Reports

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Bug GroupBug Type ▾FileFunction/MethodLinePath Length
Logic errorAssigned value is garbage or undefinedeval_cps.ccont_application_start425238View Report
Logic errorAssigned value is garbage or undefinedeval_cps.ceval_match20428View Report
Logic errorAssigned value is garbage or undefinedeval_cps.ccont_closure_application_args300024View Report
Logic errorAssigned value is garbage or undefinedeval_cps.ccont_closure_application_args299824View Report
Logic errorAssigned value is garbage or undefinedeval_cps.ccont_application_start425438View Report
Logic errorAssigned value is garbage or undefinedeval_cps.ccont_progn_rest21638View Report
Logic errorDereference of null pointereval_cps.ccont_read_append_array399832View Report
Logic errorDereference of null pointereval_cps.ccont_read_eval_continue40773View Report
Logic errorDereference of null pointereval_cps.ccont_read_append_array398324View Report
Logic errorDereference of null pointereval_cps.ceval_callcc166416View Report
Logic errorDereference of null pointereval_cps.ccont_move_array_elts_to_flash459512View Report
Logic errorDereference of null pointereval_cps.ccont_move_array_elts_to_flash459912View Report
Logic errorDereference of null pointerheap.clbm_dec_str23414View Report
Logic errorDereference of null pointerheap.clbm_heap_array_get_data_ro125914View Report
Logic errorDereference of null pointereval_cps.ccont_application_start430137View Report
Logic errorDereference of null pointereval_cps.ccont_read_next_token375731View Report
Logic errorUninitialized argument valueeval_cps.ccont_move_to_flash441213View Report
Logic errorUninitialized argument valueeval_cps.ccont_closure_application_args29898View Report
Logic errorUninitialized argument valueeval_cps.ceval_symbol159836View Report
+ + diff --git a/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-0007d3.html b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-0007d3.html new file mode 100644 index 00000000..97619b07 --- /dev/null +++ b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-0007d3.html @@ -0,0 +1,6558 @@ + + + +src/eval_cps.c + + + + + + + + + + + + + + + + + + + + + + + + + + +

Bug Summary

+ + + + +
File:eval_cps.c
Warning:line 4301, column 19
Access to field 'size' results in a dereference of a null pointer (loaded from variable 'arr')
+ +

Annotated Source Code

+

Press '?' + to see keyboard shortcuts

+ + +
clang -cc1 -triple i386-pc-linux-gnu -analyze -disable-free -disable-llvm-verifier -discard-value-names -main-file-name eval_cps.c -analyzer-store=region -analyzer-opt-analyze-nested-blocks -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -mrelocation-model static -mthread-model posix -mframe-pointer=none -fmath-errno -fno-rounding-math -masm-verbose -mconstructor-aliases -target-cpu i686 -dwarf-column-info -fno-split-dwarf-inlining -debugger-tuning=gdb -resource-dir /usr/lib/llvm-10/lib/clang/10.0.0 -I ./include -I ./include/extensions -I platform/linux/include -D _PRELUDE -internal-isystem /usr/local/include -internal-isystem /usr/lib/llvm-10/lib/clang/10.0.0/include -internal-externc-isystem /usr/include/i386-linux-gnu -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -std=c99 -fdebug-compilation-dir /home/joels/Current/lispbm -ferror-limit 19 -fmessage-length 0 -fgnuc-version=4.2.1 -fobjc-runtime=gcc -fdiagnostics-show-option -vectorize-loops -vectorize-slp -analyzer-output=html -faddrsig -o /home/joels/Current/lispbm/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1 -x c src/eval_cps.c +
+ + + +
+ + +
+ + + + +
+

src/eval_cps.c

+
→
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1/*
2 Copyright 2018, 2020 - 2024 Joel Svensson svenssonjoel@yahoo.se
3
4 This program is free software: you can redistribute it and/or modify
5 it under the terms of the GNU General Public License as published by
6 the Free Software Foundation, either version 3 of the License, or
7 (at your option) any later version.
8
9 This program is distributed in the hope that it will be useful,
10 but WITHOUT ANY WARRANTY; without even the implied warranty of
11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 GNU General Public License for more details.
13
14 You should have received a copy of the GNU General Public License
15 along with this program. If not, see <http://www.gnu.org/licenses/>.
16*/
17
18#include <lbm_memory.h>
19#include <lbm_types.h>
20#include "symrepr.h"
21#include "heap.h"
22#include "env.h"
23#include "eval_cps.h"
24#include "stack.h"
25#include "fundamental.h"
26#include "extensions.h"
27#include "tokpar.h"
28#include "lbm_channel.h"
29#include "print.h"
30#include "platform_mutex.h"
31#include "lbm_flat_value.h"
32#include "lbm_flags.h"
33
34#ifdef VISUALIZE_HEAP
35#include "heap_vis.h"
36#endif
37
38#include <setjmp.h>
39#include <stdarg.h>
40
41static jmp_buf error_jmp_buf;
42static jmp_buf critical_error_jmp_buf;
43
44#define S_TO_US(X)(lbm_uint)((X) * 1000000) (lbm_uint)((X) * 1000000)
45
46#define DEC_CONTINUATION(x)(((x) & ~0xF8000001u) >> 2) (((x) & ~LBM_CONTINUATION_INTERNAL0xF8000001u) >> LBM_ADDRESS_SHIFT2)
47#define IS_CONTINUATION(x)(((x) & 0xF8000001u) == 0xF8000001u) (((x) & LBM_CONTINUATION_INTERNAL0xF8000001u) == LBM_CONTINUATION_INTERNAL0xF8000001u)
48#define CONTINUATION(x)(((x) << 2) | 0xF8000001u) (((x) << LBM_ADDRESS_SHIFT2) | LBM_CONTINUATION_INTERNAL0xF8000001u)
49
50#define DONE(((0) << 2) | 0xF8000001u) CONTINUATION(0)(((0) << 2) | 0xF8000001u)
51#define SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u) CONTINUATION(1)(((1) << 2) | 0xF8000001u)
52#define BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u) CONTINUATION(2)(((2) << 2) | 0xF8000001u)
53#define IF(((3) << 2) | 0xF8000001u) CONTINUATION(3)(((3) << 2) | 0xF8000001u)
54#define PROGN_REST(((4) << 2) | 0xF8000001u) CONTINUATION(4)(((4) << 2) | 0xF8000001u)
55#define APPLICATION_ARGS(((5) << 2) | 0xF8000001u) CONTINUATION(5)(((5) << 2) | 0xF8000001u)
56#define AND(((6) << 2) | 0xF8000001u) CONTINUATION(6)(((6) << 2) | 0xF8000001u)
57#define OR(((7) << 2) | 0xF8000001u) CONTINUATION(7)(((7) << 2) | 0xF8000001u)
58#define WAIT(((8) << 2) | 0xF8000001u) CONTINUATION(8)(((8) << 2) | 0xF8000001u)
59#define MATCH(((9) << 2) | 0xF8000001u) CONTINUATION(9)(((9) << 2) | 0xF8000001u)
60#define APPLICATION_START(((10) << 2) | 0xF8000001u) CONTINUATION(10)(((10) << 2) | 0xF8000001u)
61#define EVAL_R(((11) << 2) | 0xF8000001u) CONTINUATION(11)(((11) << 2) | 0xF8000001u)
62#define RESUME(((12) << 2) | 0xF8000001u) CONTINUATION(12)(((12) << 2) | 0xF8000001u)
63#define CLOSURE_ARGS(((13) << 2) | 0xF8000001u) CONTINUATION(13)(((13) << 2) | 0xF8000001u)
64#define EXIT_ATOMIC(((14) << 2) | 0xF8000001u) CONTINUATION(14)(((14) << 2) | 0xF8000001u)
65#define READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u) CONTINUATION(15)(((15) << 2) | 0xF8000001u)
66#define READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u) CONTINUATION(16)(((16) << 2) | 0xF8000001u)
67#define READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u) CONTINUATION(17)(((17) << 2) | 0xF8000001u)
68#define READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u) CONTINUATION(18)(((18) << 2) | 0xF8000001u)
69#define READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u) CONTINUATION(19)(((19) << 2) | 0xF8000001u)
70#define READ_DONE(((20) << 2) | 0xF8000001u) CONTINUATION(20)(((20) << 2) | 0xF8000001u)
71#define READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u) CONTINUATION(21)(((21) << 2) | 0xF8000001u)
72#define READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u) CONTINUATION(22)(((22) << 2) | 0xF8000001u)
73#define READ_COMMA_RESULT(((23) << 2) | 0xF8000001u) CONTINUATION(23)(((23) << 2) | 0xF8000001u)
74#define READ_START_ARRAY(((24) << 2) | 0xF8000001u) CONTINUATION(24)(((24) << 2) | 0xF8000001u)
75#define READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u) CONTINUATION(25)(((25) << 2) | 0xF8000001u)
76#define MAP(((26) << 2) | 0xF8000001u) CONTINUATION(26)(((26) << 2) | 0xF8000001u)
77#define MATCH_GUARD(((27) << 2) | 0xF8000001u) CONTINUATION(27)(((27) << 2) | 0xF8000001u)
78#define TERMINATE(((28) << 2) | 0xF8000001u) CONTINUATION(28)(((28) << 2) | 0xF8000001u)
79#define PROGN_VAR(((29) << 2) | 0xF8000001u) CONTINUATION(29)(((29) << 2) | 0xF8000001u)
80#define SETQ(((30) << 2) | 0xF8000001u) CONTINUATION(30)(((30) << 2) | 0xF8000001u)
81#define MOVE_TO_FLASH(((31) << 2) | 0xF8000001u) CONTINUATION(31)(((31) << 2) | 0xF8000001u)
82#define MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u) CONTINUATION(32)(((32) << 2) | 0xF8000001u)
83#define MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u) CONTINUATION(33)(((33) << 2) | 0xF8000001u)
84#define CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u) CONTINUATION(34)(((34) << 2) | 0xF8000001u)
85#define QQ_EXPAND_START(((35) << 2) | 0xF8000001u) CONTINUATION(35)(((35) << 2) | 0xF8000001u)
86#define QQ_EXPAND(((36) << 2) | 0xF8000001u) CONTINUATION(36)(((36) << 2) | 0xF8000001u)
87#define QQ_APPEND(((37) << 2) | 0xF8000001u) CONTINUATION(37)(((37) << 2) | 0xF8000001u)
88#define QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u) CONTINUATION(38)(((38) << 2) | 0xF8000001u)
89#define QQ_LIST(((39) << 2) | 0xF8000001u) CONTINUATION(39)(((39) << 2) | 0xF8000001u)
90#define KILL(((40) << 2) | 0xF8000001u) CONTINUATION(40)(((40) << 2) | 0xF8000001u)
91#define LOOP(((41) << 2) | 0xF8000001u) CONTINUATION(41)(((41) << 2) | 0xF8000001u)
92#define LOOP_CONDITION(((42) << 2) | 0xF8000001u) CONTINUATION(42)(((42) << 2) | 0xF8000001u)
93#define MERGE_REST(((43) << 2) | 0xF8000001u) CONTINUATION(43)(((43) << 2) | 0xF8000001u)
94#define MERGE_LAYER(((44) << 2) | 0xF8000001u) CONTINUATION(44)(((44) << 2) | 0xF8000001u)
95#define CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u) CONTINUATION(45)(((45) << 2) | 0xF8000001u)
96#define MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u) CONTINUATION(46)(((46) << 2) | 0xF8000001u)
97#define POP_READER_FLAGS(((47) << 2) | 0xF8000001u) CONTINUATION(47)(((47) << 2) | 0xF8000001u)
98#define EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u) CONTINUATION(48)(((48) << 2) | 0xF8000001u)
99#define NUM_CONTINUATIONS49 49
100
101#define FM_NEED_GC-1 -1
102#define FM_NO_MATCH-2 -2
103#define FM_PATTERN_ERROR-3 -3
104
105typedef enum {
106 BL_OK = 0,
107 BL_NO_MEMORY,
108 BL_INCORRECT_KEY
109} binding_location_status;
110
111#define FB_OK0 0
112#define FB_TYPE_ERROR-1 -1
113
114const char* lbm_error_str_parse_eof = "End of parse stream.";
115const char* lbm_error_str_parse_dot = "Incorrect usage of '.'.";
116const char* lbm_error_str_parse_close = "Expected closing parenthesis.";
117const char* lbm_error_str_num_args = "Incorrect number of arguments.";
118const char* lbm_error_str_forbidden_in_atomic = "Operation is forbidden in an atomic block.";
119const char* lbm_error_str_no_number = "Argument(s) must be a number.";
120const char* lbm_error_str_not_a_boolean = "Argument must be t or nil (true or false).";
121const char* lbm_error_str_incorrect_arg = "Incorrect argument.";
122const char* lbm_error_str_var_outside_progn = "Usage of var outside of progn.";
123const char* lbm_error_str_flash_not_possible = "Value cannot be written to flash.";
124const char* lbm_error_str_flash_error = "Error writing to flash.";
125const char* lbm_error_str_flash_full = "Flash memory is full.";
126const char* lbm_error_str_variable_not_bound = "Variable not bound.";
127
128static lbm_value lbm_error_suspect;
129static bool_Bool lbm_error_has_suspect = false0;
130#ifdef LBM_ALWAYS_GC
131
132#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
133 gc(); \
134 (y) = (x); \
135 if (lbm_is_symbol_merror((y))) { \
136 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
137 }
138
139#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
140 lbm_gc_mark_phase(r); \
141 gc(); \
142 (y) = (x); \
143 if (lbm_is_symbol_merror((y))) { \
144 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
145 }
146
147#else
148
149#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
150 (y) = (x); \
151 if (lbm_is_symbol_merror((y))) { \
152 gc(); \
153 (y) = (x); \
154 if (lbm_is_symbol_merror((y))) { \
155 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
156 } \
157 /* continue executing statements below */ \
158 }
159#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
160 (y) = (x); \
161 if (lbm_is_symbol_merror((y))) { \
162 lbm_gc_mark_phase(r); \
163 gc(); \
164 (y) = (x); \
165 if (lbm_is_symbol_merror((y))) { \
166 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
167 } \
168 /* continue executing statements below */ \
169 }
170
171#endif
172
173typedef struct {
174 eval_context_t *first;
175 eval_context_t *last;
176} eval_context_queue_t;
177
178#ifdef CLEAN_UP_CLOSURES
179static lbm_value clean_cl_env_symbol = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
180#endif
181
182static int gc(void);
183static void error_ctx(lbm_value);
184static void error_at_ctx(lbm_value err_val, lbm_value at);
185static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx);
186static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail);
187
188// The currently executing context.
189eval_context_t *ctx_running = NULL((void*)0);
190volatile bool_Bool lbm_system_sleeping = false0;
191
192static volatile bool_Bool gc_requested = false0;
193void lbm_request_gc(void) {
194 gc_requested = true1;
195}
196
197/*
198 On ChibiOs the CH_CFG_ST_FREQUENCY setting in chconf.h sets the
199 resolution of the timer used for sleep operations. If this is set
200 to 10KHz the resolution is 100us.
201
202 The CH_CFG_ST_TIMEDELTA specifies the minimum number of ticks that
203 can be safely specified in a timeout directive (wonder if that
204 means sleep-period). The timedelta is set to 2.
205
206 If I have understood these correctly it means that the minimum
207 sleep duration possible is 2 * 100us = 200us.
208*/
209
210#define EVAL_CPS_DEFAULT_STACK_SIZE256 256
211#define EVAL_CPS_MIN_SLEEP200 200
212#define EVAL_STEPS_QUOTA10 10
213
214static volatile uint32_t eval_steps_refill = EVAL_STEPS_QUOTA10;
215static uint32_t eval_steps_quota = EVAL_STEPS_QUOTA10;
216
217void lbm_set_eval_step_quota(uint32_t quota) {
218 eval_steps_refill = quota;
219}
220
221static uint32_t eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
222static volatile uint32_t eval_cps_next_state = EVAL_CPS_STATE_NONE0;
223static volatile uint32_t eval_cps_next_state_arg = 0;
224static volatile bool_Bool eval_cps_state_changed = false0;
225
226static void usleep_nonsense(uint32_t us) {
227 (void) us;
228}
229
230static bool_Bool dynamic_load_nonsense(const char *sym, const char **code) {
231 (void) sym;
232 (void) code;
233 return false0;
234}
235
236static uint32_t timestamp_nonsense(void) {
237 return 0;
238}
239
240static int printf_nonsense(const char *fmt, ...) {
241 (void) fmt;
242 return 0;
243}
244
245static void ctx_done_nonsense(eval_context_t *ctx) {
246 (void) ctx;
247}
248
249static void critical_nonsense(void) {
250 return;
251}
252
253static void (*critical_error_callback)(void) = critical_nonsense;
254static void (*usleep_callback)(uint32_t) = usleep_nonsense;
255static uint32_t (*timestamp_us_callback)(void) = timestamp_nonsense;
256static void (*ctx_done_callback)(eval_context_t *) = ctx_done_nonsense;
257static int (*printf_callback)(const char *, ...) = printf_nonsense;
258static bool_Bool (*dynamic_load_callback)(const char *, const char **) = dynamic_load_nonsense;
259
260void lbm_set_critical_error_callback(void (*fptr)(void)) {
261 if (fptr == NULL((void*)0)) critical_error_callback = critical_nonsense;
262 else critical_error_callback = fptr;
263}
264
265void lbm_set_usleep_callback(void (*fptr)(uint32_t)) {
266 if (fptr == NULL((void*)0)) usleep_callback = usleep_nonsense;
267 else usleep_callback = fptr;
268}
269
270void lbm_set_timestamp_us_callback(uint32_t (*fptr)(void)) {
271 if (fptr == NULL((void*)0)) timestamp_us_callback = timestamp_nonsense;
272 else timestamp_us_callback = fptr;
273}
274
275void lbm_set_ctx_done_callback(void (*fptr)(eval_context_t *)) {
276 if (fptr == NULL((void*)0)) ctx_done_callback = ctx_done_nonsense;
277 else ctx_done_callback = fptr;
278}
279
280void lbm_set_printf_callback(int (*fptr)(const char*, ...)){
281 if (fptr == NULL((void*)0)) printf_callback = printf_nonsense;
282 else printf_callback = fptr;
283}
284
285void lbm_set_dynamic_load_callback(bool_Bool (*fptr)(const char *, const char **)) {
286 if (fptr == NULL((void*)0)) dynamic_load_callback = dynamic_load_nonsense;
287 else dynamic_load_callback = fptr;
288}
289
290static volatile lbm_event_t *lbm_events = NULL((void*)0);
291static unsigned int lbm_events_head = 0;
292static unsigned int lbm_events_tail = 0;
293static unsigned int lbm_events_max = 0;
294static bool_Bool lbm_events_full = false0;
295static mutex_t lbm_events_mutex;
296static bool_Bool lbm_events_mutex_initialized = false0;
297static volatile lbm_cid lbm_event_handler_pid = -1;
298
299lbm_cid lbm_get_event_handler_pid(void) {
300 return lbm_event_handler_pid;
301}
302
303void lbm_set_event_handler_pid(lbm_cid pid) {
304 lbm_event_handler_pid = pid;
305}
306
307bool_Bool lbm_event_handler_exists(void) {
308 return(lbm_event_handler_pid > 0);
309}
310
311
312static bool_Bool event_internal(lbm_event_type_t event_type, lbm_uint parameter, lbm_uint buf_ptr, lbm_uint buf_len) {
313 bool_Bool r = false0;
314 if (lbm_events) {
315 mutex_lock(&lbm_events_mutex);
316 if (!lbm_events_full) {
317 lbm_event_t event;
318 event.type = event_type;
319 event.parameter = parameter;
320 event.buf_ptr = buf_ptr;
321 event.buf_len = buf_len;
322 lbm_events[lbm_events_head] = event;
323 lbm_events_head = (lbm_events_head + 1) % lbm_events_max;
324 lbm_events_full = lbm_events_head == lbm_events_tail;
325 r = true1;
326 }
327 mutex_unlock(&lbm_events_mutex);
328 }
329 return r;
330}
331
332bool_Bool lbm_event_define(lbm_value key, lbm_flat_value_t *fv) {
333 return event_internal(LBM_EVENT_DEFINE, key, (lbm_uint)fv->buf, fv->buf_size);
334}
335
336bool_Bool lbm_event_unboxed(lbm_value unboxed) {
337 lbm_uint t = lbm_type_of(unboxed);
338 if (t == LBM_TYPE_SYMBOL0x00000000u ||
339 t == LBM_TYPE_I0x00000008u ||
340 t == LBM_TYPE_U0x0000000Cu ||
341 t == LBM_TYPE_CHAR0x00000004u) {
342 if (lbm_event_handler_pid > 0) {
343 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)unboxed, 0);
344 }
345 }
346 return false0;
347}
348
349bool_Bool lbm_event(lbm_flat_value_t *fv) {
350 if (lbm_event_handler_pid > 0) {
351 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)fv->buf, fv->buf_size);
352 }
353 return false0;
354}
355
356static bool_Bool lbm_event_pop(lbm_event_t *event) {
357 mutex_lock(&lbm_events_mutex);
358 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
359 mutex_unlock(&lbm_events_mutex);
360 return false0;
361 }
362 *event = lbm_events[lbm_events_tail];
363 lbm_events_tail = (lbm_events_tail + 1) % lbm_events_max;
364 lbm_events_full = false0;
365 mutex_unlock(&lbm_events_mutex);
366 return true1;
367}
368
369bool_Bool lbm_event_queue_is_empty(void) {
370 mutex_lock(&lbm_events_mutex);
371 bool_Bool empty = false0;
372 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
373 empty = true1;
374 }
375 mutex_unlock(&lbm_events_mutex);
376 return empty;
377}
378
379static bool_Bool eval_running = false0;
380static volatile bool_Bool blocking_extension = false0;
381static mutex_t blocking_extension_mutex;
382static bool_Bool blocking_extension_mutex_initialized = false0;
383static lbm_uint blocking_extension_timeout_us = 0;
384static bool_Bool blocking_extension_timeout = false0;
385
386static uint32_t is_atomic = 0;
387
388/* Process queues */
389static eval_context_queue_t blocked = {NULL((void*)0), NULL((void*)0)};
390static eval_context_queue_t queue = {NULL((void*)0), NULL((void*)0)};
391
392/* one mutex for all queue operations */
393mutex_t qmutex;
394bool_Bool qmutex_initialized = false0;
395
396
397// MODES
398static volatile bool_Bool lbm_verbose = false0;
399
400void lbm_toggle_verbose(void) {
401 lbm_verbose = !lbm_verbose;
402}
403
404void lbm_set_verbose(bool_Bool verbose) {
405 lbm_verbose = verbose;
406}
407
408lbm_cid lbm_get_current_cid(void) {
409 if (ctx_running)
410 return ctx_running->id;
411 else
412 return -1;
413}
414
415eval_context_t *lbm_get_current_context(void) {
416 return ctx_running;
417}
418
419/****************************************************/
420/* Utilities used locally in this file */
421
422static lbm_value cons_with_gc(lbm_value head, lbm_value tail, lbm_value remember) {
423#ifdef LBM_ALWAYS_GC
424 lbm_value roots[3] = {head, tail, remember};
425 lbm_gc_mark_roots(roots, 3);
426 gc();
427 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
428 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
429 if (lbm_is_symbol_merror(res)) {
430 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
431 }
432 return res;
433#else
434 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
435 if (lbm_is_symbol_merror(res)) {
436 lbm_value roots[3] = {head, tail, remember};
437 lbm_gc_mark_roots(roots,3);
438 gc();
439 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
440 if (lbm_is_symbol_merror(res)) {
441 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
442 }
443 }
444 return res;
445#endif
446}
447
448static lbm_uint *get_stack_ptr(eval_context_t *ctx, unsigned int n) {
449 if (n <= ctx->K.sp) {
450 lbm_uint index = ctx->K.sp - n;
451 return &ctx->K.data[index];
452 }
453 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
454 return 0; // dead code cannot be reached, but C compiler doesn't realise.
455}
456
457// pop_stack_ptr is safe when no GC is performed and
458// the values of the stack will be dropped.
459static lbm_uint *pop_stack_ptr(eval_context_t *ctx, unsigned int n) {
460 if (n <= ctx->K.sp) {
461 ctx->K.sp -= n;
462 return &ctx->K.data[ctx->K.sp];
463 }
464 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
465 return 0; // dead code cannot be reached, but C compiler doesn't realise.
466}
467
468static inline lbm_uint *stack_reserve(eval_context_t *ctx, unsigned int n) {
469 if (ctx->K.sp + n < ctx->K.size) {
470 lbm_uint *ptr = &ctx->K.data[ctx->K.sp];
471 ctx->K.sp += n;
472 return ptr;
473 }
474 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
475 return 0; // dead code cannot be reached, but C compiler doesn't realise.
476}
477
478static void handle_flash_status(lbm_flash_status s) {
479 if ( s == LBM_FLASH_FULL) {
480 lbm_set_error_reason((char*)lbm_error_str_flash_full);
481 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
482 }
483 if (s == LBM_FLASH_WRITE_ERROR) {
484 lbm_set_error_reason((char*)lbm_error_str_flash_error);
485 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
486 }
487}
488
489static void lift_array_flash(lbm_value flash_cell, bool_Bool bytearray, char *data, lbm_uint num_elt) {
490
491 lbm_array_header_t flash_array_header;
492 flash_array_header.size = num_elt;
493 flash_array_header.data = (lbm_uint*)data;
494 lbm_uint flash_array_header_ptr;
495 handle_flash_status(lbm_write_const_raw((lbm_uint*)&flash_array_header,
496 sizeof(lbm_array_header_t) / sizeof(lbm_uint),
497 &flash_array_header_ptr));
498 handle_flash_status(write_const_car(flash_cell, flash_array_header_ptr));
499 lbm_uint t = bytearray ? ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u) : ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u);
500 handle_flash_status(write_const_cdr(flash_cell, t));
501}
502
503static void get_car_and_cdr(lbm_value a, lbm_value *a_car, lbm_value *a_cdr) {
504 if (lbm_is_ptr(a)) {
505 lbm_cons_t *cell = lbm_ref_cell(a);
506 *a_car = cell->car;
507 *a_cdr = cell->cdr;
508 } else if (lbm_is_symbol_nil(a)) {
509 *a_car = *a_cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
510 } else {
511 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
512 }
513}
514
515/* car cdr caar cadr replacements that are evaluator safe. */
516static lbm_value get_car(lbm_value a) {
517 if (lbm_is_ptr(a)) {
13
←
Taking true branch
→
28
←
Taking false branch
→
518 lbm_cons_t *cell = lbm_ref_cell(a);
519 return cell->car;
14
←
Returning value, which participates in a condition later
→
520 } else if (lbm_is_symbol_nil(a)) {
29
←
Calling 'lbm_is_symbol_nil'
→
32
←
Returning from 'lbm_is_symbol_nil'
→
33
←
Taking true branch
→
521 return a;
34
←
Returning zero (loaded from 'a')
→
522 }
523 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
524 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
525}
526
527static lbm_value get_cdr(lbm_value a) {
528 if (lbm_is_ptr(a)) {
18
←
Taking true branch
→
529 lbm_cons_t *cell = lbm_ref_cell(a);
530 return cell->cdr;
19
←
Returning value, which participates in a condition later
→
20
←
Returning value
→
531 } else if (lbm_is_symbol_nil(a)) {
532 return a;
533 }
534 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
535 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
536}
537
538static lbm_value get_cadr(lbm_value a) {
539 if (lbm_is_ptr(a)) {
540 lbm_cons_t *cell = lbm_ref_cell(a);
541 lbm_value tmp = cell->cdr;
542 if (lbm_is_ptr(tmp)) {
543 return lbm_ref_cell(tmp)->car;
544 } else if (lbm_is_symbol_nil(tmp)) {
545 return tmp;
546 }
547 } else if (lbm_is_symbol_nil(a)) {
548 return a;
549 }
550 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
551 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
552}
553
554static lbm_value allocate_closure(lbm_value params, lbm_value body, lbm_value env) {
555
556#ifdef LBM_ALWAYS_GC
557 gc();
558 if (lbm_heap_num_free() < 4) {
559 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
560 }
561#else
562 if (lbm_heap_num_free() < 4) {
563 gc();
564 if (lbm_heap_num_free() < 4) {
565 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
566 }
567 }
568#endif
569 // The freelist will always contain just plain heap-cells.
570 // So dec_ptr is sufficient.
571 lbm_value res = lbm_heap_state.freelist;
572 if (lbm_type_of(res) == LBM_TYPE_CONS0x10000000u) {
573 lbm_cons_t *heap = lbm_heap_state.heap;
574 lbm_uint ix = lbm_dec_ptr(res);
575 heap[ix].car = ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u);
576 ix = lbm_dec_ptr(heap[ix].cdr);
577 heap[ix].car = params;
578 ix = lbm_dec_ptr(heap[ix].cdr);
579 heap[ix].car = body;
580 ix = lbm_dec_ptr(heap[ix].cdr);
581 heap[ix].car = env;
582 lbm_heap_state.freelist = heap[ix].cdr;
583 heap[ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
584 lbm_heap_state.num_alloc+=4;
585 } else {
586 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
587 }
588 return res;
589}
590
591// Allocate a binding and attach it to a list (if so desired)
592static lbm_value allocate_binding(lbm_value key, lbm_value val, lbm_value the_cdr) {
593 if (lbm_heap_num_free() < 2) {
594 gc();
595 if (lbm_heap_num_free() < 2) {
596 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
597 }
598 }
599 lbm_cons_t* heap = lbm_heap_state.heap;
600 lbm_value binding_cell = lbm_heap_state.freelist;
601 lbm_uint binding_cell_ix = lbm_dec_ptr(binding_cell);
602 lbm_value list_cell = heap[binding_cell_ix].cdr;
603 lbm_uint list_cell_ix = lbm_dec_ptr(list_cell);
604 lbm_heap_state.freelist = heap[list_cell_ix].cdr;
605 lbm_heap_state.num_alloc += 2;
606 heap[binding_cell_ix].car = key;
607 heap[binding_cell_ix].cdr = val;
608 heap[list_cell_ix].car = binding_cell;
609 heap[list_cell_ix].cdr = the_cdr;
610 return list_cell;
611}
612
613#define CLO_PARAMS0 0
614#define CLO_BODY1 1
615#define CLO_ENV2 2
616#define LOOP_BINDS0 0
617#define LOOP_COND1 1
618#define LOOP_BODY2 2
619
620// (a b c) -> [a b c]
621static lbm_value extract_n(lbm_value curr, lbm_value *res, unsigned int n) {
622 for (unsigned int i = 0; i < n; i ++) {
623 if (lbm_is_ptr(curr)) {
624 lbm_cons_t *cell = lbm_ref_cell(curr);
625 res[i] = cell->car;
626 curr = cell->cdr;
627 } else {
628 res[i] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
629 }
630 }
631 return curr; // Rest of list is returned here.
632}
633
634static void call_fundamental(lbm_uint fundamental, lbm_value *args, lbm_uint arg_count, eval_context_t *ctx) {
635 lbm_value res;
636 res = fundamental_table[fundamental](args, arg_count, ctx);
637 if (lbm_is_error(res)) {
638 if (lbm_is_symbol_merror(res)) {
639 gc();
640 res = fundamental_table[fundamental](args, arg_count, ctx);
641 }
642 if (lbm_is_error(res)) {
643 error_at_ctx(res, lbm_enc_sym(FUNDAMENTAL_SYMBOLS_START0x20000 | fundamental));
644 }
645 }
646 lbm_stack_drop(&ctx->K, arg_count+1);
647 ctx->app_cont = true1;
648 ctx->r = res;
649}
650
651// block_current_ctx blocks a context until it is
652// woken up externally or a timeout period of time passes.
653static void block_current_ctx(uint32_t state, lbm_uint sleep_us, bool_Bool do_cont) {
654 ctx_running->timestamp = timestamp_us_callback();
655 ctx_running->sleep_us = sleep_us;
656 ctx_running->state = state;
657 ctx_running->app_cont = do_cont;
658 enqueue_ctx(&blocked, ctx_running);
659 ctx_running = NULL((void*)0);
660}
661
662lbm_flash_status lbm_write_const_array_padded(uint8_t *data, lbm_uint n, lbm_uint *res) {
663 lbm_uint full_words = n / sizeof(lbm_uint);
664 lbm_uint n_mod = n % sizeof(lbm_uint);
665
666 if (n_mod == 0) { // perfect fit.
667 return lbm_write_const_raw((lbm_uint*)data, full_words, res);
668 } else {
669 lbm_uint last_word = 0;
670 memcpy(&last_word, &data[full_words * sizeof(lbm_uint)], n_mod);
671 if (full_words >= 1) {
672 lbm_flash_status s = lbm_write_const_raw((lbm_uint*)data, full_words, res);
673 if ( s == LBM_FLASH_WRITE_OK) {
674 lbm_uint dummy;
675 s = lbm_write_const_raw(&last_word, 1, &dummy);
676 }
677 return s;
678 } else {
679 return lbm_write_const_raw(&last_word, 1, res);
680 }
681 }
682}
683
684/****************************************************/
685/* Error message creation */
686
687#define ERROR_MESSAGE_BUFFER_SIZE_BYTES256 256
688
689void print_environments(char *buf, unsigned int size) {
690
691 lbm_value curr_l = ctx_running->curr_env;
692 printf_callback("\tCurrent local environment:\n");
693 while (lbm_type_of(curr_l) == LBM_TYPE_CONS0x10000000u) {
694 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_l));
695 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_l)));
696 printf_callback("\t%s = %s\n", buf, buf+(size/2));
697 curr_l = lbm_cdr(curr_l);
698 }
699 printf_callback("\n\n");
700 printf_callback("\tCurrent global environment:\n");
701 lbm_value *glob_env = lbm_get_global_env();
702
703 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
704 lbm_value curr_g = glob_env[i];;
705 while (lbm_type_of(curr_g) == LBM_TYPE_CONS0x10000000u) {
706
707 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_g));
708 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_g)));
709 printf_callback("\t%s = %s\n", buf, buf+(size/2));
710 curr_g = lbm_cdr(curr_g);
711 }
712 }
713}
714
715void print_error_message(lbm_value error, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int col, lbm_int row0, lbm_int row1) {
716 if (!printf_callback) return;
717
718 /* try to allocate a lbm_print_value buffer on the lbm_memory */
719 char *buf = lbm_malloc_reserve(ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
720 if (!buf) {
721 printf_callback("Error: Not enough free memory to create a human readable error message\n");
722 return;
723 }
724
725 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, error);
726 printf_callback( "*** Error: %s\n", buf);
727 if (has_at) {
728 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, at);
729 printf_callback("*** In: %s\n",buf);
730 if (lbm_error_has_suspect) {
731 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, lbm_error_suspect);
732 lbm_error_has_suspect = false0;
733 printf_callback("*** At: %s\n", buf);
734 } else {
735 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
736 printf_callback("*** After: %s\n",buf);
737 }
738 } else {
739 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
740 printf_callback("*** Near: %s\n",buf);
741 }
742
743 printf_callback("\n");
744
745 if (lbm_is_symbol(error) &&
746 error == ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u)) {
747 printf_callback("*** Line: %u\n", row);
748 printf_callback("*** Column: %u\n", col);
749 } else if (row0 != -1 || row1 != -1 ) {
750 printf_callback("*** Between rows: (-1 unknown) \n");
751 printf_callback("*** Start: %d\n", (int32_t)row0);
752 printf_callback("*** End: %d\n", (int32_t)row1);
753 }
754
755 printf_callback("\n");
756
757 if (ctx_running->error_reason) {
758 printf_callback("Reason:\n %s\n\n", ctx_running->error_reason);
759 }
760 if (lbm_verbose) {
761 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
762 printf_callback(" In context: %d\n", ctx_running->id);
763 printf_callback(" Current intermediate result: %s\n\n", buf);
764
765 print_environments(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
766 printf_callback("\n\n");
767
768 printf_callback(" Stack:\n");
769 for (unsigned int i = 0; i < ctx_running->K.sp; i ++) {
770 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->K.data[i]);
771 printf_callback(" %s\n", buf);
772 }
773 }
774 lbm_free(buf);
775}
776
777/****************************************************/
778/* Tokenizing and parsing */
779
780bool_Bool create_string_channel(char *str, lbm_value *res) {
781
782 lbm_char_channel_t *chan = NULL((void*)0);
783 lbm_string_channel_state_t *st = NULL((void*)0);
784
785 st = (lbm_string_channel_state_t*)lbm_memory_allocate(sizeof(lbm_string_channel_state_t) / sizeof(lbm_uint) +1);
786 if (st == NULL((void*)0)) {
787 return false0;
788 }
789 chan = (lbm_char_channel_t*)lbm_memory_allocate(sizeof(lbm_char_channel_t) / sizeof(lbm_uint) + 1);
790 if (chan == NULL((void*)0)) {
791 lbm_memory_free((lbm_uint*)st);
792 return false0;
793 }
794
795 lbm_create_string_char_channel(st, chan, str);
796 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
797 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
798 lbm_memory_free((lbm_uint*)st);
799 lbm_memory_free((lbm_uint*)chan);
800 return false0;
801 }
802
803 *res = cell;
804 return true1;
805}
806
807bool_Bool lift_char_channel(lbm_char_channel_t *chan , lbm_value *res) {
808 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
809 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
810 return false0;
811 }
812 *res = cell;
813 return true1;
814}
815
816
817/****************************************************/
818/* Queue functions */
819
820static void queue_iterator_nm(eval_context_queue_t *q, ctx_fun f, void *arg1, void *arg2) {
821 eval_context_t *curr;
822 curr = q->first;
823
824 while (curr != NULL((void*)0)) {
825 f(curr, arg1, arg2);
826 curr = curr->next;
827 }
828}
829
830void lbm_running_iterator(ctx_fun f, void *arg1, void *arg2){
831 mutex_lock(&qmutex);
832 queue_iterator_nm(&queue, f, arg1, arg2);
833 mutex_unlock(&qmutex);
834}
835
836void lbm_blocked_iterator(ctx_fun f, void *arg1, void *arg2){
837 mutex_lock(&qmutex);
838 queue_iterator_nm(&blocked, f, arg1, arg2);
839 mutex_unlock(&qmutex);
840}
841
842static void enqueue_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
843 if (q->last == NULL((void*)0)) {
844 ctx->prev = NULL((void*)0);
845 ctx->next = NULL((void*)0);
846 q->first = ctx;
847 q->last = ctx;
848 } else {
849 ctx->prev = q->last;
850 ctx->next = NULL((void*)0);
851 q->last->next = ctx;
852 q->last = ctx;
853 }
854}
855
856static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx) {
857 mutex_lock(&qmutex);
858 enqueue_ctx_nm(q,ctx);
859 mutex_unlock(&qmutex);
860}
861
862static eval_context_t *lookup_ctx_nm(eval_context_queue_t *q, lbm_cid cid) {
863 eval_context_t *curr;
864 curr = q->first;
865 while (curr != NULL((void*)0)) {
866 if (curr->id == cid) {
867 return curr;
868 }
869 curr = curr->next;
870 }
871 return NULL((void*)0);
872}
873
874static bool_Bool drop_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
875
876 bool_Bool res = false0;
877 if (q->first == NULL((void*)0) || q->last == NULL((void*)0)) {
878 if (!(q->last == NULL((void*)0) && q->first == NULL((void*)0))) {
879 /* error state that should not happen */
880 return res;
881 }
882 /* Queue is empty */
883 return res;
884 }
885
886 eval_context_t *curr = q->first;
887 while (curr) {
888 if (curr->id == ctx->id) {
889 res = true1;
890 eval_context_t *tmp = curr->next;
891 if (curr->prev == NULL((void*)0)) {
892 if (curr->next == NULL((void*)0)) {
893 q->last = NULL((void*)0);
894 q->first = NULL((void*)0);
895 } else {
896 q->first = tmp;
897 tmp->prev = NULL((void*)0);
898 }
899 } else { /* curr->prev != NULL */
900 if (curr->next == NULL((void*)0)) {
901 q->last = curr->prev;
902 q->last->next = NULL((void*)0);
903 } else {
904 curr->prev->next = tmp;
905 tmp->prev = curr->prev;
906 }
907 }
908 break;
909 }
910 curr = curr->next;
911 }
912 return res;
913}
914
915/* End execution of the running context. */
916static void finish_ctx(void) {
917
918 if (!ctx_running) {
919 return;
920 }
921 /* Drop the continuation stack immediately to free up lbm_memory */
922 lbm_stack_free(&ctx_running->K);
923 ctx_done_callback(ctx_running);
924 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->name)) {
925 lbm_free(ctx_running->name);
926 }
927 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->error_reason)) {
928 lbm_memory_free((lbm_uint*)ctx_running->error_reason);
929 }
930 lbm_memory_free((lbm_uint*)ctx_running->mailbox);
931 lbm_memory_free((lbm_uint*)ctx_running);
932 ctx_running = NULL((void*)0);
933}
934
935static void context_exists(eval_context_t *ctx, void *cid, void *b) {
936 if (ctx->id == *(lbm_cid*)cid) {
937 *(bool_Bool*)b = true1;
938 }
939}
940
941bool_Bool lbm_wait_ctx(lbm_cid cid, lbm_uint timeout_ms) {
942
943 bool_Bool exists;
944 uint32_t i = 0;
945
946 do {
947 exists = false0;
948 lbm_blocked_iterator(context_exists, &cid, &exists);
949 lbm_running_iterator(context_exists, &cid, &exists);
950
951 if (ctx_running &&
952 ctx_running->id == cid) {
953 exists = true1;
954 }
955
956 if (exists) {
957 if (usleep_callback) {
958 usleep_callback(1000);
959 }
960 if (timeout_ms > 0) i ++;
961 }
962 } while (exists && i < timeout_ms);
963
964 if (exists) return false0;
965 return true1;
966}
967
968void lbm_set_error_suspect(lbm_value suspect) {
969 lbm_error_suspect = suspect;
970 lbm_error_has_suspect = true1;
971}
972
973void lbm_set_error_reason(char *error_str) {
974 if (ctx_running != NULL((void*)0)) {
975 ctx_running->error_reason = error_str;
976 }
977}
978
979// Not possible to CONS_WITH_GC in error_ctx_base (potential loop)
980static void error_ctx_base(lbm_value err_val, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int column) {
981
982 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
983 if (lbm_heap_num_free() < 3) {
984 gc();
985 }
986
987 if (lbm_heap_num_free() >= 3) {
988 lbm_value msg = lbm_cons(err_val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
989 msg = lbm_cons(lbm_enc_i(ctx_running->id), msg);
990 msg = lbm_cons(ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u), msg);
991 if (!lbm_is_symbol_merror(msg)) {
992 lbm_find_receiver_and_send(ctx_running->parent, msg);
993 goto error_ctx_base_done;
994 }
995 }
996 }
997 if ((ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10) &&
998 (err_val != ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u))) {
999 lbm_uint v;
1000 while (ctx_running->K.sp > 0) {
1001 lbm_pop(&ctx_running->K, &v);
1002 if (v == EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u)) {
1003 lbm_value *sptr = get_stack_ptr(ctx_running, 2);
1004 lbm_set_car(sptr[0], ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
1005 stack_reserve(ctx_running, 1)[0] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1006 ctx_running->app_cont = true1;
1007 ctx_running->r = err_val;
1008 longjmp(error_jmp_buf, 1);
1009 }
1010 }
1011 err_val = ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u);
1012 }
1013 print_error_message(err_val,
1014 has_at,
1015 at,
1016 row,
1017 column,
1018 ctx_running->row0,
1019 ctx_running->row1);
1020 error_ctx_base_done:
1021 ctx_running->r = err_val;
1022 finish_ctx();
1023 longjmp(error_jmp_buf, 1);
1024}
1025
1026static void error_at_ctx(lbm_value err_val, lbm_value at) {
1027 error_ctx_base(err_val, true1, at, 0, 0);
1028}
1029
1030static void error_ctx(lbm_value err_val) {
1031 error_ctx_base(err_val, false0, 0, 0, 0);
1032}
1033
1034static void read_error_ctx(unsigned int row, unsigned int column) {
1035 error_ctx_base(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u), false0, 0, row, column);
1036}
1037
1038void lbm_critical_error(void) {
1039 longjmp(critical_error_jmp_buf, 1);
1040}
1041
1042// successfully finish a context
1043static void ok_ctx(void) {
1044 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
1045 lbm_value msg;
1046 WITH_GC(msg, lbm_heap_allocate_list_init(3,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1047 ENC_SYM_EXIT_OK,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1048 lbm_enc_i(ctx_running->id),(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1049 ctx_running->r))(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
1050 lbm_find_receiver_and_send(ctx_running->parent, msg);
1051 }
1052 finish_ctx();
1053}
1054
1055static eval_context_t *dequeue_ctx_nm(eval_context_queue_t *q) {
1056 if (q->last == NULL((void*)0)) {
1057 return NULL((void*)0);
1058 }
1059 // q->first should only be NULL if q->last is.
1060 eval_context_t *res = q->first;
1061
1062 if (q->first == q->last) { // One thing in queue
1063 q->first = NULL((void*)0);
1064 q->last = NULL((void*)0);
1065 } else {
1066 q->first = q->first->next;
1067 q->first->prev = NULL((void*)0);
1068 }
1069 res->prev = NULL((void*)0);
1070 res->next = NULL((void*)0);
1071 return res;
1072}
1073
1074static void wake_up_ctxs_nm(void) {
1075 lbm_uint t_now;
1076
1077 if (timestamp_us_callback) {
1078 t_now = timestamp_us_callback();
1079 } else {
1080 t_now = 0;
1081 }
1082
1083 eval_context_queue_t *q = &blocked;
1084 eval_context_t *curr = q->first;
1085
1086 while (curr != NULL((void*)0)) {
1087 lbm_uint t_diff;
1088 eval_context_t *next = curr->next;
1089 if (curr->state != LBM_THREAD_STATE_BLOCKED(uint32_t)1) {
1090 if ( curr->timestamp > t_now) {
1091 /* There was an overflow on the counter */
1092#ifndef LBM64
1093 t_diff = (0xFFFFFFFF - curr->timestamp) + t_now;
1094#else
1095 t_diff = (0xFFFFFFFFFFFFFFFF - curr->timestamp) + t_now;
1096#endif
1097 } else {
1098 t_diff = t_now - curr->timestamp;
1099 }
1100
1101 if (t_diff >= curr->sleep_us) {
1102 eval_context_t *wake_ctx = curr;
1103 if (curr == q->last) {
1104 if (curr->prev) {
1105 q->last = curr->prev;
1106 q->last->next = NULL((void*)0);
1107 } else {
1108 q->first = NULL((void*)0);
1109 q->last = NULL((void*)0);
1110 }
1111 } else if (curr->prev == NULL((void*)0)) {
1112 q->first = curr->next;
1113 q->first->prev = NULL((void*)0);
1114 } else {
1115 curr->prev->next = curr->next;
1116 if (curr->next) {
1117 curr->next->prev = curr->prev;
1118 }
1119 }
1120 wake_ctx->next = NULL((void*)0);
1121 wake_ctx->prev = NULL((void*)0);
1122 if (curr->state == LBM_THREAD_STATE_TIMEOUT(uint32_t)2) {
1123 mailbox_add_mail(wake_ctx, ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u));
1124 wake_ctx->r = ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u);
1125 }
1126 wake_ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1127 enqueue_ctx_nm(&queue, wake_ctx);
1128 }
1129 }
1130 curr = next;
1131 }
1132}
1133
1134static void yield_ctx(lbm_uint sleep_us) {
1135 if (timestamp_us_callback) {
1136 ctx_running->timestamp = timestamp_us_callback();
1137 ctx_running->sleep_us = sleep_us;
1138 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1139 } else {
1140 ctx_running->timestamp = 0;
1141 ctx_running->sleep_us = 0;
1142 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1143 }
1144 ctx_running->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1145 ctx_running->app_cont = true1;
1146 enqueue_ctx(&blocked,ctx_running);
1147 ctx_running = NULL((void*)0);
1148}
1149
1150static lbm_cid lbm_create_ctx_parent(lbm_value program, lbm_value env, lbm_uint stack_size, lbm_cid parent, uint32_t context_flags, char *name) {
1151
1152 if (!lbm_is_cons(program)) return -1;
1153
1154 eval_context_t *ctx = NULL((void*)0);
1155
1156 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1157 if (ctx == NULL((void*)0)) {
1158 lbm_uint roots[2] = {program, env};
1159 lbm_gc_mark_roots(roots, 2);
1160 gc();
1161 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1162 }
1163 if (ctx == NULL((void*)0)) return -1;
1164
1165 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1166 lbm_uint roots[2] = {program, env};
1167 lbm_gc_mark_roots(roots, 2);
1168 gc();
1169 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1170 lbm_memory_free((lbm_uint*)ctx);
1171 return -1;
1172 }
1173 }
1174
1175 lbm_value *mailbox = NULL((void*)0);
1176 mailbox = (lbm_value*)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1177 if (mailbox == NULL((void*)0)) {
1178 lbm_value roots[2] = {program, env};
1179 lbm_gc_mark_roots(roots,2);
1180 gc();
1181 mailbox = (lbm_value *)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1182 }
1183 if (mailbox == NULL((void*)0)) {
1184 lbm_stack_free(&ctx->K);
1185 lbm_memory_free((lbm_uint*)ctx);
1186 return -1;
1187 }
1188
1189 // TODO: Limit names to 19 chars + 1 char for 0? (or something similar).
1190 if (name) {
1191 lbm_uint name_len = strlen(name) + 1;
1192 ctx->name = lbm_malloc(strlen(name) + 1);
1193 if (ctx->name == NULL((void*)0)) {
1194 lbm_value roots[2] = {program, env};
1195 lbm_gc_mark_roots(roots, 2);
1196 gc();
1197 ctx->name = lbm_malloc(strlen(name) + 1);
1198 }
1199 if (ctx->name == NULL((void*)0)) {
1200 lbm_stack_free(&ctx->K);
1201 lbm_memory_free((lbm_uint*)mailbox);
1202 lbm_memory_free((lbm_uint*)ctx);
1203 return -1;
1204 }
1205 memcpy(ctx->name, name, name_len+1);
1206 } else {
1207 ctx->name = NULL((void*)0);
1208 }
1209
1210 lbm_int cid = lbm_memory_address_to_ix((lbm_uint*)ctx);
1211
1212 ctx->program = lbm_cdr(program);
1213 ctx->curr_exp = lbm_car(program);
1214 ctx->curr_env = env;
1215 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1216 ctx->error_reason = NULL((void*)0);
1217 ctx->mailbox = mailbox;
1218 ctx->mailbox_size = EVAL_CPS_DEFAULT_MAILBOX_SIZE10;
1219 ctx->flags = context_flags;
1220 ctx->num_mail = 0;
1221 ctx->app_cont = false0;
1222 ctx->timestamp = 0;
1223 ctx->sleep_us = 0;
1224 ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1225 ctx->prev = NULL((void*)0);
1226 ctx->next = NULL((void*)0);
1227
1228 ctx->row0 = -1;
1229 ctx->row1 = -1;
1230
1231 ctx->id = cid;
1232 ctx->parent = parent;
1233
1234 if (!lbm_push(&ctx->K, DONE(((0) << 2) | 0xF8000001u))) {
1235 lbm_memory_free((lbm_uint*)ctx->mailbox);
1236 lbm_stack_free(&ctx->K);
1237 lbm_memory_free((lbm_uint*)ctx);
1238 return -1;
1239 }
1240
1241 enqueue_ctx(&queue,ctx);
1242
1243 return ctx->id;
1244}
1245
1246lbm_cid lbm_create_ctx(lbm_value program, lbm_value env, lbm_uint stack_size, char *name) {
1247 // Creates a parentless context.
1248 return lbm_create_ctx_parent(program,
1249 env,
1250 stack_size,
1251 -1,
1252 EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00,
1253 name);
1254}
1255
1256bool_Bool lbm_mailbox_change_size(eval_context_t *ctx, lbm_uint new_size) {
1257
1258 lbm_value *mailbox = NULL((void*)0);
1259 mailbox = (lbm_value*)lbm_memory_allocate(new_size);
1260 if (mailbox == NULL((void*)0)) {
1261 gc();
1262 mailbox = (lbm_value *)lbm_memory_allocate(new_size);
1263 }
1264 if (mailbox == NULL((void*)0)) {
1265 return false0;
1266 }
1267
1268 for (lbm_uint i = 0; i < ctx->num_mail; i ++ ) {
1269 mailbox[i] = ctx->mailbox[i];
1270 }
1271 lbm_memory_free(ctx->mailbox);
1272 ctx->mailbox = mailbox;
1273 ctx->mailbox_size = (uint32_t)new_size;
1274 return true1;
1275}
1276
1277static void mailbox_remove_mail(eval_context_t *ctx, lbm_uint ix) {
1278
1279 for (lbm_uint i = ix; i < ctx->num_mail-1; i ++) {
1280 ctx->mailbox[i] = ctx->mailbox[i+1];
1281 }
1282 ctx->num_mail --;
1283}
1284
1285static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail) {
1286
1287 if (ctx->num_mail >= ctx->mailbox_size) {
1288 mailbox_remove_mail(ctx, 0);
1289 }
1290
1291 ctx->mailbox[ctx->num_mail] = mail;
1292 ctx->num_mail ++;
1293 return true1;
1294}
1295
1296/* Advance execution to the next expression in the program */
1297static void advance_ctx(eval_context_t *ctx) {
1298 if (lbm_is_cons(ctx->program)) {
1299 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);;
1300 get_car_and_cdr(ctx->program, &ctx->curr_exp, &ctx->program);
1301 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1302 } else {
1303 if (ctx_running == ctx) { // This should always be the case because of odd historical reasons.
1304 ok_ctx();
1305 }
1306 }
1307}
1308
1309bool_Bool lbm_unblock_ctx(lbm_cid cid, lbm_flat_value_t *fv) {
1310 return event_internal(LBM_EVENT_UNBLOCK_CTX, (lbm_uint)cid, (lbm_uint)fv->buf, fv->buf_size);
1311}
1312
1313bool_Bool lbm_unblock_ctx_r(lbm_cid cid) {
1314 mutex_lock(&blocking_extension_mutex);
1315 bool_Bool r = false0;
1316 eval_context_t *found = NULL((void*)0);
1317 mutex_lock(&qmutex);
1318 found = lookup_ctx_nm(&blocked, cid);
1319 if (found) {
1320 drop_ctx_nm(&blocked,found);
1321 enqueue_ctx_nm(&queue,found);
1322 r = true1;
1323 }
1324 mutex_unlock(&qmutex);
1325 mutex_unlock(&blocking_extension_mutex);
1326 return r;
1327}
1328
1329// unblock unboxed is also safe for rmbr:ed things.
1330bool_Bool lbm_unblock_ctx_unboxed(lbm_cid cid, lbm_value unboxed) {
1331 mutex_lock(&blocking_extension_mutex);
1332 bool_Bool r = false0;
1333 eval_context_t *found = NULL((void*)0);
1334 mutex_lock(&qmutex);
1335 found = lookup_ctx_nm(&blocked, cid);
1336 if (found) {
1337 drop_ctx_nm(&blocked,found);
1338 found->r = unboxed;
1339 if (lbm_is_error(unboxed)) {
1340 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
1341 found->app_cont = true1;
1342 }
1343 enqueue_ctx_nm(&queue,found);
1344 r = true1;
1345 }
1346 mutex_unlock(&qmutex);
1347 mutex_unlock(&blocking_extension_mutex);
1348 return r;
1349}
1350
1351static bool_Bool lbm_block_ctx_base(bool_Bool timeout, float t_s) {
1352 mutex_lock(&blocking_extension_mutex);
1353 blocking_extension = true1;
1354 if (timeout) {
1355 blocking_extension_timeout_us = S_TO_US(t_s)(lbm_uint)((t_s) * 1000000);
1356 blocking_extension_timeout = true1;
1357 } else {
1358 blocking_extension_timeout = false0;
1359 }
1360 return true1;
1361}
1362
1363void lbm_block_ctx_from_extension_timeout(float s) {
1364 lbm_block_ctx_base(true1, s);
1365}
1366
1367void lbm_block_ctx_from_extension(void) {
1368 lbm_block_ctx_base(false0, 0);
1369}
1370
1371// todo: May need to pop rmbrs from stack, if present.
1372// Suspect that the letting the discard cont run is really not a problem.
1373// Either way will be quite confusing what happens to allocated things when undoing block.
1374void lbm_undo_block_ctx_from_extension(void) {
1375 blocking_extension = false0;
1376 blocking_extension_timeout_us = 0;
1377 blocking_extension_timeout = false0;
1378 mutex_unlock(&blocking_extension_mutex);
1379}
1380
1381lbm_value lbm_find_receiver_and_send(lbm_cid cid, lbm_value msg) {
1382 mutex_lock(&qmutex);
1383 eval_context_t *found = NULL((void*)0);
1384 bool_Bool found_blocked = false0;
1385
1386 found = lookup_ctx_nm(&blocked, cid);
1387 if (found) found_blocked = true1;
1388
1389 if (found == NULL((void*)0)) {
1390 found = lookup_ctx_nm(&queue, cid);
1391 }
1392
1393 if (found) {
1394 if (!mailbox_add_mail(found, msg)) {
1395 mutex_unlock(&qmutex);
1396 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1397 }
1398
1399 if (found_blocked){
1400 drop_ctx_nm(&blocked,found);
1401 enqueue_ctx_nm(&queue,found);
1402 }
1403 mutex_unlock(&qmutex);
1404 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1405 }
1406
1407 /* check the current context */
1408 if (ctx_running && ctx_running->id == cid) {
1409 if (!mailbox_add_mail(ctx_running, msg)) {
1410 mutex_unlock(&qmutex);
1411 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1412 }
1413 mutex_unlock(&qmutex);
1414 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1415 }
1416 mutex_unlock(&qmutex);
1417 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1418}
1419
1420/* Pattern matching is currently implemented as a recursive
1421 function and make use of stack relative to the size of
1422 expressions that are being matched. */
1423static bool_Bool match(lbm_value p, lbm_value e, lbm_value *env, bool_Bool *gc) {
1424
1425 lbm_value binding;
1426
1427 if (lbm_is_match_binder(p)) {
1428 lbm_value var = get_cadr(p);
1429 lbm_value bindertype = get_car(p);
1430
1431 if (!lbm_is_symbol(var)) return false0;
1432
1433 switch (bindertype) {
1434 case ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u):
1435 if ( var == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) {
1436 return true1;
1437 }
1438 break;
1439 default: /* this should be an error case */
1440 return false0;
1441 }
1442 binding = lbm_cons(var, e);
1443 if ( lbm_type_of(binding) == LBM_TYPE_SYMBOL0x00000000u ) {
1444 *gc = true1;
1445 return false0;
1446 }
1447 *env = lbm_cons(binding, *env);
1448 if ( lbm_type_of(*env) == LBM_TYPE_SYMBOL0x00000000u ) {
1449 *gc = true1;
1450 return false0;
1451 }
1452 return true1;
1453 }
1454
1455 if (lbm_is_symbol(p)) {
1456 if (p == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return true1;
1457 return (p == e);
1458 }
1459 if (lbm_is_cons(p) &&
1460 lbm_is_cons(e) ) {
1461
1462 lbm_value headp, tailp;
1463 lbm_value heade, taile;
1464 get_car_and_cdr(p, &headp, &tailp);
1465 get_car_and_cdr(e, &heade, &taile); // Static analysis warns, but execution does not
1466 // past this point unless head and tail get initialized.
1467 if (!match(headp, heade, env, gc)) {
1468 return false0;
1469 }
1470 return match (tailp, taile, env, gc);
1471 }
1472 return struct_eq(p, e);
1473}
1474
1475// Find match is not very picky about syntax.
1476// A completely malformed recv form is most likely to
1477// just return no_match.
1478static int find_match(lbm_value plist, lbm_value *earr, lbm_uint num, lbm_value *e, lbm_value *env) {
1479
1480 // A pattern list is a list of pattern, expression lists.
1481 // ( (p1 e1) (p2 e2) ... (pn en))
1482 lbm_value curr_p = plist;
1483 int n = 0;
1484 bool_Bool gc = false0;
1485 for (int i = 0; i < (int)num; i ++ ) {
1486 lbm_value curr_e = earr[i];
1487 while (!lbm_is_symbol_nil(curr_p)) {
1488 lbm_value me = get_car(curr_p);
1489 if (match(get_car(me), curr_e, env, &gc)) {
1490 if (gc) return FM_NEED_GC-1;
1491 *e = get_cadr(me);
1492
1493 if (!lbm_is_symbol_nil(get_cadr(get_cdr(me)))) {
1494 return FM_PATTERN_ERROR-3;
1495 }
1496 return n;
1497 }
1498 curr_p = get_cdr(curr_p);
1499 }
1500 curr_p = plist; /* search all patterns against next exp */
1501 n ++;
1502 }
1503
1504 return FM_NO_MATCH-2;
1505}
1506
1507/****************************************************/
1508/* Garbage collection */
1509
1510static void mark_context(eval_context_t *ctx, void *arg1, void *arg2) {
1511 (void) arg1;
1512 (void) arg2;
1513 lbm_value roots[3] = {ctx->curr_exp, ctx->program, ctx->r };
1514 lbm_gc_mark_env(ctx->curr_env);
1515 lbm_gc_mark_roots(roots, 3);
1516 lbm_gc_mark_roots(ctx->mailbox, ctx->num_mail);
1517 lbm_gc_mark_aux(ctx->K.data, ctx->K.sp);
1518}
1519
1520static int gc(void) {
1521 if (ctx_running) {
1522 ctx_running->state = ctx_running->state | LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1523 }
1524
1525 gc_requested = false0;
1526 lbm_gc_state_inc();
1527
1528 // The freelist should generally be NIL when GC runs.
1529 lbm_nil_freelist();
1530 lbm_value *env = lbm_get_global_env();
1531 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
1532 lbm_gc_mark_env(env[i]);
1533 }
1534
1535 mutex_lock(&qmutex); // Lock the queues.
1536 // Any concurrent messing with the queues
1537 // while doing GC cannot possibly be good.
1538 queue_iterator_nm(&queue, mark_context, NULL((void*)0), NULL((void*)0));
1539 queue_iterator_nm(&blocked, mark_context, NULL((void*)0), NULL((void*)0));
1540
1541 if (ctx_running) {
1542 mark_context(ctx_running, NULL((void*)0), NULL((void*)0));
1543 }
1544 mutex_unlock(&qmutex);
1545
1546#ifdef VISUALIZE_HEAP
1547 heap_vis_gen_image();
1548#endif
1549
1550 int r = lbm_gc_sweep_phase();
1551 lbm_heap_new_freelist_length();
1552
1553 if (ctx_running) {
1554 ctx_running->state = ctx_running->state & ~LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1555 }
1556 return r;
1557}
1558
1559int lbm_perform_gc(void) {
1560 return gc();
1561}
1562
1563/****************************************************/
1564/* Evaluation functions */
1565
1566
1567static void eval_symbol(eval_context_t *ctx) {
1568 lbm_uint s = lbm_dec_sym(ctx->curr_exp);
1569 if (s >= RUNTIME_SYMBOLS_START0x40000) {
1570 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1571 if (lbm_env_lookup_b(&res, ctx->curr_exp, ctx->curr_env) ||
1572 lbm_global_env_lookup(&res, ctx->curr_exp)) {
1573 ctx->r = res;
1574 ctx->app_cont = true1;
1575 return;
1576 }
1577 // Dynamic load attempt
1578 // Only symbols of kind RUNTIME can be dynamically loaded.
1579 const char *sym_str = lbm_get_name_by_symbol(s);
1580 const char *code_str = NULL((void*)0);
1581 if (!dynamic_load_callback(sym_str, &code_str)) {
1582 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), ctx->curr_exp);
1583 }
1584 lbm_value *sptr = stack_reserve(ctx, 3);
1585 sptr[0] = ctx->curr_exp;
1586 sptr[1] = ctx->curr_env;
1587 sptr[2] = RESUME(((12) << 2) | 0xF8000001u);
1588
1589 lbm_value chan;
1590 if (!create_string_channel((char *)code_str, &chan)) {
1591 gc();
1592 if (!create_string_channel((char *)code_str, &chan)) {
1593 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1594 }
1595 }
1596
1597 lbm_value loader;
1598 WITH_GC_RMBR_1(loader, lbm_heap_allocate_list_init(2,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1599 ENC_SYM_READ,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1600 chan), chan)(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} };
1601 lbm_value evaluator;
1602 WITH_GC_RMBR_1(evaluator, lbm_heap_allocate_list_init(2,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1603 ENC_SYM_EVAL,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1604 loader), loader)(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } };
1605 ctx->curr_exp = evaluator;
1606 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // dynamics should be evaluable in empty local env
1607 } else {
1608 //special symbols and extensions can be handled the same way.
1609 ctx->r = ctx->curr_exp;
1610 ctx->app_cont = true1;
1611 }
1612}
1613
1614static void eval_quote(eval_context_t *ctx) {
1615 ctx->r = get_cadr(ctx->curr_exp);
1616 ctx->app_cont = true1;
1617}
1618
1619static void eval_selfevaluating(eval_context_t *ctx) {
1620 ctx->r = ctx->curr_exp;
1621 ctx->app_cont = true1;
1622}
1623
1624static void eval_progn(eval_context_t *ctx) {
1625 lbm_value exps = get_cdr(ctx->curr_exp);
1626
1627 if (lbm_is_cons(exps)) {
1628 lbm_uint *sptr = stack_reserve(ctx, 4);
1629 sptr[0] = ctx->curr_env; // env to restore between expressions in progn
1630 sptr[1] = lbm_enc_u(0); // Has env been copied (needed for progn local bindings)
1631 sptr[3] = PROGN_REST(((4) << 2) | 0xF8000001u);
1632 get_car_and_cdr(exps, &ctx->curr_exp, &sptr[2]);
1633 if (lbm_is_symbol(sptr[2])) /* The only symbol it can be is nil */
1634 lbm_stack_drop(&ctx->K, 4);
1635 } else if (lbm_is_symbol_nil(exps)) {
1636 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1637 ctx->app_cont = true1;
1638 } else {
1639 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1640 }
1641}
1642
1643static void eval_atomic(eval_context_t *ctx) {
1644 if (is_atomic) {
1645 lbm_set_error_reason("Atomic blocks cannot be nested!");
1646 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1647 }
1648 stack_reserve(ctx, 1)[0] = EXIT_ATOMIC(((14) << 2) | 0xF8000001u);
1649 is_atomic ++;
1650 eval_progn(ctx);
1651}
1652
1653/* (call-cc (lambda (k) .... )) */
1654static void eval_callcc(eval_context_t *ctx) {
1655 lbm_value cont_array;
1656 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1657 gc();
1658 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1659 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1660 return; // dead return but static analysis doesn't know :)
1661 }
1662 }
1663 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(cont_array);
1664 memcpy(arr->data, ctx->K.data, ctx->K.sp * sizeof(lbm_uint));
1665
1666 lbm_value acont = cons_with_gc(ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u), cont_array, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1667 lbm_value arg_list = cons_with_gc(acont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1668 // Go directly into application evaluation without passing go
1669 lbm_uint *sptr = stack_reserve(ctx, 3);
1670 sptr[0] = ctx->curr_env;
1671 sptr[1] = arg_list;
1672 sptr[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
1673 ctx->curr_exp = get_cadr(ctx->curr_exp);
1674}
1675
1676// (define sym exp)
1677#define KEY1 1
1678#define VAL2 2
1679static void eval_define(eval_context_t *ctx) {
1680 lbm_value parts[3];
1681 lbm_value rest = extract_n(ctx->curr_exp, parts, 3);
1682 lbm_uint *sptr = stack_reserve(ctx, 2);
1683 if (lbm_is_symbol(parts[KEY1]) && lbm_is_symbol_nil(rest)) {
1684 lbm_uint sym_val = lbm_dec_sym(parts[KEY1]);
1685 sptr[0] = parts[KEY1];
1686 if (sym_val >= RUNTIME_SYMBOLS_START0x40000) {
1687 sptr[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
1688 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02) {
1689 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
1690 }
1691 ctx->curr_exp = parts[VAL2];
1692 return;
1693 }
1694 }
1695 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
1696}
1697
1698
1699/* Eval lambda is cheating, a lot! It does this
1700 for performance reasons. The cheats are that
1701 1. When closure is created, a reference to the local env
1702 in which the lambda was evaluated is added to the closure.
1703 Ideally it should have created a list of free variables in the function
1704 and then looked up the values of these creating a new environment.
1705 2. The global env is considered global constant. As there is no copying
1706 of environment bindings into the closure, undefine may break closures.
1707
1708 Correct closure creation is a lot more expensive than what happens here.
1709 However, one can try to write programs in such a way that closures are created
1710 seldomly. If one does that the space-usage benefits of "correct" closures
1711 may outweigh the performance gain of "incorrect" ones.
1712
1713 some obscure programs such as test_setq_local_closure.lisp does not
1714 work properly due to this cheating.
1715 */
1716// (lambda param-list body-exp) -> (closure param-list body-exp env)
1717static void eval_lambda(eval_context_t *ctx) {
1718 lbm_value vals[3];
1719 extract_n(ctx->curr_exp, vals, 3);
1720 ctx->r = allocate_closure(vals[1],vals[2], ctx->curr_env);
1721#ifdef CLEAN_UP_CLOSURES
1722 lbm_uint sym_id = 0;
1723 if (clean_cl_env_symbol) {
1724 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1725 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1726 ctx->curr_exp = app;
1727 } else if (lbm_get_symbol_by_name("clean-cl-env", &sym_id)) {
1728 clean_cl_env_symbol = lbm_enc_sym(sym_id);
1729 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1730 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1731 ctx->curr_exp = app;
1732 } else {
1733 ctx->app_cont = true1;
1734 }
1735#else
1736 ctx->app_cont = true1;
1737#endif
1738}
1739
1740// (if cond-expr then-expr else-expr)
1741static void eval_if(eval_context_t *ctx) {
1742 lbm_value cdr = get_cdr(ctx->curr_exp);
1743 lbm_value *sptr = stack_reserve(ctx, 3);
1744 sptr[0] = get_cdr(cdr);
1745 sptr[1] = ctx->curr_env;
1746 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1747 ctx->curr_exp = get_car(cdr);
1748}
1749
1750// (cond (cond-expr-1 expr-1)
1751// ...
1752// (cond-expr-N expr-N))
1753static void eval_cond(eval_context_t *ctx) {
1754 lbm_value cond1[2];
1755 lbm_value rest_conds = extract_n(ctx->curr_exp, cond1, 2);
1756
1757 // end recursion at (cond )
1758 if (lbm_is_symbol_nil(cond1[1])) {
1759 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1760 ctx->app_cont = true1;
1761 } else {
1762 // Cond is one of the few places where a bit of syntax checking takes place at runtime..
1763 // Maybe dont bother?
1764 lbm_uint len = lbm_list_length(cond1[1]);
1765 if (len != 2) {
1766 lbm_set_error_reason("Incorrect syntax in cond");
1767 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1768 }
1769 lbm_value cond_expr[2];
1770 extract_n(cond1[1], cond_expr, 2);
1771 lbm_value rest;
1772 WITH_GC(rest, lbm_heap_allocate_list_init(2,(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1773 cond_expr[1], // Then branch(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1774 cons_with_gc(ENC_SYM_COND, rest_conds , ENC_SYM_NIL)))(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
1775 lbm_value *sptr = stack_reserve(ctx, 3);
1776 sptr[0] = rest;
1777 sptr[1] = ctx->curr_env;
1778 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1779 ctx->curr_exp = cond_expr[0]; //condition;
1780 }
1781}
1782
1783static void eval_app_cont(eval_context_t *ctx) {
1784 lbm_stack_drop(&ctx->K, 1);
1785 ctx->app_cont = true1;
1786}
1787
1788// Create a named location in an environment to later receive a value.
1789static binding_location_status create_binding_location_internal(lbm_value key, lbm_value *env) {
1790
1791 if (lbm_is_symbol(key) &&
1792 (key == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u) ||
1793 key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)))
1794 return BL_OK;
1795
1796 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) { // default case
1797 lbm_value binding;
1798 lbm_value new_env_tmp;
1799 binding = lbm_cons(key, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1800 new_env_tmp = lbm_cons(binding, *env);
1801 if (lbm_is_symbol(binding) || lbm_is_symbol(new_env_tmp)) {
1802 return BL_NO_MEMORY;
1803 }
1804 *env = new_env_tmp;
1805 } else if (lbm_is_cons(key)) { // deconstruct case
1806 int r = create_binding_location_internal(get_car(key), env);
1807 if (r == BL_OK) {
1808 r = create_binding_location_internal(get_cdr(key), env);
1809 }
1810 return r;
1811 }
1812 return BL_OK;
1813}
1814
1815static void create_binding_location(lbm_value key, lbm_value *env) {
1816
1817 lbm_value env_tmp = *env;
1818 binding_location_status r = create_binding_location_internal(key, &env_tmp);
1819 if (r != BL_OK) {
1820 if (r == BL_NO_MEMORY) {
1821 env_tmp = *env;
1822 lbm_gc_mark_phase(env_tmp);
1823 gc();
1824 r = create_binding_location_internal(key, &env_tmp);
1825 }
1826 switch(r) {
1827 case BL_OK:
1828 break;
1829 case BL_NO_MEMORY:
1830 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1831 break;
1832 case BL_INCORRECT_KEY:
1833 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
1834 break;
1835 }
1836 }
1837 *env = env_tmp;
1838}
1839
1840static void let_bind_values_eval(lbm_value binds, lbm_value exp, lbm_value env, eval_context_t *ctx) {
1841
1842 if (!lbm_is_cons(binds)) {
1843 // binds better be nil or there is a programmer error.
1844 ctx->curr_exp = exp;
1845 return;
1846 }
1847
1848 // Preallocate binding locations.
1849 lbm_value curr = binds;
1850 while (lbm_is_cons(curr)) {
1851 lbm_value new_env_tmp = env;
1852 lbm_value car_curr, cdr_curr;
1853 get_car_and_cdr(curr, &car_curr, &cdr_curr);
1854 lbm_value key = get_car(car_curr);
1855 create_binding_location(key, &new_env_tmp);
1856 env = new_env_tmp;
1857 curr = cdr_curr;
1858 }
1859
1860 lbm_value car_binds;
1861 lbm_value cdr_binds;
1862 get_car_and_cdr(binds, &car_binds, &cdr_binds);
1863 lbm_value key_val[2];
1864 extract_n(car_binds, key_val, 2);
1865
1866 lbm_uint *sptr = stack_reserve(ctx, 5);
1867 sptr[0] = exp;
1868 sptr[1] = cdr_binds;
1869 sptr[2] = env;
1870 sptr[3] = key_val[0];
1871 sptr[4] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
1872 ctx->curr_exp = key_val[1];
1873 ctx->curr_env = env;
1874}
1875
1876// (var x (...)) - local binding inside of an progn
1877// var has to take, place root-level nesting within progn.
1878// (progn ... (var a 10) ...) OK!
1879// (progn ... (something (var a 10)) ... ) NOT OK!
1880/* progn stack
1881 sp-4 : env
1882 sp-3 : 0
1883 sp-2 : rest
1884 sp-1 : PROGN_REST
1885*/
1886static void eval_var(eval_context_t *ctx) {
1887
1888 if (ctx->K.sp >= 4) { // Possibly in progn
1889 lbm_value sv = ctx->K.data[ctx->K.sp - 1];
1890 if (IS_CONTINUATION(sv)(((sv) & 0xF8000001u) == 0xF8000001u) && (sv == PROGN_REST(((4) << 2) | 0xF8000001u))) {
1891 lbm_uint sp = ctx->K.sp;
1892 uint32_t is_copied = lbm_dec_as_u32(ctx->K.data[sp-3]);
1893 if (is_copied == 0) {
1894 lbm_value env;
1895 WITH_GC(env, lbm_env_copy_spine(ctx->K.data[sp-4]))(env) = (lbm_env_copy_spine(ctx->K.data[sp-4])); if (lbm_is_symbol_merror
((env))) { gc(); (env) = (lbm_env_copy_spine(ctx->K.data[sp
-4])); if (lbm_is_symbol_merror((env))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1896 ctx->K.data[sp-3] = lbm_enc_u(1);
1897 ctx->K.data[sp-4] = env;
1898 }
1899 lbm_value new_env = ctx->K.data[sp-4];
1900 lbm_value args = get_cdr(ctx->curr_exp);
1901 lbm_value key = get_car(args);
1902 create_binding_location(key, &new_env);
1903 ctx->K.data[sp-4] = new_env;
1904
1905 lbm_value v_exp = get_cadr(args);
1906 lbm_value *sptr = stack_reserve(ctx, 3);
1907 sptr[0] = new_env;
1908 sptr[1] = key;
1909 sptr[2] = PROGN_VAR(((29) << 2) | 0xF8000001u);
1910 // Activating the new environment before the evaluation of the value to be bound,
1911 // means that other variables with same name will be shadowed already in the value
1912 // body.
1913 // The way closures work, the var-variable needs to be in scope during val evaluation
1914 // for a recursive closure to be possible.
1915 ctx->curr_env = new_env;
1916 ctx->curr_exp = v_exp;
1917 return;
1918 }
1919 }
1920 lbm_set_error_reason((char*)lbm_error_str_var_outside_progn);
1921 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1922}
1923
1924// (setq x (...)) - same as (set 'x (...)) or (setvar 'x (...))
1925static void eval_setq(eval_context_t *ctx) {
1926 lbm_value parts[3];
1927 extract_n(ctx->curr_exp, parts, 3);
1928 lbm_value *sptr = stack_reserve(ctx, 3);
1929 sptr[0] = ctx->curr_env;
1930 sptr[1] = parts[1];
1931 sptr[2] = SETQ(((30) << 2) | 0xF8000001u);
1932 ctx->curr_exp = parts[2];
1933}
1934
1935static void eval_move_to_flash(eval_context_t *ctx) {
1936 lbm_value args = get_cdr(ctx->curr_exp);
1937 lbm_value *sptr = stack_reserve(ctx,2);
1938 sptr[0] = args;
1939 sptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
1940 ctx->app_cont = true1;
1941}
1942
1943// (loop list-of-local-bindings
1944// condition-exp
1945// body-exp)
1946static void eval_loop(eval_context_t *ctx) {
1947 lbm_value env = ctx->curr_env;
1948 lbm_value parts[3];
1949 extract_n(get_cdr(ctx->curr_exp), parts, 3);
1950 lbm_value *sptr = stack_reserve(ctx, 3);
1951 sptr[0] = parts[LOOP_BODY2];
1952 sptr[1] = parts[LOOP_COND1];
1953 sptr[2] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
1954 let_bind_values_eval(parts[LOOP_BINDS0], parts[LOOP_COND1], env, ctx);
1955}
1956
1957/* (trap expression)
1958 *
1959 * suggested use:
1960 * (match (trap expression)
1961 * ((exit-error (? err)) (error-handler err))
1962 * ((exit-ok (? v)) (value-handler v)))
1963 */
1964static void eval_trap(eval_context_t *ctx) {
1965
1966 lbm_value expr = get_cadr(ctx->curr_exp);
1967 lbm_value retval;
1968 WITH_GC(retval, lbm_heap_allocate_list(2))(retval) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((retval))) { gc(); (retval) = (lbm_heap_allocate_list(2)); if
(lbm_is_symbol_merror((retval))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1969 lbm_set_car(retval, ENC_SYM_EXIT_OK(((0x3000B) << 4) | 0x00000000u)); // Assume things will go well.
1970 lbm_uint *sptr = stack_reserve(ctx,3);
1971 sptr[0] = retval;
1972 sptr[1] = ctx->flags;
1973 sptr[2] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1974 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10;
1975 ctx->curr_exp = expr;
1976}
1977
1978// (let list-of-binding s
1979// body-exp)
1980static void eval_let(eval_context_t *ctx) {
1981 lbm_value env = ctx->curr_env;
1982 lbm_value parts[3];
1983 extract_n(ctx->curr_exp, parts, 3);
1984 let_bind_values_eval(parts[1], parts[2], env, ctx);
1985}
1986
1987// (and exp0 ... expN)
1988static void eval_and(eval_context_t *ctx) {
1989 lbm_value rest = get_cdr(ctx->curr_exp);
1990 if (lbm_is_symbol_nil(rest)) {
1991 ctx->app_cont = true1;
1992 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1993 } else {
1994 lbm_value *sptr = stack_reserve(ctx, 3);
1995 sptr[0] = ctx->curr_env;
1996 sptr[1] = get_cdr(rest);
1997 sptr[2] = AND(((6) << 2) | 0xF8000001u);
1998 ctx->curr_exp = get_car(rest);
1999 }
2000}
2001
2002// (or exp0 ... expN)
2003static void eval_or(eval_context_t *ctx) {
2004 lbm_value rest = get_cdr(ctx->curr_exp);
2005 if (lbm_is_symbol_nil(rest)) {
2006 ctx->app_cont = true1;
2007 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2008 } else {
2009 lbm_value *sptr = stack_reserve(ctx, 3);
2010 sptr[0] = ctx->curr_env;
2011 sptr[1] = get_cdr(rest);
2012 sptr[2] = OR(((7) << 2) | 0xF8000001u);
2013 ctx->curr_exp = get_car(rest);
2014 }
2015}
2016
2017// Pattern matching
2018// format:
2019// (match e (pattern body)
2020// (pattern body)
2021// ... )
2022//
2023// There can be an optional pattern guard:
2024// (match e (pattern guard body)
2025// ... )
2026// a guard is a boolean expression.
2027// Guards make match, pattern matching more complicated
2028// than the recv pattern matching and requires staged execution
2029// via the continuation system rather than a while loop over a list.
2030static void eval_match(eval_context_t *ctx) {
2031
2032 lbm_value rest = get_cdr(ctx->curr_exp);
2033 if (lbm_type_of(rest) == LBM_TYPE_SYMBOL0x00000000u &&
2034 rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
2035 // Someone wrote the program (match)
2036 ctx->app_cont = true1;
2037 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2038 } else {
2039 lbm_value cdr_rest;
2040 get_car_and_cdr(rest, &ctx->curr_exp, &cdr_rest);
2041 lbm_value *sptr = stack_reserve(ctx, 3);
2042 sptr[0] = cdr_rest;
2043 sptr[1] = ctx->curr_env;
2044 sptr[2] = MATCH(((9) << 2) | 0xF8000001u);
2045 }
2046}
2047
2048static void receive_base(eval_context_t *ctx, lbm_value pats, float timeout_time, bool_Bool timeout) {
2049 if (ctx->num_mail == 0) {
2050 if (timeout) {
2051 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000), false0);
2052 } else {
2053 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1,0,false0);
2054 }
2055 } else {
2056 lbm_value *msgs = ctx->mailbox;
2057 lbm_uint num = ctx->num_mail;
2058
2059 if (lbm_is_symbol_nil(pats)) {
2060 /* A receive statement without any patterns */
2061 ctx->app_cont = true1;
2062 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2063 } else {
2064 /* The common case */
2065 lbm_value e;
2066 lbm_value new_env = ctx->curr_env;
2067 int n = find_match(pats, msgs, num, &e, &new_env);
2068 if (n == FM_NEED_GC-1) {
2069 gc();
2070 new_env = ctx->curr_env;
2071 n = find_match(pats, msgs, num, &e, &new_env);
2072 if (n == FM_NEED_GC-1) {
2073 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2074 }
2075 }
2076 if (n == FM_PATTERN_ERROR-3) {
2077 lbm_set_error_reason("Incorrect pattern format for recv");
2078 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),pats);
2079 } else if (n >= 0 ) { /* Match */
2080 mailbox_remove_mail(ctx, (lbm_uint)n);
2081 ctx->curr_env = new_env;
2082 ctx->curr_exp = e;
2083 } else { /* No match go back to sleep */
2084 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
2085 if (timeout) {
2086 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2,S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000),false0);
2087 } else {
2088 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,false0);
2089 }
2090 }
2091 }
2092 }
2093 return;
2094}
2095
2096static void eval_receive_timeout(eval_context_t *ctx) {
2097 if (is_atomic) {
2098 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2099 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2100 }
2101 lbm_value timeout_val = get_cadr(ctx->curr_exp);
2102 if (!lbm_is_number(timeout_val)) {
2103 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2104 }
2105 float timeout_time = lbm_dec_as_float(timeout_val);
2106 lbm_value pats = get_cdr(get_cdr(ctx->curr_exp));
2107 receive_base(ctx, pats, timeout_time, true1);
2108}
2109
2110// Receive
2111// (recv (pattern expr)
2112// (pattern expr))
2113static void eval_receive(eval_context_t *ctx) {
2114
2115 if (is_atomic) {
2116 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2117 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
2118 }
2119 lbm_value pats = get_cdr(ctx->curr_exp);
2120 receive_base(ctx, pats, 0, false0);
2121}
2122
2123/*********************************************************/
2124/* Continuation functions */
2125
2126/* cont_set_global_env
2127 sp-1 : Key-symbol
2128 */
2129static void cont_set_global_env(eval_context_t *ctx){
2130
2131 lbm_value key;
2132 lbm_value val = ctx->r;
2133
2134 lbm_pop(&ctx->K, &key);
2135 lbm_uint dec_key = lbm_dec_sym(key);
2136 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
2137 lbm_value *global_env = lbm_get_global_env();
2138 lbm_uint orig_env = global_env[ix_key];
2139 lbm_value new_env;
2140 // A key is a symbol and should not need to be remembered.
2141 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2142
2143 global_env[ix_key] = new_env;
2144 ctx->r = val;
2145
2146 ctx->app_cont = true1;
2147
2148 return;
2149}
2150
2151static void cont_resume(eval_context_t *ctx) {
2152 lbm_pop_2(&ctx->K, &ctx->curr_env, &ctx->curr_exp);
2153}
2154
2155static void cont_progn_rest(eval_context_t *ctx) {
2156 lbm_value *sptr = get_stack_ptr(ctx, 3);
2157
2158 lbm_value rest = sptr[2];
2159 lbm_value env = sptr[0];
2160
2161 lbm_value rest_car, rest_cdr;
2162 get_car_and_cdr(rest, &rest_car, &rest_cdr);
2163 ctx->curr_exp = rest_car;
2164 ctx->curr_env = env;
2165 if (lbm_is_symbol_nil(rest_cdr)) {
2166 // allow for tail recursion
2167 lbm_stack_drop(&ctx->K, 3);
2168 } else {
2169 sptr[2] = rest_cdr;
2170 stack_reserve(ctx, 1)[0] = PROGN_REST(((4) << 2) | 0xF8000001u);
2171 }
2172}
2173
2174static void cont_wait(eval_context_t *ctx) {
2175
2176 lbm_value cid_val;
2177 lbm_pop(&ctx->K, &cid_val);
2178 lbm_cid cid = (lbm_cid)lbm_dec_i(cid_val);
2179
2180 bool_Bool exists = false0;
2181
2182 lbm_blocked_iterator(context_exists, &cid, &exists);
2183 lbm_running_iterator(context_exists, &cid, &exists);
2184
2185 if (ctx_running->id == cid) {
2186 exists = true1;
2187 }
2188
2189 if (exists) {
2190 lbm_value *sptr = stack_reserve(ctx, 2);
2191 sptr[0] = lbm_enc_i(cid);
2192 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2193 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2194 ctx->app_cont = true1;
2195 yield_ctx(50000);
2196 } else {
2197 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2198 ctx->app_cont = true1;
2199 }
2200}
2201
2202static lbm_value perform_setvar(lbm_value key, lbm_value val, lbm_value env) {
2203
2204 lbm_uint s = lbm_dec_sym(key);
2205 if (s >= RUNTIME_SYMBOLS_START0x40000) {
2206 lbm_value new_env = lbm_env_modify_binding(env, key, val);
2207 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2208 lbm_uint ix_key = lbm_dec_sym(key) & GLOBAL_ENV_MASK0x1F;
2209 lbm_value *glob_env = lbm_get_global_env();
2210 new_env = lbm_env_modify_binding(glob_env[ix_key], key, val);
2211 glob_env[ix_key] = new_env;
2212 }
2213 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2214 lbm_set_error_reason((char*)lbm_error_str_variable_not_bound);
2215 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), key);
2216 }
2217 return val;
2218 }
2219 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2220 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // unreachable
2221}
2222
2223static void apply_setvar(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2224 if (nargs == 2 && lbm_is_symbol(args[0])) {
2225 lbm_value res;
2226 WITH_GC(res, perform_setvar(args[0], args[1], ctx->curr_env))(res) = (perform_setvar(args[0], args[1], ctx->curr_env));
if (lbm_is_symbol_merror((res))) { gc(); (res) = (perform_setvar
(args[0], args[1], ctx->curr_env)); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2227 ctx->r = args[1];
2228 lbm_stack_drop(&ctx->K, nargs+1);
2229 ctx->app_cont = true1;
2230 } else {
2231 if (nargs == 2) lbm_set_error_reason((char*)lbm_error_str_incorrect_arg);
2232 else lbm_set_error_reason((char*)lbm_error_str_num_args);
2233 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2234 }
2235}
2236
2237static void apply_read_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, bool_Bool program, bool_Bool incremental) {
2238 if (nargs == 1) {
2239 lbm_value chan = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2240 if (lbm_type_of_functional(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2241 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2242 gc();
2243 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2244 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2245 }
2246 }
2247 } else if (lbm_type_of(args[0]) == LBM_TYPE_CHANNEL0x90000000u) {
2248 chan = args[0];
2249 } else {
2250 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2251 }
2252 lbm_value *sptr = get_stack_ptr(ctx, 2);
2253
2254 // If we are inside a reader, its settings are stored.
2255 sptr[0] = lbm_enc_u(ctx->flags); // flags stored.
2256 sptr[1] = chan;
2257 lbm_value *rptr = stack_reserve(ctx,1);
2258 rptr[0] = READ_DONE(((20) << 2) | 0xF8000001u);
2259
2260 // Each reader starts in a fresh situation
2261 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
2262
2263 if (program) {
2264 if (incremental) {
2265 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2266 lbm_value *rptr1 = stack_reserve(ctx,3);
2267 rptr1[0] = chan;
2268 rptr1[1] = ctx->curr_env;
2269 rptr1[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
2270 } else {
2271 ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2272 lbm_value *rptr1 = stack_reserve(ctx,4);
2273 rptr1[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2274 rptr1[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2275 rptr1[2] = chan;
2276 rptr1[3] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
2277 }
2278 }
2279 rptr = stack_reserve(ctx,3); // reuse of variable rptr
2280 rptr[0] = chan;
2281 rptr[1] = lbm_enc_u(1);
2282 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
2283 ctx->app_cont = true1;
2284 } else {
2285 lbm_set_error_reason((char*)lbm_error_str_num_args);
2286 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2287 }
2288}
2289
2290static void apply_read_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2291 apply_read_base(args,nargs,ctx,true1,false0);
2292}
2293
2294static void apply_read_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2295 apply_read_base(args,nargs,ctx,true1,true1);
2296}
2297
2298static void apply_read(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2299 apply_read_base(args,nargs,ctx,false0,false0);
2300}
2301
2302static void apply_spawn_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, uint32_t context_flags) {
2303
2304 lbm_uint stack_size = EVAL_CPS_DEFAULT_STACK_SIZE256;
2305 lbm_uint closure_pos = 0;
2306 char *name = NULL((void*)0);
2307
2308 if (nargs >= 1 &&
2309 lbm_is_closure(args[0])) {
2310 closure_pos = 0;
2311 } else if (nargs >= 2 &&
2312 lbm_is_number(args[0]) &&
2313 lbm_is_closure(args[1])) {
2314 stack_size = lbm_dec_as_u32(args[0]);
2315 closure_pos = 1;
2316 } else if (nargs >= 2 &&
2317 lbm_is_array_r(args[0]) &&
2318 lbm_is_closure(args[1])) {
2319 name = lbm_dec_str(args[0]);
2320 closure_pos = 1;
2321 }else if (nargs >= 3 &&
2322 lbm_is_array_r(args[0]) &&
2323 lbm_is_number(args[1]) &&
2324 lbm_is_closure(args[2])) {
2325 stack_size = lbm_dec_as_u32(args[1]);
2326 closure_pos = 2;
2327 name = lbm_dec_str(args[0]);
2328 } else {
2329 if (context_flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01)
2330 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN_TRAP(((0x30005) << 4) | 0x00000000u));
2331 else
2332 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN(((0x30004) << 4) | 0x00000000u));
2333 }
2334
2335 lbm_value cl[3];
2336 extract_n(get_cdr(args[closure_pos]), cl, 3);
2337 lbm_value curr_param = cl[CLO_PARAMS0];
2338 lbm_value clo_env = cl[CLO_ENV2];
2339 lbm_uint i = closure_pos + 1;
2340 while (lbm_is_cons(curr_param) && i <= nargs) {
2341 lbm_value entry = cons_with_gc(get_car(curr_param), args[i], clo_env);
2342 lbm_value aug_env = cons_with_gc(entry, clo_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2343 clo_env = aug_env;
2344 curr_param = get_cdr(curr_param);
2345 i ++;
2346 }
2347
2348 lbm_stack_drop(&ctx->K, nargs+1);
2349
2350 lbm_value program = cons_with_gc(cl[CLO_BODY1], ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), clo_env);
2351
2352 lbm_cid cid = lbm_create_ctx_parent(program,
2353 clo_env,
2354 stack_size,
2355 lbm_get_current_cid(),
2356 context_flags,
2357 name);
2358 ctx->r = lbm_enc_i(cid);
2359 ctx->app_cont = true1;
2360}
2361
2362static void apply_spawn(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2363 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00);
2364}
2365
2366static void apply_spawn_trap(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2367 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01);
2368}
2369
2370static void apply_yield(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2371 if (is_atomic) {
2372 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2373 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2374 }
2375 if (nargs == 1 && lbm_is_number(args[0])) {
2376 lbm_uint ts = lbm_dec_as_u32(args[0]);
2377 lbm_stack_drop(&ctx->K, nargs+1);
2378 yield_ctx(ts);
2379 } else {
2380 lbm_set_error_reason((char*)lbm_error_str_no_number);
2381 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2382 }
2383}
2384
2385static void apply_sleep(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2386 if (is_atomic) {
2387 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2388 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2389 }
2390 if (nargs == 1 && lbm_is_number(args[0])) {
2391 lbm_uint ts = (lbm_uint)(1000000.0f * lbm_dec_as_float(args[0]));
2392 lbm_stack_drop(&ctx->K, nargs+1);
2393 yield_ctx(ts);
2394 } else {
2395 lbm_set_error_reason((char*)lbm_error_str_no_number);
2396 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2397 }
2398}
2399
2400static void apply_wait(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2401 if (nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2402 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2403 lbm_value *sptr = get_stack_ptr(ctx, 2);
2404 sptr[0] = lbm_enc_i(cid);
2405 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2406 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2407 ctx->app_cont = true1;
2408 yield_ctx(50000);
2409 } else {
2410 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_WAIT(((0x30007) << 4) | 0x00000000u));
2411 }
2412}
2413
2414/* (eval expr)
2415 (eval env expr) */
2416static void apply_eval(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2417 if ( nargs == 1) {
2418 ctx->curr_exp = args[0];
2419 } else if (nargs == 2) {
2420 ctx->curr_exp = args[1];
2421 ctx->curr_env = args[0];
2422 } else {
2423 lbm_set_error_reason((char*)lbm_error_str_num_args);
2424 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL(((0x30008) << 4) | 0x00000000u));
2425 }
2426 lbm_stack_drop(&ctx->K, nargs+1);
2427}
2428
2429static void apply_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2430 int prg_pos = 0;
2431 if (nargs == 2) {
2432 prg_pos = 1;
2433 ctx->curr_env = args[0];
2434 }
2435 if (nargs == 1 || nargs == 2) {
2436 lbm_value prg = args[prg_pos];
2437 lbm_value app_cont;
2438 lbm_value app_cont_prg;
2439 lbm_value new_prg;
2440 lbm_value prg_copy;
2441
2442 int len = -1;
2443 WITH_GC(prg_copy, lbm_list_copy(&len, prg))(prg_copy) = (lbm_list_copy(&len, prg)); if (lbm_is_symbol_merror
((prg_copy))) { gc(); (prg_copy) = (lbm_list_copy(&len, prg
)); if (lbm_is_symbol_merror((prg_copy))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2444 lbm_stack_drop(&ctx->K, nargs+1);
2445
2446 if (ctx->K.sp > nargs+2) { // if there is a continuation
2447 app_cont = cons_with_gc(ENC_SYM_APP_CONT(((0x111) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2448 app_cont_prg = cons_with_gc(app_cont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2449 new_prg = lbm_list_append(app_cont_prg, ctx->program);
2450 new_prg = lbm_list_append(prg_copy, new_prg);
2451 } else {
2452 new_prg = lbm_list_append(prg_copy, ctx->program);
2453 }
2454 if (!lbm_is_list(new_prg)) {
2455 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2456 }
2457 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);
2458 ctx->program = get_cdr(new_prg);
2459 ctx->curr_exp = get_car(new_prg);
2460 } else {
2461 lbm_set_error_reason((char*)lbm_error_str_num_args);
2462 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2463 }
2464}
2465
2466static void apply_send(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2467 if (nargs == 2) {
2468 if (lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2469 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2470 lbm_value msg = args[1];
2471 lbm_value status = lbm_find_receiver_and_send(cid, msg);
2472 /* return the status */
2473 lbm_stack_drop(&ctx->K, nargs+1);
2474 ctx->r = status;
2475 ctx->app_cont = true1;
2476 } else {
2477 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2478 }
2479 } else {
2480 lbm_set_error_reason((char*)lbm_error_str_num_args);
2481 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2482 }
2483}
2484
2485static void apply_ok(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2486 lbm_value ok_val = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2487 if (nargs >= 1) {
2488 ok_val = args[0];
2489 }
2490 ctx->r = ok_val;
2491 ok_ctx();
2492}
2493
2494static void apply_error(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2495 (void) ctx;
2496 lbm_value err_val = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
2497 if (nargs >= 1) {
2498 err_val = args[0];
2499 }
2500 error_at_ctx(err_val, ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
2501}
2502
2503// (map f arg-list)
2504static void apply_map(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2505 if (nargs == 2 && lbm_is_cons(args[1])) {
2506 lbm_value *sptr = get_stack_ptr(ctx, 3);
2507
2508 lbm_value f = args[0];
2509 lbm_value h = get_car(args[1]);
2510 lbm_value t = get_cdr(args[1]);
2511
2512 lbm_value appli_1;
2513 lbm_value appli;
2514 WITH_GC(appli_1, lbm_heap_allocate_list(2))(appli_1) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli_1))) { gc(); (appli_1) = (lbm_heap_allocate_list(2));
if (lbm_is_symbol_merror((appli_1))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2515 WITH_GC_RMBR_1(appli, lbm_heap_allocate_list(2), appli_1)(appli) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli))) { lbm_gc_mark_phase(appli_1); gc(); (appli) = (lbm_heap_allocate_list
(2)); if (lbm_is_symbol_merror((appli))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2516
2517 lbm_value appli_0 = get_cdr(appli_1);
2518
2519 lbm_set_car_and_cdr(appli_0, h, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2520 lbm_set_car(appli_1, ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u));
2521
2522 lbm_set_car_and_cdr(get_cdr(appli), appli_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2523 lbm_set_car(appli, f);
2524
2525 lbm_value elt = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), appli);
2526 sptr[0] = t; // reuse stack space
2527 sptr[1] = ctx->curr_env;
2528 sptr[2] = elt;
2529 lbm_value *rptr = stack_reserve(ctx,4);
2530 rptr[0] = elt;
2531 rptr[1] = appli;
2532 rptr[2] = appli_0;
2533 rptr[3] = MAP(((26) << 2) | 0xF8000001u);
2534 ctx->curr_exp = appli;
2535 } else if (nargs == 2 && lbm_is_symbol_nil(args[1])) {
2536 lbm_stack_drop(&ctx->K, 3);
2537 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2538 ctx->app_cont = true1;
2539 return;
2540 } else {
2541 lbm_set_error_reason((char*)lbm_error_str_num_args);
2542 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_MAP(((0x3000D) << 4) | 0x00000000u));
2543 }
2544}
2545
2546static void apply_reverse(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2547 if (nargs == 1 && lbm_is_list(args[0])) {
2548 lbm_value curr = args[0];
2549
2550 lbm_value new_list = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2551 while (lbm_is_cons(curr)) {
2552 lbm_value tmp = cons_with_gc(get_car(curr), new_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2553 new_list = tmp;
2554 curr = get_cdr(curr);
2555 }
2556 lbm_stack_drop(&ctx->K, 2);
2557 ctx->r = new_list;
2558 ctx->app_cont = true1;
2559 } else {
2560 lbm_set_error_reason("Reverse requires a list argument");
2561 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_REVERSE(((0x3000E) << 4) | 0x00000000u));
2562 }
2563}
2564
2565static void apply_flatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2566 if (nargs == 1) {
2567
2568 lbm_value v = flatten_value(args[0]);
2569 if ( v == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)) {
2570 gc();
2571 v = flatten_value(args[0]);
2572 }
2573
2574 if (lbm_is_symbol(v)) {
2575 error_at_ctx(v, ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2576 } else {
2577 lbm_stack_drop(&ctx->K, 2);
2578 ctx->r = v;
2579 ctx->app_cont = true1;
2580 }
2581 return;
2582 }
2583 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2584}
2585
2586static void apply_unflatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2587 if(nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2588 lbm_array_header_t *array;
2589 array = (lbm_array_header_t *)get_car(args[0]);
2590
2591 lbm_flat_value_t fv;
2592 fv.buf = (uint8_t*)array->data;
2593 fv.buf_size = array->size;
2594 fv.buf_pos = 0;
2595
2596 lbm_value res;
2597
2598 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2599 if (lbm_unflatten_value(&fv, &res)) {
2600 ctx->r = res;
2601 }
2602 lbm_stack_drop(&ctx->K, 2);
2603 ctx->app_cont = true1;
2604 return;
2605 }
2606 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_UNFLATTEN(((0x30010) << 4) | 0x00000000u));
2607}
2608
2609static void apply_kill(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2610 if (nargs == 2 && lbm_is_number(args[0])) {
2611 lbm_cid cid = lbm_dec_as_i32(args[0]);
2612
2613 if (ctx->id == cid) {
2614 ctx->r = args[1];
2615 finish_ctx();
2616 return;
2617 }
2618 mutex_lock(&qmutex);
2619 eval_context_t *found = NULL((void*)0);
2620 found = lookup_ctx_nm(&blocked, cid);
2621 if (found)
2622 drop_ctx_nm(&blocked, found);
2623 else
2624 found = lookup_ctx_nm(&queue, cid);
2625 if (found)
2626 drop_ctx_nm(&queue, found);
2627
2628 if (found) {
2629 found->K.data[found->K.sp - 1] = KILL(((40) << 2) | 0xF8000001u);
2630 found->r = args[1];
2631 found->app_cont = true1;
2632 enqueue_ctx_nm(&queue,found);
2633 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2634 } else {
2635 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2636 }
2637 lbm_stack_drop(&ctx->K, 3);
2638 ctx->app_cont = true1;
2639 mutex_unlock(&qmutex);
2640 return;
2641 }
2642 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_KILL(((0x30011) << 4) | 0x00000000u));
2643}
2644
2645// (merge comparator list1 list2)
2646static void apply_merge(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2647 if (nargs == 3 && lbm_is_list(args[1]) && lbm_is_list(args[2])) {
2648
2649 if (!lbm_is_closure(args[0])) {
2650 lbm_value closure;
2651 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2652 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2653 lbm_value cl1 = lbm_cdr(closure);
2654 lbm_value par;
2655 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2656 lbm_set_car(cl1, par);
2657 lbm_value cl2 = lbm_cdr(cl1);
2658 lbm_value body;
2659 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2660 lbm_set_car(cl2, body);
2661 lbm_value cl3 = lbm_cdr(cl2);
2662 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2663
2664 // Replace operator on stack with closure and rest of the code is
2665 // compatible.
2666 args[0] = closure;
2667 }
2668
2669 // Copy input lists for functional behaviour at top-level
2670 // merge itself is in-place in the copied lists.
2671 lbm_value a;
2672 lbm_value b;
2673 int len_a = -1;
2674 int len_b = -1;
2675 WITH_GC(a, lbm_list_copy(&len_a, args[1]))(a) = (lbm_list_copy(&len_a, args[1])); if (lbm_is_symbol_merror
((a))) { gc(); (a) = (lbm_list_copy(&len_a, args[1])); if
(lbm_is_symbol_merror((a))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } };
2676 WITH_GC_RMBR_1(b, lbm_list_copy(&len_b, args[2]), a)(b) = (lbm_list_copy(&len_b, args[2])); if (lbm_is_symbol_merror
((b))) { lbm_gc_mark_phase(a); gc(); (b) = (lbm_list_copy(&
len_b, args[2])); if (lbm_is_symbol_merror((b))) { error_ctx(
(((0x23) << 4) | 0x00000000u)); } };
2677
2678 if (len_a == 0) {
2679 ctx->r = b;
2680 lbm_stack_drop(&ctx->K, 4);
2681 ctx->app_cont = true1;
2682 return;
2683 }
2684 if (len_b == 0) {
2685 ctx->r = a;
2686 lbm_stack_drop(&ctx->K, 4);
2687 ctx->app_cont = true1;
2688 return;
2689 }
2690
2691 args[1] = a; // keep safe by replacing the original on stack.
2692 args[2] = b;
2693
2694 lbm_value a_1 = a;
2695 lbm_value a_rest = lbm_cdr(a);
2696 lbm_value b_1 = b;
2697 lbm_value b_rest = lbm_cdr(b);
2698
2699 lbm_value cl[3]; // Comparator closure
2700 extract_n(lbm_cdr(args[0]), cl, 3);
2701 lbm_value cmp_env = cl[CLO_ENV2];
2702 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2703 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2704 lbm_uint len = lbm_list_length(cl[CLO_PARAMS0]);
2705 if (len == 2) {
2706 par1 = get_car(cl[CLO_PARAMS0]);
2707 par2 = get_cadr(cl[CLO_PARAMS0]);
2708 lbm_value new_env0;
2709 lbm_value new_env;
2710 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a_1)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a_1))); if (
lbm_is_symbol_merror((new_env0))) { gc(); (new_env0) = (lbm_env_set
(cmp_env, par1, lbm_car(a_1))); if (lbm_is_symbol_merror((new_env0
))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2711 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b_1)),new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1))); if (
lbm_is_symbol_merror((new_env))) { lbm_gc_mark_phase(new_env0
); gc(); (new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1
))); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2712 cmp_env = new_env;
2713 } else {
2714 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2715 }
2716 lbm_set_cdr(a_1, b_1);
2717 lbm_set_cdr(b_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2718 lbm_value cmp = cl[CLO_BODY1];
2719
2720 lbm_stack_drop(&ctx->K, 4); // TODO: Optimize drop 4 alloc 10 into alloc 6
2721 lbm_uint *sptr = stack_reserve(ctx, 10);
2722 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged list
2723 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged list
2724 sptr[2] = a_1;
2725 sptr[3] = a_rest;
2726 sptr[4] = b_rest;
2727 sptr[5] = cmp;
2728 sptr[6] = cmp_env;
2729 sptr[7] = par1;
2730 sptr[8] = par2;
2731 sptr[9] = MERGE_REST(((43) << 2) | 0xF8000001u);
2732 ctx->curr_exp = cl[CLO_BODY1];
2733 ctx->curr_env = cmp_env;
2734 return;
2735 }
2736 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MERGE(((0x30013) << 4) | 0x00000000u));
2737}
2738
2739// (sort comparator list)
2740static void apply_sort(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2741 if (nargs == 2 && lbm_is_list(args[1])) {
2742
2743 if (!lbm_is_closure(args[0])) {
2744 lbm_value closure;
2745 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2746 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2747 lbm_value cl1 = lbm_cdr(closure);
2748 lbm_value par;
2749 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2750 lbm_set_car(cl1, par);
2751 lbm_value cl2 = lbm_cdr(cl1);
2752 lbm_value body;
2753 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2754 lbm_set_car(cl2, body);
2755 lbm_value cl3 = lbm_cdr(cl2);
2756 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2757
2758 // Replace operator on stack with closure and rest of the code is
2759 // compatible.
2760 args[0] = closure;
2761 }
2762
2763 int len = -1;
2764 lbm_value list_copy;
2765 WITH_GC(list_copy, lbm_list_copy(&len, args[1]))(list_copy) = (lbm_list_copy(&len, args[1])); if (lbm_is_symbol_merror
((list_copy))) { gc(); (list_copy) = (lbm_list_copy(&len,
args[1])); if (lbm_is_symbol_merror((list_copy))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2766 if (len <= 1) {
2767 lbm_stack_drop(&ctx->K, 3);
2768 ctx->r = list_copy;
2769 ctx->app_cont = true1;
2770 return;
2771 }
2772
2773 args[1] = list_copy; // Keep safe, original replaced on stack.
2774
2775 // Take the headmost 2, 1-element sublists.
2776 lbm_value a = list_copy;
2777 lbm_value b = lbm_cdr(a);
2778 lbm_value rest = lbm_cdr(b);
2779 // Do not terminate b. keep rest of list safe from GC in the following
2780 // closure extraction.
2781 //lbm_set_cdr(a, b); // This is void
2782
2783 lbm_value cl[3]; // Comparator closure
2784 extract_n(lbm_cdr(args[0]), cl, 3);
2785 lbm_value cmp_env = cl[CLO_ENV2];
2786 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2787 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2788 lbm_uint cl_len = lbm_list_length(cl[CLO_PARAMS0]);
2789 if (cl_len == 2) {
2790 par1 = get_car(cl[CLO_PARAMS0]);
2791 par2 = get_cadr(cl[CLO_PARAMS0]);
2792 lbm_value new_env0;
2793 lbm_value new_env;
2794 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a))); if (lbm_is_symbol_merror
((new_env0))) { gc(); (new_env0) = (lbm_env_set(cmp_env, par1
, lbm_car(a))); if (lbm_is_symbol_merror((new_env0))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2795 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b)), new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { lbm_gc_mark_phase(new_env0); gc(); (new_env) =
(lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { error_ctx((((0x23) << 4) | 0x00000000u))
; } };
2796 cmp_env = new_env;
2797 } else {
2798 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2799 }
2800 lbm_value cmp = cl[CLO_BODY1];
2801
2802 // Terminate the comparator argument list.
2803 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2804
2805 lbm_stack_drop(&ctx->K, 3); //TODO: optimize drop 3, alloc 20 into alloc 17
2806 lbm_uint *sptr = stack_reserve(ctx, 20);
2807 sptr[0] = cmp;
2808 sptr[1] = cmp_env;
2809 sptr[2] = par1;
2810 sptr[3] = par2;
2811 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged accumulation of sublists
2812 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged accumulation of sublists
2813 sptr[6] = rest;
2814 sptr[7] = lbm_enc_i(1);
2815 sptr[8] = lbm_enc_i(len); //TODO: 28 bit i vs 32 bit i
2816 sptr[9] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
2817 sptr[10] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged sublist
2818 sptr[11] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged sublist
2819 sptr[12] = a;
2820 sptr[13] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no a_rest, 1 element lists in layer 1.
2821 sptr[14] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no b_rest, 1 element lists in layer 1.
2822 sptr[15] = cmp;
2823 sptr[16] = cmp_env;
2824 sptr[17] = par1;
2825 sptr[18] = par2;
2826 sptr[19] = MERGE_REST(((43) << 2) | 0xF8000001u);
2827 ctx->curr_exp = cmp;
2828 ctx->curr_env = cmp_env;
2829 return;
2830 }
2831 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
2832}
2833
2834static void apply_rest_args(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2835 lbm_value res;
2836 if (lbm_env_lookup_b(&res, ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ctx->curr_env)) {
2837 if (nargs == 1 && lbm_is_number(args[0])) {
2838 int32_t ix = lbm_dec_as_i32(args[0]);
2839 res = lbm_index_list(res, ix);
2840 }
2841 ctx->r = res;
2842 } else {
2843 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2844 }
2845 lbm_stack_drop(&ctx->K, nargs+1);
2846 ctx->app_cont = true1;
2847}
2848
2849/* (rotate list-expr dist/dir-expr) */
2850static void apply_rotate(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2851 if (nargs == 2 && lbm_is_list(args[0]) && lbm_is_number(args[1])) {
2852 int len = -1;
2853 lbm_value ls = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2854 WITH_GC(ls, lbm_list_copy(&len, args[0]))(ls) = (lbm_list_copy(&len, args[0])); if (lbm_is_symbol_merror
((ls))) { gc(); (ls) = (lbm_list_copy(&len, args[0])); if
(lbm_is_symbol_merror((ls))) { error_ctx((((0x23) << 4
) | 0x00000000u)); } };
2855 int dist = lbm_dec_as_i32(args[1]);
2856 if (len > 0 && dist != 0) {
2857 int d = dist;
2858 if (dist > 0) {
2859 ls = lbm_list_destructive_reverse(ls);
2860 } else {
2861 d = -dist;
2862 }
2863
2864 lbm_value start = ls;
2865 lbm_value end = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2866 lbm_value curr = start;
2867 while (lbm_is_cons(curr)) {
2868 end = curr;
2869 curr = get_cdr(curr);
2870 }
2871
2872 for (int i = 0; i < d; i ++) {
2873 lbm_value a = start;
2874 start = lbm_cdr(start);
2875 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2876 lbm_set_cdr(end, a);
2877 end = a;
2878 }
2879 ls = start;
2880 if (dist > 0) {
2881 ls = lbm_list_destructive_reverse(ls);
2882 }
2883 }
2884 lbm_stack_drop(&ctx->K, nargs+1);
2885 ctx->app_cont = true1;
2886 ctx->r = ls;
2887 return;
2888 }
2889 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2890}
2891
2892/***************************************************/
2893/* Application lookup table */
2894
2895typedef void (*apply_fun)(lbm_value *, lbm_uint, eval_context_t *);
2896static const apply_fun fun_table[] =
2897 {
2898 apply_setvar,
2899 apply_read,
2900 apply_read_program,
2901 apply_read_eval_program,
2902 apply_spawn,
2903 apply_spawn_trap,
2904 apply_yield,
2905 apply_wait,
2906 apply_eval,
2907 apply_eval_program,
2908 apply_send,
2909 apply_ok,
2910 apply_error,
2911 apply_map,
2912 apply_reverse,
2913 apply_flatten,
2914 apply_unflatten,
2915 apply_kill,
2916 apply_sleep,
2917 apply_merge,
2918 apply_sort,
2919 apply_rest_args,
2920 apply_rotate,
2921 };
2922
2923/***************************************************/
2924/* Application of function that takes arguments */
2925/* passed over the stack. */
2926
2927static void application(eval_context_t *ctx, lbm_value *fun_args, lbm_uint arg_count) {
2928 /* If arriving here, we know that the fun is a symbol.
2929 * and can be a built in operation or an extension.
2930 */
2931 lbm_value fun = fun_args[0];
2932
2933 lbm_uint fun_val = lbm_dec_sym(fun);
2934 lbm_uint fun_kind = SYMBOL_KIND(fun_val)((fun_val) >> 16);
2935
2936 switch (fun_kind) {
2937 case SYMBOL_KIND_EXTENSION1: {
2938 extension_fptr f = extension_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)].fptr;
2939
2940 lbm_value ext_res;
2941 WITH_GC(ext_res, f(&fun_args[1], arg_count))(ext_res) = (f(&fun_args[1], arg_count)); if (lbm_is_symbol_merror
((ext_res))) { gc(); (ext_res) = (f(&fun_args[1], arg_count
)); if (lbm_is_symbol_merror((ext_res))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2942 if (lbm_is_error(ext_res)) { //Error other than merror
2943 error_at_ctx(ext_res, fun);
2944 }
2945 lbm_stack_drop(&ctx->K, arg_count + 1);
2946
2947 ctx->app_cont = true1;
2948 ctx->r = ext_res;
2949
2950 if (blocking_extension) {
2951 blocking_extension = false0;
2952 if (blocking_extension_timeout) {
2953 blocking_extension_timeout = false0;
2954 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, blocking_extension_timeout_us,true1);
2955 } else {
2956 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,true1);
2957 }
2958 mutex_unlock(&blocking_extension_mutex);
2959 }
2960 } break;
2961 case SYMBOL_KIND_FUNDAMENTAL2:
2962 call_fundamental(SYMBOL_IX(fun_val)((fun_val) & 0xFFFF), &fun_args[1], arg_count, ctx);
2963 break;
2964 case SYMBOL_KIND_APPFUN3:
2965 fun_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)](&fun_args[1], arg_count, ctx);
2966 break;
2967 default:
2968 // Symbols that are "special" but not in the way caught above
2969 // ends up here.
2970 lbm_set_error_reason("Symbol does not represent a function");
2971 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),fun_args[0]);
2972 break;
2973 }
2974}
2975
2976static void cont_closure_application_args(eval_context_t *ctx) {
2977 lbm_uint* sptr = get_stack_ptr(ctx, 5);
2978
2979 lbm_value arg_env = (lbm_value)sptr[0];
2980 lbm_value exp = (lbm_value)sptr[1];
2981 lbm_value clo_env = (lbm_value)sptr[2];
2982 lbm_value params = (lbm_value)sptr[3];
2983 lbm_value args = (lbm_value)sptr[4];
2984
2985 lbm_value car_params, cdr_params;
2986 get_car_and_cdr(params, &car_params, &cdr_params);
2987
2988 bool_Bool a_nil = lbm_is_symbol_nil(args);
2989 bool_Bool p_nil = lbm_is_symbol_nil(cdr_params);
2990
2991 lbm_value binder = allocate_binding(car_params, ctx->r, clo_env);
2992
2993 if (!a_nil && !p_nil) {
2994 lbm_value car_args, cdr_args;
2995 get_car_and_cdr(args, &car_args, &cdr_args);
2996 sptr[2] = binder;
2997 sptr[3] = cdr_params;
2998 sptr[4] = cdr_args;
2999 stack_reserve(ctx,1)[0] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
3000 ctx->curr_exp = car_args;
3001 ctx->curr_env = arg_env;
3002 } else if (a_nil && p_nil) {
3003 // Arguments and parameters match up in number
3004 lbm_stack_drop(&ctx->K, 5);
3005 ctx->curr_env = binder;
3006 ctx->curr_exp = exp;
3007 } else if (p_nil) {
3008 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), binder);
3009 sptr[2] = rest_binder;
3010 sptr[3] = get_cdr(args);
3011 sptr[4] = get_car(rest_binder); // last element of rest_args so far
3012 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3013 ctx->curr_exp = get_car(args);
3014 ctx->curr_env = arg_env;
3015 } else {
3016 lbm_set_error_reason((char*)lbm_error_str_num_args);
3017 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
3018 }
3019}
3020
3021
3022static void cont_closure_args_rest(eval_context_t *ctx) {
3023 lbm_uint* sptr = get_stack_ptr(ctx, 5);
3024 lbm_value arg_env = (lbm_value)sptr[0];
3025 lbm_value exp = (lbm_value)sptr[1];
3026 lbm_value clo_env = (lbm_value)sptr[2];
3027 lbm_value args = (lbm_value)sptr[3];
3028 lbm_value last = (lbm_value)sptr[4];
3029 lbm_cons_t* heap = lbm_heap_state.heap;
3030
3031 lbm_value binding = lbm_heap_state.freelist;
3032 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3033 gc();
3034 binding = lbm_heap_state.freelist;
3035 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3036 }
3037 lbm_uint binding_ix = lbm_dec_ptr(binding);
3038 lbm_heap_state.freelist = heap[binding_ix].cdr;
3039 lbm_heap_state.num_alloc += 1;
3040 heap[binding_ix].car = ctx->r;
3041 heap[binding_ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3042
3043
3044 lbm_set_cdr(last, binding);
3045 sptr[4] = binding;
3046
3047 if (args == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3048 lbm_stack_drop(&ctx->K, 5);
3049 ctx->curr_env = clo_env;
3050 ctx->curr_exp = exp;
3051 } else {
3052 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3053 sptr[3] = get_cdr(args);
3054 ctx->curr_exp = get_car(args);
3055 ctx->curr_env = arg_env;
3056 }
3057}
3058
3059static void cont_application_args(eval_context_t *ctx) {
3060 lbm_uint *sptr = get_stack_ptr(ctx, 3);
3061
3062 lbm_value env = sptr[0];
3063 lbm_value rest = sptr[1];
3064 lbm_value count = sptr[2];
3065
3066 ctx->curr_env = env;
3067 sptr[0] = ctx->r; // Function 1st then Arguments
3068 if (lbm_is_cons(rest)) {
3069 lbm_cons_t *cell = lbm_ref_cell(rest);
3070 sptr[1] = env;
3071 sptr[2] = cell->cdr;
3072 lbm_value *rptr = stack_reserve(ctx,2);
3073 rptr[0] = count + (1 << LBM_VAL_SHIFT4);
3074 rptr[1] = APPLICATION_ARGS(((5) << 2) | 0xF8000001u);
3075 ctx->curr_exp = cell->car;
3076 } else {
3077 // No more arguments
3078 lbm_stack_drop(&ctx->K, 2);
3079 lbm_uint nargs = lbm_dec_u(count);
3080 lbm_value *args = get_stack_ptr(ctx, (uint32_t)(nargs + 1));
3081 application(ctx,args, nargs);
3082 }
3083}
3084
3085static void cont_and(eval_context_t *ctx) {
3086 lbm_value env;
3087 lbm_value rest;
3088 lbm_value arg = ctx->r;
3089 lbm_pop_2(&ctx->K, &rest, &env);
3090 if (lbm_is_symbol_nil(arg)) {
3091 ctx->app_cont = true1;
3092 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3093 } else if (lbm_is_symbol_nil(rest)) {
3094 ctx->app_cont = true1;
3095 } else {
3096 lbm_value *sptr = stack_reserve(ctx, 3);
3097 sptr[0] = env;
3098 sptr[1] = get_cdr(rest);
3099 sptr[2] = AND(((6) << 2) | 0xF8000001u);
3100 ctx->curr_env = env;
3101 ctx->curr_exp = get_car(rest);
3102 }
3103}
3104
3105static void cont_or(eval_context_t *ctx) {
3106 lbm_value env;
3107 lbm_value rest;
3108 lbm_value arg = ctx->r;
3109 lbm_pop_2(&ctx->K, &rest, &env);
3110 if (!lbm_is_symbol_nil(arg)) {
3111 ctx->app_cont = true1;
3112 } else if (lbm_is_symbol_nil(rest)) {
3113 ctx->app_cont = true1;
3114 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3115 } else {
3116 lbm_value *sptr = stack_reserve(ctx, 3);
3117 sptr[0] = env;
3118 sptr[1] = get_cdr(rest);
3119 sptr[2] = OR(((7) << 2) | 0xF8000001u);
3120 ctx->curr_exp = get_car(rest);
3121 ctx->curr_env = env;
3122 }
3123}
3124
3125static int fill_binding_location(lbm_value key, lbm_value value, lbm_value env) {
3126 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) {
3127 if (key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return FB_OK0;
3128 lbm_env_modify_binding(env,key,value);
3129 return FB_OK0;
3130 } else if (lbm_is_cons(key) &&
3131 lbm_is_cons(value)) {
3132 int r = fill_binding_location(get_car(key), get_car(value), env);
3133 if (r == FB_OK0) {
3134 r = fill_binding_location(get_cdr(key), get_cdr(value), env);
3135 }
3136 return r;
3137 }
3138 return FB_TYPE_ERROR-1;
3139}
3140
3141static void cont_bind_to_key_rest(eval_context_t *ctx) {
3142
3143 lbm_value *sptr = get_stack_ptr(ctx, 4);
3144
3145 lbm_value rest = sptr[1];
3146 lbm_value env = sptr[2];
3147 lbm_value key = sptr[3];
3148
3149 if (fill_binding_location(key, ctx->r, env) < 0) {
3150 lbm_set_error_reason("Incorrect type of name/key in let-binding");
3151 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
3152 }
3153
3154 if (lbm_is_cons(rest)) {
3155 lbm_value car_rest = get_car(rest);
3156 lbm_value key_val[2];
3157 extract_n(car_rest, key_val, 2);
3158
3159 sptr[1] = get_cdr(rest);
3160 sptr[3] = key_val[0];
3161 stack_reserve(ctx,1)[0] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
3162 ctx->curr_exp = key_val[1];
3163 ctx->curr_env = env;
3164 } else {
3165 // Otherwise evaluate the expression in the populated env
3166 ctx->curr_exp = sptr[0];
3167 ctx->curr_env = env;
3168 lbm_stack_drop(&ctx->K, 4);
3169 }
3170}
3171
3172static void cont_if(eval_context_t *ctx) {
3173
3174 lbm_value arg = ctx->r;
3175
3176 lbm_value *sptr = pop_stack_ptr(ctx, 2);
3177
3178 ctx->curr_env = sptr[1];
3179 if (lbm_is_symbol_nil(arg)) {
3180 ctx->curr_exp = get_cadr(sptr[0]); // else branch
3181 } else {
3182 ctx->curr_exp = get_car(sptr[0]); // then branch
3183 }
3184}
3185
3186static void cont_match(eval_context_t *ctx) {
3187 lbm_value e = ctx->r;
3188 bool_Bool do_gc = false0;
3189
3190 lbm_uint *sptr = get_stack_ptr(ctx, 2);
3191 lbm_value patterns = (lbm_value)sptr[0];
3192 lbm_value orig_env = (lbm_value)sptr[1]; // restore enclosing environment.
3193 lbm_value new_env = orig_env;
3194
3195 if (lbm_is_symbol_nil(patterns)) {
3196 // no more patterns
3197 lbm_stack_drop(&ctx->K, 2);
3198 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
3199 ctx->app_cont = true1;
3200 } else if (lbm_is_cons(patterns)) {
3201 lbm_value match_case = get_car(patterns);
3202 lbm_value pattern = get_car(match_case);
3203 lbm_value n1 = get_cadr(match_case);
3204 lbm_value n2 = get_cadr(get_cdr(match_case));
3205 lbm_value body;
3206 bool_Bool check_guard = false0;
3207 if (lbm_is_symbol_nil(n2)) { // TODO: Not a very robust check.
3208 body = n1;
3209 } else {
3210 body = n2;
3211 check_guard = true1;
3212 }
3213
3214 bool_Bool is_match = match(pattern, e, &new_env, &do_gc);
3215 if (do_gc) {
3216 gc();
3217 do_gc = false0;
3218 new_env = orig_env;
3219 is_match = match(pattern, e, &new_env, &do_gc);
3220 if (do_gc) {
3221 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3222 }
3223 }
3224 if (is_match) {
3225 if (check_guard) {
3226 lbm_value *rptr = stack_reserve(ctx,5);
3227 sptr[0] = get_cdr(patterns);
3228 sptr[1] = ctx->curr_env;
3229 rptr[0] = MATCH(((9) << 2) | 0xF8000001u);
3230 rptr[1] = new_env;
3231 rptr[2] = body;
3232 rptr[3] = e;
3233 rptr[4] = MATCH_GUARD(((27) << 2) | 0xF8000001u);
3234 ctx->curr_env = new_env;
3235 ctx->curr_exp = n1; // The guard
3236 } else {
3237 lbm_stack_drop(&ctx->K, 2);
3238 ctx->curr_env = new_env;
3239 ctx->curr_exp = body;
3240 }
3241 } else {
3242 // set up for checking of next pattern
3243 sptr[0] = get_cdr(patterns);
3244 sptr[1] = orig_env;
3245 stack_reserve(ctx,1)[0] = MATCH(((9) << 2) | 0xF8000001u);
3246 // leave r unaltered
3247 ctx->app_cont = true1;
3248 }
3249 } else {
3250 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MATCH(((0x108) << 4) | 0x00000000u));
3251 }
3252}
3253
3254static void cont_exit_atomic(eval_context_t *ctx) {
3255 is_atomic --;
3256 ctx->app_cont = true1;
3257}
3258
3259static void cont_map(eval_context_t *ctx) {
3260 lbm_value *sptr = get_stack_ptr(ctx, 6);
3261
3262 lbm_value ls = sptr[0];
3263 lbm_value env = sptr[1];
3264 lbm_value t = sptr[3];
3265 lbm_set_car(t, ctx->r); // update car field tailmost position.
3266 if (lbm_is_cons(ls)) {
3267 lbm_value next, rest;
3268 get_car_and_cdr(ls, &next, &rest);
3269 sptr[0] = rest;
3270 stack_reserve(ctx,1)[0] = MAP(((26) << 2) | 0xF8000001u);
3271 lbm_set_car(sptr[5], next); // new arguments
3272
3273 lbm_value elt = cons_with_gc(ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3274 lbm_set_cdr(t, elt);
3275 sptr[3] = elt; // (r1 ... rN . (nil . nil))
3276 ctx->curr_exp = sptr[4];
3277 ctx->curr_env = env;
3278 } else {
3279 ctx->r = sptr[2]; //head of result list
3280 ctx->curr_env = env;
3281 lbm_stack_drop(&ctx->K, 6);
3282 ctx->app_cont = true1;
3283 }
3284}
3285
3286static void cont_match_guard(eval_context_t *ctx) {
3287 if (lbm_is_symbol_nil(ctx->r)) {
3288 lbm_value e;
3289 lbm_pop(&ctx->K, &e);
3290 lbm_stack_drop(&ctx->K, 2);
3291 ctx->r = e;
3292 ctx->app_cont = true1;
3293 } else {
3294 lbm_value body;
3295 lbm_value env;
3296 lbm_stack_drop(&ctx->K, 1);
3297 lbm_pop_2(&ctx->K, &body, &env);
3298 lbm_stack_drop(&ctx->K, 3);
3299 ctx->curr_env = env;
3300 ctx->curr_exp = body;
3301 }
3302}
3303
3304static void cont_terminate(eval_context_t *ctx) {
3305 error_ctx(ctx->r);
3306}
3307
3308static void cont_loop(eval_context_t *ctx) {
3309 lbm_value *sptr = get_stack_ptr(ctx, 2);
3310 stack_reserve(ctx,1)[0] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
3311 ctx->curr_exp = sptr[1];
3312}
3313
3314static void cont_loop_condition(eval_context_t *ctx) {
3315 if (lbm_is_symbol_nil(ctx->r)) {
3316 lbm_stack_drop(&ctx->K, 2);
3317 ctx->app_cont = true1; // A loop returns nil? Makes sense to me... but in general?
3318 return;
3319 }
3320 lbm_value *sptr = get_stack_ptr(ctx, 2);
3321 stack_reserve(ctx,1)[0] = LOOP(((41) << 2) | 0xF8000001u);
3322 ctx->curr_exp = sptr[0];
3323}
3324
3325static void cont_merge_rest(eval_context_t *ctx) {
3326 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3327
3328 // If comparator returns true (result is in ctx->r):
3329 // "a" should be moved to the last element position in merged list.
3330 // A new element from "a_rest" should be moved into comparator argument 1 pos.
3331 // else
3332 // "b" should be moved to last element position in merged list.
3333 // A new element from "b_rest" should be moved into comparator argument 2 pos.
3334 //
3335 // If a_rest or b_rest is NIL:
3336 // we are done, the remaining elements of
3337 // non_nil list should be appended to merged list.
3338 // else
3339 // Set up for a new comparator evaluation and recurse.
3340 lbm_value a = sptr[2];
3341 lbm_value b = lbm_cdr(a);
3342 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate 1 element list
3343
3344 if (ctx->r == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) { // Comparison false
3345
3346 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3347 sptr[0] = b;
3348 sptr[1] = b;
3349 } else {
3350 lbm_set_cdr(sptr[1], b);
3351 sptr[1] = b;
3352 }
3353 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3354 lbm_set_cdr(a, sptr[3]);
3355 lbm_set_cdr(sptr[1], a);
3356 ctx->r = sptr[0];
3357 lbm_stack_drop(&ctx->K, 9);
3358 ctx->app_cont = true1;
3359 return;
3360 } else {
3361 b = sptr[4];
3362 sptr[4] = lbm_cdr(sptr[4]);
3363 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3364 }
3365 } else {
3366 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3367 sptr[0] = a;
3368 sptr[1] = a;
3369 } else {
3370 lbm_set_cdr(sptr[1], a);
3371 sptr[1] = a;
3372 }
3373
3374 if (sptr[3] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3375 lbm_set_cdr(b, sptr[4]);
3376 lbm_set_cdr(sptr[1], b);
3377 ctx->r = sptr[0];
3378 lbm_stack_drop(&ctx->K, 9);
3379 ctx->app_cont = true1;
3380 return;
3381 } else {
3382 a = sptr[3];
3383 sptr[3] = lbm_cdr(sptr[3]);
3384 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3385 }
3386 }
3387 lbm_set_cdr(a, b);
3388 sptr[2] = a;
3389
3390 lbm_value par1 = sptr[7];
3391 lbm_value par2 = sptr[8];
3392 lbm_value cmp_body = sptr[5];
3393 lbm_value cmp_env = sptr[6];
3394 // Environment should be preallocated already at this point
3395 // and the operations below should never need GC.
3396 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3397 lbm_value new_env = lbm_env_set(new_env0, par2, lbm_car(b));
3398 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3399 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3400 }
3401 cmp_env = new_env;
3402
3403 stack_reserve(ctx,1)[0] = MERGE_REST(((43) << 2) | 0xF8000001u);
3404 ctx->curr_exp = cmp_body;
3405 ctx->curr_env = cmp_env;
3406}
3407
3408// merge_layer stack contents
3409// s[sp-9] = cmp
3410// s[sp-8] = cmp_env
3411// s[sp-7] = par1
3412// s[sp-6] = par2
3413// s[sp-5] = acc - first cell
3414// s[sp-4] = acc - last cell
3415// s[sp-3] = rest;
3416// s[sp-2] = layer
3417// s[sp-1] = length or original list
3418//
3419// ctx->r merged sublist
3420static void cont_merge_layer(eval_context_t *ctx) {
3421 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3422 lbm_int layer = lbm_dec_i(sptr[7]);
3423 lbm_int len = lbm_dec_i(sptr[8]);
3424
3425 lbm_value r_curr = ctx->r;
3426 while (lbm_is_cons(r_curr)) {
3427 lbm_value next = lbm_cdr(r_curr);
3428 if (next == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3429 break;
3430 }
3431 r_curr = next;
3432 }
3433
3434 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3435 sptr[4] = ctx->r;
3436 sptr[5] = r_curr;
3437 } else {
3438 lbm_set_cdr(sptr[5], ctx->r); // accumulate merged sublists.
3439 sptr[5] = r_curr;
3440 }
3441
3442 lbm_value layer_rest = sptr[6];
3443 // switch layer or done ?
3444 if (layer_rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3445 if (layer * 2 >= len) {
3446 ctx->r = sptr[4];
3447 ctx->app_cont = true1;
3448 lbm_stack_drop(&ctx->K, 9);
3449 return;
3450 } else {
3451 // Setup for merges of the next layer
3452 layer = layer * 2;
3453 sptr[7] = lbm_enc_i(layer);
3454 layer_rest = sptr[4]; // continue on the accumulation of all sublists.
3455 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3456 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3457 }
3458 }
3459 // merge another sublist based on current layer.
3460 lbm_value a_list = layer_rest;
3461 // build sublist a
3462 lbm_value curr = layer_rest;
3463 for (int i = 0; i < layer-1; i ++) {
3464 if (lbm_is_cons(curr)) {
3465 curr = lbm_cdr(curr);
3466 } else {
3467 break;
3468 }
3469 }
3470 layer_rest = lbm_cdr(curr);
3471 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3472
3473 lbm_value b_list = layer_rest;
3474 // build sublist b
3475 curr = layer_rest;
3476 for (int i = 0; i < layer-1; i ++) {
3477 if (lbm_is_cons(curr)) {
3478 curr = lbm_cdr(curr);
3479 } else {
3480 break;
3481 }
3482 }
3483 layer_rest = lbm_cdr(curr);
3484 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3485
3486 sptr[6] = layer_rest;
3487
3488 if (b_list == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3489 stack_reserve(ctx,1)[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3490 ctx->r = a_list;
3491 ctx->app_cont = true1;
3492 return;
3493 }
3494 // Set up for a merge of sublists.
3495
3496 lbm_value a_rest = lbm_cdr(a_list);
3497 lbm_value b_rest = lbm_cdr(b_list);
3498 lbm_value a = a_list;
3499 lbm_value b = b_list;
3500 lbm_set_cdr(a, b);
3501 // Terminating the b list would be incorrect here
3502 // if there was any chance that the environment update below
3503 // performs GC.
3504 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3505
3506 lbm_value cmp_body = sptr[0];
3507 lbm_value cmp_env = sptr[1];
3508 lbm_value par1 = sptr[2];
3509 lbm_value par2 = sptr[3];
3510 // Environment should be preallocated already at this point
3511 // and the operations below should never need GC.
3512 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3513 lbm_value new_env = lbm_env_set(cmp_env, par2, lbm_car(b));
3514 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3515 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3516 }
3517 cmp_env = new_env;
3518
3519 lbm_uint *merge_cont = stack_reserve(ctx, 11);
3520 merge_cont[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3521 merge_cont[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3522 merge_cont[2] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3523 merge_cont[3] = a;
3524 merge_cont[4] = a_rest;
3525 merge_cont[5] = b_rest;
3526 merge_cont[6] = cmp_body;
3527 merge_cont[7] = cmp_env;
3528 merge_cont[8] = par1;
3529 merge_cont[9] = par2;
3530 merge_cont[10] = MERGE_REST(((43) << 2) | 0xF8000001u);
3531 ctx->curr_exp = cmp_body;
3532 ctx->curr_env = cmp_env;
3533 return;
3534}
3535
3536/****************************************************/
3537/* READER */
3538
3539static void read_finish(lbm_char_channel_t *str, eval_context_t *ctx) {
3540
3541 /* Tokenizer reached "end of file"
3542 The parser could be in a state where it needs
3543 more tokens to correctly finish an expression.
3544
3545 Three cases
3546 1. The program / expression is malformed and the context should die.
3547 2. We are finished reading a program and should close off the
3548 internal representation with a closing parenthesis. Then
3549 apply continuation.
3550 3. We are finished reading an expression and should
3551 apply the continuation.
3552
3553 In case 3, we should find the READ_DONE at sp - 1.
3554 In case 2, we should find the READ_DONE at sp - 5.
3555
3556 */
3557
3558 if (lbm_is_symbol(ctx->r)) {
3559 lbm_uint sym_val = lbm_dec_sym(ctx->r);
3560 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
3561 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
3562 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3563 }
3564 }
3565
3566 if (ctx->K.data[ctx->K.sp-1] == READ_DONE(((20) << 2) | 0xF8000001u) &&
3567 lbm_dec_u(ctx->K.data[ctx->K.sp-3]) == 0) {
3568 /* successfully finished reading an expression (CASE 3) */
3569 ctx->app_cont = true1;
3570 } else if (ctx->K.sp > 4 && ctx->K.data[ctx->K.sp - 4] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3571 lbm_value env;
3572 lbm_value s;
3573 lbm_value sym;
3574 lbm_pop_3(&ctx->K, &sym, &env, &s);
3575 ctx->curr_env = env;
3576 ctx->app_cont = true1; // Program evaluated and result is in ctx->r.
3577 } else if (ctx->K.sp > 5 && ctx->K.data[ctx->K.sp - 5] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3578 /* successfully finished reading a program (CASE 2) */
3579 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3580 ctx->app_cont = true1;
3581 } else {
3582 /* Parsing failed */
3583 if (lbm_channel_row(str) == 1 &&
3584 lbm_channel_column(str) == 1 ){
3585 // eof at empty stream.
3586 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3587 ctx->app_cont = true1;
3588 } else {
3589 lbm_set_error_reason((char*)lbm_error_str_parse_eof);
3590 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3591 }
3592 lbm_channel_reader_close(str);
3593 }
3594}
3595
3596/* cont_read_next_token
3597 sp-2 : Stream
3598 sp-1 : Grab row
3599*/
3600static void cont_read_next_token(eval_context_t *ctx) {
3601 lbm_value *sptr = get_stack_ptr(ctx, 2);
3602 lbm_value stream = sptr[0];
3603 lbm_value grab_row0 = sptr[1];
3604
3605 lbm_char_channel_t *chan = lbm_dec_channel(stream);
3606 if (chan == NULL((void*)0) || chan->state == NULL((void*)0)) {
3607 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3608 }
3609
3610 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3611 lbm_stack_drop(&ctx->K, 2);
3612 read_finish(chan, ctx);
3613 return;
3614 }
3615 /* Eat whitespace and comments */
3616 if (!tok_clean_whitespace(chan)) {
3617 sptr[0] = stream;
3618 sptr[1] = lbm_enc_u(0);
3619 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3620 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3621 return;
3622 }
3623 /* After eating whitespace we may be at end of file/stream */
3624 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3625 lbm_stack_drop(&ctx->K, 2);
3626 read_finish(chan, ctx);
3627 return;
3628 }
3629
3630 if (lbm_dec_u(grab_row0)) {
3631 ctx->row0 = (int32_t)lbm_channel_row(chan);
3632 }
3633
3634 /* Attempt to extract tokens from the character stream */
3635 int n = 0;
3636 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3637 unsigned int string_len = 0;
3638
3639 /*
3640 * SYNTAX
3641 */
3642 uint32_t match;
3643 n = tok_syntax(chan, &match);
3644 if (n > 0) {
3645 if (!lbm_channel_drop(chan, (unsigned int)n)) {
3646 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3647 }
3648 ctx->app_cont = true1;
3649 lbm_uint do_next = 0;
3650 switch(match) {
3651 case TOKOPENPAR1u: {
3652 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3653 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3654 lbm_value *rptr = stack_reserve(ctx,5);
3655 rptr[0] = stream;
3656 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3657 rptr[2] = stream;
3658 rptr[3] = lbm_enc_u(0);
3659 rptr[4] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3660 ctx->r = ENC_SYM_OPENPAR(((0x70) << 4) | 0x00000000u);
3661 } return;
3662 case TOKCLOSEPAR2u: {
3663 lbm_stack_drop(&ctx->K, 2);
3664 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3665 } return;
3666 case TOKOPENBRACK3u: {
3667 sptr[0] = stream;
3668 sptr[1] = READ_START_ARRAY(((24) << 2) | 0xF8000001u);
3669 lbm_value *rptr = stack_reserve(ctx, 3);
3670 rptr[0] = stream;
3671 rptr[1] = lbm_enc_u(0);
3672 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3673 ctx->r = ENC_SYM_OPENBRACK(((0x80) << 4) | 0x00000000u);
3674 } return;
3675 case TOKCLOSEBRACK4u:
3676 lbm_stack_drop(&ctx->K, 2);
3677 ctx->r = ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u);
3678 return;
3679 case TOKDOT5u:
3680 lbm_stack_drop(&ctx->K, 2);
3681 ctx->r = ENC_SYM_DOT(((0x76) << 4) | 0x00000000u);
3682 return;
3683 case TOKDONTCARE6u:
3684 lbm_stack_drop(&ctx->K, 2);
3685 ctx->r = ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u);
3686 return;
3687 case TOKQUOTE7u:
3688 do_next = READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u);
3689 break;
3690 case TOKBACKQUOTE8u: {
3691 sptr[0] = QQ_EXPAND_START(((35) << 2) | 0xF8000001u);
3692 sptr[1] = stream;
3693 lbm_value *rptr = stack_reserve(ctx, 2);
3694 rptr[0] = lbm_enc_u(0);
3695 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3696 ctx->app_cont = true1;
3697 } return;
3698 case TOKCOMMAAT9u:
3699 do_next = READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u);
3700 break;
3701 case TOKCOMMA10u:
3702 do_next = READ_COMMA_RESULT(((23) << 2) | 0xF8000001u);
3703 break;
3704 case TOKMATCHANY11u:
3705 lbm_stack_drop(&ctx->K, 2);
3706 ctx->r = ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u);
3707 return;
3708 case TOKOPENCURL12u: {
3709 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3710 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3711 lbm_value *rptr = stack_reserve(ctx,2);
3712 rptr[0] = stream;
3713 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3714 ctx->r = ENC_SYM_PROGN(((0x102) << 4) | 0x00000000u);
3715 } return;
3716 case TOKCLOSECURL13u:
3717 lbm_stack_drop(&ctx->K, 2);
3718 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3719 return;
3720 case TOKCONSTSTART14u: /* fall through */
3721 case TOKCONSTEND15u:
3722 case TOKCONSTSYMSTR16u: {
3723 if (match == TOKCONSTSTART14u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3724 if (match == TOKCONSTEND15u) ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3725 if (match == TOKCONSTSYMSTR16u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04;
3726 sptr[0] = stream;
3727 sptr[1] = lbm_enc_u(0);
3728 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3729 ctx->app_cont = true1;
3730 } return;
3731 default:
3732 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3733 }
3734 sptr[0] = do_next;
3735 sptr[1] = stream;
3736 lbm_value *rptr = stack_reserve(ctx, 2);
3737 rptr[0] = lbm_enc_u(0);
3738 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3739 ctx->app_cont = true1;
3740 return;
3741 } else if (n < 0) goto retry_token;
3742
3743 /*
3744 * STRING
3745 */
3746 n = tok_string(chan, &string_len);
3747 if (n >= 2) {
3748 lbm_channel_drop(chan, (unsigned int)n);
3749 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3750 gc();
3751 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3752 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3753 return; // dead return but static analysis does not know that.
3754 }
3755 }
3756 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(res);
3757 char *data = (char*)arr->data;
3758 memset(data,0, string_len + 1);
3759 memcpy(data, tokpar_sym_str, string_len);
3760 lbm_stack_drop(&ctx->K, 2);
3761 ctx->r = res;
3762 ctx->app_cont = true1;
3763 return;
3764 } else if (n < 0) goto retry_token;
3765
3766 /*
3767 * FLOAT
3768 */
3769 token_float f_val;
3770 n = tok_double(chan, &f_val);
3771 if (n > 0) {
3772 lbm_channel_drop(chan, (unsigned int) n);
3773 switch(f_val.type) {
3774 case TOKTYPEF32107u:
3775 WITH_GC(res, lbm_enc_float((float)f_val.value))(res) = (lbm_enc_float((float)f_val.value)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (lbm_enc_float((float)f_val.value));
if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
3776 break;
3777 case TOKTYPEF64108u:
3778 res = lbm_enc_double(f_val.value);
3779 break;
3780 default:
3781 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3782 }
3783 lbm_stack_drop(&ctx->K, 2);
3784 ctx->r = res;
3785 ctx->app_cont = true1;
3786 return;
3787 } else if (n < 0) goto retry_token;
3788
3789 /*
3790 * INTEGER
3791 */
3792 token_int int_result;
3793 n = tok_integer(chan, &int_result);
3794 if (n > 0) {
3795 lbm_channel_drop(chan, (unsigned int)n);
3796 switch(int_result.type) {
3797 case TOKTYPEBYTE100u:
3798 res = lbm_enc_char((uint8_t)(int_result.negative ? -int_result.value : int_result.value));
3799 break;
3800 case TOKTYPEI101u:
3801 res = lbm_enc_i((lbm_int)(int_result.negative ? -int_result.value : int_result.value));
3802 break;
3803 case TOKTYPEU102u:
3804 res = lbm_enc_u((lbm_uint)(int_result.negative ? -int_result.value : int_result.value));
3805 break;
3806 case TOKTYPEI32103u:
3807 WITH_GC(res, lbm_enc_i32((int32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i32((int32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i32((int32_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3808 break;
3809 case TOKTYPEU32104u:
3810 WITH_GC(res,lbm_enc_u32((uint32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u32((uint32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u32((uint32_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3811 break;
3812 case TOKTYPEI64105u:
3813 WITH_GC(res,lbm_enc_i64((int64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i64((int64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i64((int64_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3814 break;
3815 case TOKTYPEU64106u:
3816 WITH_GC(res,lbm_enc_u64((uint64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u64((uint64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u64((uint64_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3817 break;
3818 default:
3819 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3820 }
3821 lbm_stack_drop(&ctx->K, 2);
3822 ctx->r = res;
3823 ctx->app_cont = true1;
3824 return;
3825 } else if (n < 0) goto retry_token;
3826
3827 /*
3828 * SYMBOL
3829 */
3830 n = tok_symbol(chan);
3831 if (n > 0) {
3832 lbm_channel_drop(chan, (unsigned int) n);
3833 lbm_uint symbol_id;
3834 if (lbm_get_symbol_by_name(tokpar_sym_str, &symbol_id)) {
3835 res = lbm_enc_sym(symbol_id);
3836 } else {
3837 int r = 0;
3838 if (n > 4 &&
3839 tokpar_sym_str[0] == 'e' &&
3840 tokpar_sym_str[1] == 'x' &&
3841 tokpar_sym_str[2] == 't' &&
3842 tokpar_sym_str[3] == '-') {
3843 lbm_uint ext_id;
3844 lbm_uint ext_name_len = (lbm_uint)n + 1;
3845 char *ext_name = lbm_malloc(ext_name_len);
3846 if (!ext_name) {
3847 gc();
3848 ext_name = lbm_malloc(ext_name_len);
3849 }
3850 if (ext_name) {
3851 memcpy(ext_name, tokpar_sym_str, ext_name_len);
3852 r = lbm_add_extension(ext_name, lbm_extensions_default);
3853 if (!lbm_lookup_extension_id(ext_name, &ext_id)) {
3854 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3855 }
3856 symbol_id = ext_id;
3857 } else {
3858 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3859 }
3860 } else {
3861 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04 &&
3862 ctx->flags & EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08) {
3863 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id, true1); //flash
3864 if (!r) {
3865 lbm_set_error_reason((char*)lbm_error_str_flash_error);
3866 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3867 }
3868 } else {
3869 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3870 if (!r) {
3871 gc();
3872 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3873 }
3874 }
3875 }
3876 if (r) {
3877 res = lbm_enc_sym(symbol_id);
3878 } else {
3879 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3880 }
3881 }
3882 lbm_stack_drop(&ctx->K, 2);
3883 ctx->r = res;
3884 ctx->app_cont = true1;
3885 return;
3886 } else if (n == TOKENIZER_NEED_MORE-1) {
3887 goto retry_token;
3888 } else if (n <= TOKENIZER_STRING_ERROR-2) {
3889 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3890 }
3891
3892 /*
3893 * CHAR
3894 */
3895 char c_val;
3896 n = tok_char(chan, &c_val);
3897 if(n > 0) {
3898 lbm_channel_drop(chan,(unsigned int) n);
3899 lbm_stack_drop(&ctx->K, 2);
3900 ctx->r = lbm_enc_char((uint8_t)c_val);
3901 ctx->app_cont = true1;
3902 return;
3903 }else if (n < 0) goto retry_token;
3904
3905 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3906
3907 retry_token:
3908 if (n == TOKENIZER_NEED_MORE-1) {
3909 sptr[0] = stream;
3910 sptr[1] = lbm_enc_u(0);
3911 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3912 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3913 return;
3914 }
3915 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3916}
3917
3918static void cont_read_start_array(eval_context_t *ctx) {
3919 lbm_value *sptr = get_stack_ptr(ctx, 1);
3920 lbm_value stream = sptr[0];
3921
3922 lbm_char_channel_t *str = lbm_dec_channel(stream);
3923 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
3924 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3925 }
3926
3927 lbm_uint num_free = lbm_memory_longest_free();
3928 lbm_uint initial_size = (lbm_uint)((float)num_free * 0.9);
3929 if (initial_size == 0) {
3930 gc();
3931 num_free = lbm_memory_longest_free();
3932 initial_size = (lbm_uint)((float)num_free * 0.9);
3933 if (initial_size == 0) {
3934 lbm_channel_reader_close(str);
3935 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3936 }
3937 }
3938
3939 if (lbm_is_number(ctx->r)) {
3940 lbm_value array;
3941 initial_size = sizeof(lbm_uint) * initial_size;
3942
3943 if (!lbm_heap_allocate_array(&array, initial_size)) {
3944 lbm_set_error_reason("Out of memory while reading.");
3945 lbm_channel_reader_close(str);
3946 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3947 // NOTE: If array is not created evaluation ends here.
3948 // Static analysis seems unaware.
3949 }
3950
3951 sptr[0] = array;
3952 lbm_value *rptr = stack_reserve(ctx, 4);
3953 rptr[0] = lbm_enc_u(initial_size);
3954 rptr[1] = lbm_enc_u(0);
3955 rptr[2] = stream;
3956 rptr[3] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3957 ctx->app_cont = true1;
3958 } else {
3959 lbm_channel_reader_close(str);
3960 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3961 }
3962}
3963
3964static void cont_read_append_array(eval_context_t *ctx) {
3965 lbm_uint *sptr = get_stack_ptr(ctx, 4);
3966
3967 lbm_value array = sptr[0];
3968 lbm_value size = lbm_dec_as_u32(sptr[1]);
3969 lbm_value ix = lbm_dec_as_u32(sptr[2]);
3970 lbm_value stream = sptr[3];
3971
3972 if (ix >= (size - 1)) {
3973 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3974 }
3975
3976 // get_car can return nil. Whose value is 0!
3977 // So static Analysis is right about this being a potential NULL pointer.
3978 // However, if the array was created correcly to begin with, it should be fine.
3979 lbm_value arr_car = get_car(array);
3980 lbm_array_header_t *arr = (lbm_array_header_t*)arr_car;
3981
3982 if (lbm_is_number(ctx->r)) {
3983 ((uint8_t*)arr->data)[ix] = (uint8_t)lbm_dec_as_u32(ctx->r);
3984
3985 sptr[2] = lbm_enc_u(ix + 1);
3986 lbm_value *rptr = stack_reserve(ctx, 4);
3987 rptr[0] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3988 rptr[1] = stream;
3989 rptr[2] = lbm_enc_u(0);
3990 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3991 ctx->app_cont = true1;
3992 } else if (lbm_is_symbol(ctx->r) && ctx->r == ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u)) {
3993 lbm_uint array_size = ix / sizeof(lbm_uint);
3994
3995 if (ix % sizeof(lbm_uint) != 0) {
3996 array_size = array_size + 1;
3997 }
3998 lbm_memory_shrink((lbm_uint*)arr->data, array_size);
3999 arr->size = ix;
4000 lbm_stack_drop(&ctx->K, 4);
4001 ctx->r = array;
4002 ctx->app_cont = true1;
4003 } else {
4004 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
4005 }
4006}
4007
4008static void cont_read_append_continue(eval_context_t *ctx) {
4009 lbm_value *sptr = get_stack_ptr(ctx, 3);
4010
4011 lbm_value first_cell = sptr[0];
4012 lbm_value last_cell = sptr[1];
4013 lbm_value stream = sptr[2];
4014
4015 lbm_char_channel_t *str = lbm_dec_channel(stream);
4016 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4017 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4018 }
4019
4020 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4021
4022 switch(ctx->r) {
4023 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4024 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4025 lbm_set_cdr(last_cell, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate the list
4026 ctx->r = first_cell;
4027 } else {
4028 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4029 }
4030 lbm_stack_drop(&ctx->K, 3);
4031 /* Skip reading another token and apply the continuation */
4032 ctx->app_cont = true1;
4033 return;
4034 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4035 lbm_value *rptr = stack_reserve(ctx, 4);
4036 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4037 rptr[1] = stream;
4038 rptr[2] = lbm_enc_u(0);
4039 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4040 ctx->app_cont = true1;
4041 } return;
4042 }
4043 }
4044 lbm_value new_cell = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4045 if (lbm_is_symbol_merror(new_cell)) {
4046 lbm_channel_reader_close(str);
4047 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4048 return;
4049 }
4050 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4051 lbm_set_cdr(last_cell, new_cell);
4052 last_cell = new_cell;
4053 } else {
4054 first_cell = last_cell = new_cell;
4055 }
4056 sptr[0] = first_cell;
4057 sptr[1] = last_cell;
4058 sptr[2] = stream; // unchanged.
4059 lbm_value *rptr = stack_reserve(ctx, 4);
4060 rptr[0] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
4061 rptr[1] = stream;
4062 rptr[2] = lbm_enc_u(0);
4063 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4064 ctx->app_cont = true1;
4065}
4066
4067static void cont_read_eval_continue(eval_context_t *ctx) {
4068 lbm_value env;
4069 lbm_value stream;
4070 lbm_pop_2(&ctx->K, &env, &stream);
4071
4072 lbm_char_channel_t *str = lbm_dec_channel(stream);
4073 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4074 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4075 }
4076
4077 ctx->row1 = (lbm_int)str->row(str);
4078
4079 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4080
4081 switch(ctx->r) {
4082 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4083 ctx->app_cont = true1;
4084 return;
4085 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4086 // This case is a bit mysterious.
4087 // A dot, may in reality be an error in this location.
4088 lbm_value *rptr = stack_reserve(ctx, 4);
4089 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4090 rptr[1] = stream;
4091 rptr[2] = lbm_enc_u(0);
4092 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4093 ctx->app_cont = true1;
4094 } return;
4095 }
4096 }
4097
4098 lbm_value *rptr = stack_reserve(ctx, 6);
4099 rptr[0] = stream;
4100 rptr[1] = env;
4101 rptr[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
4102 rptr[3] = stream;
4103 rptr[4] = lbm_enc_u(1);
4104 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4105 rptr[6] = lbm_enc_u(ctx->flags);
4106 rptr[7] = POP_READER_FLAGS(((47) << 2) | 0xF8000001u);
4107 ctx->curr_env = env;
4108 ctx->curr_exp = ctx->r;
4109}
4110
4111static void cont_read_expect_closepar(eval_context_t *ctx) {
4112 lbm_value res;
4113 lbm_value stream;
4114
4115 lbm_pop_2(&ctx->K, &res, &stream);
4116
4117 lbm_char_channel_t *str = lbm_dec_channel(stream);
4118 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4119 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4120 }
4121
4122 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4123 ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u)) {
4124 ctx->r = res;
4125 ctx->app_cont = true1;
4126 } else {
4127 lbm_channel_reader_close(str);
4128 lbm_set_error_reason((char*)lbm_error_str_parse_close);
4129 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4130 }
4131}
4132
4133static void cont_read_dot_terminate(eval_context_t *ctx) {
4134 lbm_value *sptr = get_stack_ptr(ctx, 3);
4135
4136 lbm_value first_cell = sptr[0];
4137 lbm_value last_cell = sptr[1];
4138 lbm_value stream = sptr[2];
4139
4140 lbm_char_channel_t *str = lbm_dec_channel(stream);
4141 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4142 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4143 }
4144
4145 lbm_stack_drop(&ctx->K ,3);
4146
4147 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4148 (ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u) ||
4149 ctx->r == ENC_SYM_DOT(((0x76) << 4) | 0x00000000u))) {
4150 lbm_channel_reader_close(str);
4151 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4152 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4153 } else {
4154 if (lbm_is_cons(last_cell)) {
4155 lbm_set_cdr(last_cell, ctx->r);
4156 ctx->r = first_cell;
4157 lbm_value *rptr = stack_reserve(ctx, 6);
4158 rptr[0] = stream;
4159 rptr[1] = ctx->r;
4160 rptr[2] = READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u);
4161 rptr[3] = stream;
4162 rptr[4] = lbm_enc_u(0);
4163 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4164 ctx->app_cont = true1;
4165 } else {
4166 lbm_channel_reader_close(str);
4167 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4168 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4169 }
4170 }
4171}
4172
4173static void cont_read_done(eval_context_t *ctx) {
4174 lbm_value stream;
4175 lbm_value f_val;
4176 lbm_pop_2(&ctx->K, &stream ,&f_val);
4177
4178 uint32_t flags = lbm_dec_as_u32(f_val);
4179 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4180 ctx->flags |= (flags & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4181
4182 lbm_char_channel_t *str = lbm_dec_channel(stream);
4183 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4184 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4185 }
4186
4187 lbm_channel_reader_close(str);
4188 if (lbm_is_symbol(ctx->r)) {
4189 lbm_uint sym_val = lbm_dec_sym(ctx->r);
4190 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
4191 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
4192 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4193 }
4194 }
4195
4196 ctx->row0 = -1;
4197 ctx->row1 = -1;
4198 ctx->app_cont = true1;
4199}
4200
4201static void cont_read_quote_result(eval_context_t *ctx) {
4202 lbm_value cell;
4203 WITH_GC(cell, lbm_heap_allocate_list_init(2,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4204 ENC_SYM_QUOTE,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4205 ctx->r))(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
};
4206 ctx->r = cell;
4207 ctx->app_cont = true1;
4208}
4209
4210static void cont_read_commaat_result(eval_context_t *ctx) {
4211 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4212 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4213 ctx->r = cell1;
4214 ctx->app_cont = true1;
4215}
4216
4217static void cont_read_comma_result(eval_context_t *ctx) {
4218 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u),ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4219 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4220 ctx->r = cell1;
4221 ctx->app_cont = true1;
4222}
4223
4224static void cont_application_start(eval_context_t *ctx) {
4225
4226 /* sptr[0] = env
4227 * sptr[1] = args
4228 * ctx->r = function
4229 */
4230
4231 if (lbm_is_symbol(ctx->r)) {
1
Calling 'lbm_is_symbol'
→
4
←
Returning from 'lbm_is_symbol'
→
5
←
Taking false branch
→
4232 stack_reserve(ctx,1)[0] = lbm_enc_u(0);
4233 cont_application_args(ctx);
4234 } else if (lbm_is_cons(ctx->r)) {
6
←
Calling 'lbm_is_cons'
→
10
←
Returning from 'lbm_is_cons'
→
11
←
Taking true branch
→
4235 lbm_uint *sptr = get_stack_ptr(ctx, 2);
4236 lbm_value args = (lbm_value)sptr[1];
4237 switch (get_car(ctx->r)) {
12
←
Calling 'get_car'
→
15
←
Returning from 'get_car'
→
16
←
Control jumps to 'case 4320:' at line 4274
→
4238 case ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u): {
4239 lbm_value cl[3];
4240 extract_n(get_cdr(ctx->r), cl, 3);
4241 lbm_value arg_env = (lbm_value)sptr[0];
4242 lbm_value arg0, arg_rest;
4243 get_car_and_cdr(args, &arg0, &arg_rest);
4244 sptr[1] = cl[CLO_BODY1];
4245 bool_Bool a_nil = lbm_is_symbol_nil(args);
4246 bool_Bool p_nil = lbm_is_symbol_nil(cl[CLO_PARAMS0]);
4247 lbm_value *reserved = stack_reserve(ctx, 4);
4248
4249 if (!a_nil && !p_nil) {
4250 reserved[0] = cl[CLO_ENV2];
4251 reserved[1] = cl[CLO_PARAMS0];
4252 reserved[2] = arg_rest;
4253 reserved[3] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
4254 ctx->curr_exp = arg0;
4255 ctx->curr_env = arg_env;
4256 } else if (a_nil && p_nil) {
4257 // No params, No args
4258 lbm_stack_drop(&ctx->K, 6);
4259 ctx->curr_exp = cl[CLO_BODY1];
4260 ctx->curr_env = cl[CLO_ENV2];
4261 } else if (p_nil) {
4262 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), cl[CLO_ENV2]);
4263 reserved[0] = rest_binder;
4264 reserved[1] = get_cdr(args);
4265 reserved[2] = get_car(rest_binder);
4266 reserved[3] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
4267 ctx->curr_exp = get_car(args);
4268 ctx->curr_env = arg_env;
4269 } else {
4270 lbm_set_error_reason((char*)lbm_error_str_num_args);
4271 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->r);
4272 }
4273 } break;
4274 case ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u):{
4275 /* Continuation created using call-cc.
4276 * ((SYM_CONT . cont-array) arg0 )
4277 */
4278 lbm_value c = get_cdr(ctx->r); /* should be the continuation array*/
17
←
Calling 'get_cdr'
→
21
←
Returning from 'get_cdr'
→
22
←
'c' initialized here
→
4279
4280 if (!lbm_is_lisp_array_r(c)) {
23
←
Taking false branch
→
4281 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4282 }
4283
4284 lbm_uint arg_count = lbm_list_length(args);
4285 lbm_value arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4286 switch (arg_count) {
24
←
Control jumps to 'case 0:' at line 4287
→
4287 case 0:
4288 arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4289 break;
25
←
 Execution continues on line 4297
→
4290 case 1:
4291 arg = get_car(args);
4292 break;
4293 default:
4294 lbm_set_error_reason((char*)lbm_error_str_num_args);
4295 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4296 }
4297 lbm_stack_clear(&ctx->K);
4298
4299 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(c);
26
←
Passing value via 1st parameter 'a'
→
27
←
Calling 'get_car'
→
35
←
Returning from 'get_car'
→
36
←
'arr' initialized to a null pointer value
→
4300
4301 ctx->K.sp = arr->size / sizeof(lbm_uint);
37
←
Access to field 'size' results in a dereference of a null pointer (loaded from variable 'arr')
4302 memcpy(ctx->K.data, arr->data, arr->size);
4303
4304 ctx->curr_exp = arg;
4305 break;
4306 }
4307 case ENC_SYM_MACRO(((0x10D) << 4) | 0x00000000u):{
4308 /*
4309 * Perform macro expansion.
4310 * Macro expansion is really just evaluation in an
4311 * environment augmented with the unevaluated expressions passed
4312 * as arguments.
4313 */
4314 lbm_value env = (lbm_value)sptr[0];
4315
4316 lbm_value curr_param = get_cadr(ctx->r);
4317 lbm_value curr_arg = args;
4318 lbm_value expand_env = env;
4319 while (lbm_is_cons(curr_param) &&
4320 lbm_is_cons(curr_arg)) {
4321 lbm_value car_curr_param, cdr_curr_param;
4322 lbm_value car_curr_arg, cdr_curr_arg;
4323 get_car_and_cdr(curr_param, &car_curr_param, &cdr_curr_param);
4324 get_car_and_cdr(curr_arg, &car_curr_arg, &cdr_curr_arg);
4325
4326 lbm_value entry = cons_with_gc(car_curr_param, car_curr_arg, expand_env);
4327 lbm_value aug_env = cons_with_gc(entry, expand_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4328 expand_env = aug_env;
4329
4330 curr_param = cdr_curr_param;
4331 curr_arg = cdr_curr_arg;
4332 }
4333 /* Two rounds of evaluation is performed.
4334 * First to instantiate the arguments into the macro body.
4335 * Second to evaluate the resulting program.
4336 */
4337 sptr[1] = EVAL_R(((11) << 2) | 0xF8000001u);
4338 lbm_value exp = get_cadr(get_cdr(ctx->r));
4339 ctx->curr_exp = exp;
4340 ctx->curr_env = expand_env;
4341 } break;
4342 default:
4343 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4344 }
4345 } else {
4346 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4347 }
4348}
4349
4350static void cont_eval_r(eval_context_t* ctx) {
4351 lbm_value env;
4352 lbm_pop(&ctx->K, &env);
4353 ctx->curr_exp = ctx->r;
4354 ctx->curr_env = env;
4355}
4356
4357static void cont_progn_var(eval_context_t* ctx) {
4358
4359 lbm_value key;
4360 lbm_value env;
4361
4362 lbm_pop_2(&ctx->K, &key, &env);
4363
4364 if (fill_binding_location(key, ctx->r, env) < 0) {
4365 lbm_set_error_reason("Incorrect type of name/key in let-binding");
4366 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
4367 }
4368
4369 ctx->app_cont = true1;
4370}
4371
4372static void cont_setq(eval_context_t *ctx) {
4373 lbm_value sym;
4374 lbm_value env;
4375 lbm_pop_2(&ctx->K, &sym, &env);
4376 lbm_value res;
4377 WITH_GC(res, perform_setvar(sym, ctx->r, env))(res) = (perform_setvar(sym, ctx->r, env)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (perform_setvar(sym, ctx->r, env)
); if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
4378 ctx->r = res;
4379 ctx->app_cont = true1;
4380}
4381
4382lbm_flash_status request_flash_storage_cell(lbm_value val, lbm_value *res) {
4383
4384 lbm_value flash_cell;
4385 lbm_flash_status s = lbm_allocate_const_cell(&flash_cell);
4386 if (s != LBM_FLASH_WRITE_OK)
4387 return s;
4388 lbm_value new_val = val;
4389 new_val &= ~LBM_PTR_VAL_MASK0x03FFFFFCu; // clear the value part of the ptr
4390 new_val |= (flash_cell & LBM_PTR_VAL_MASK0x03FFFFFCu);
4391 new_val |= LBM_PTR_TO_CONSTANT_BIT0x04000000u;
4392 *res = new_val;
4393 return s;
4394}
4395
4396static void cont_move_to_flash(eval_context_t *ctx) {
4397
4398 lbm_value args;
4399 lbm_pop(&ctx->K, &args);
4400
4401 if (lbm_is_symbol_nil(args)) {
4402 // Done looping over arguments. return true.
4403 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
4404 ctx->app_cont = true1;
4405 return;
4406 }
4407
4408 lbm_value first_arg, rest;
4409 get_car_and_cdr(args, &first_arg, &rest);
4410
4411 lbm_value val;
4412 if (lbm_is_symbol(first_arg) && lbm_global_env_lookup(&val, first_arg)) {
4413 // Prepare to copy the rest of the arguments when done with first.
4414 lbm_value *rptr = stack_reserve(ctx, 2);
4415 rptr[0] = rest;
4416 rptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
4417 if (lbm_is_ptr(val) &&
4418 (!(val & LBM_PTR_TO_CONSTANT_BIT0x04000000u))) {
4419 lbm_value * rptr1 = stack_reserve(ctx, 3);
4420 rptr1[0] = first_arg;
4421 rptr1[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
4422 rptr1[2] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4423 ctx->r = val;
4424 }
4425 ctx->app_cont = true1;
4426 return;
4427 }
4428 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4429}
4430
4431static void cont_move_val_to_flash_dispatch(eval_context_t *ctx) {
4432
4433 lbm_value val = ctx->r;
4434
4435 if (lbm_is_cons(val)) {
4436 lbm_value *rptr = stack_reserve(ctx, 5);
4437 rptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // fst cell of list
4438 rptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last cell of list
4439 rptr[2] = get_cdr(val);
4440 rptr[3] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4441 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4442 ctx->r = get_car(val);
4443 ctx->app_cont = true1;
4444 return;
4445 }
4446
4447 if (lbm_is_ptr(val) && (val & LBM_PTR_TO_CONSTANT_BIT0x04000000u)) {
4448 ctx->r = val;
4449 ctx->app_cont = true1;
4450 return;
4451 }
4452
4453 if (lbm_is_ptr(val)) {
4454 lbm_cons_t *ref = lbm_ref_cell(val);
4455 if (lbm_type_of(ref->cdr) == LBM_TYPE_SYMBOL0x00000000u) {
4456 switch (ref->cdr) {
4457 case ENC_SYM_RAW_I_TYPE(((0x31) << 4) | 0x00000000u): /* fall through */
4458 case ENC_SYM_RAW_U_TYPE(((0x32) << 4) | 0x00000000u):
4459 case ENC_SYM_RAW_F_TYPE(((0x33) << 4) | 0x00000000u): {
4460 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4461 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4462 handle_flash_status(write_const_car(flash_cell, ref->car));
4463 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4464 ctx->r = flash_cell;
4465 } break;
4466 case ENC_SYM_IND_I_TYPE(((0x34) << 4) | 0x00000000u): /* fall through */
4467 case ENC_SYM_IND_U_TYPE(((0x35) << 4) | 0x00000000u):
4468 case ENC_SYM_IND_F_TYPE(((0x36) << 4) | 0x00000000u): {
4469#ifndef LBM64
4470 /* 64 bit values are in lbm mem on 32bit platforms. */
4471 lbm_uint *lbm_mem_ptr = (lbm_uint*)ref->car;
4472 lbm_uint flash_ptr;
4473
4474 handle_flash_status(lbm_write_const_raw(lbm_mem_ptr, 2, &flash_ptr));
4475 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4476 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4477 handle_flash_status(write_const_car(flash_cell, flash_ptr));
4478 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4479 ctx->r = flash_cell;
4480#else
4481 // There are no indirect types in LBM64
4482 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4483#endif
4484 } break;
4485 case ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u): {
4486 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4487 lbm_uint size = arr->size / sizeof(lbm_uint);
4488 lbm_uint flash_addr;
4489 lbm_value *arrdata = (lbm_value *)arr->data;
4490 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4491 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4492 handle_flash_status(lbm_allocate_const_raw(size, &flash_addr));
4493 lift_array_flash(flash_cell,
4494 false0,
4495 (char *)flash_addr,
4496 arr->size);
4497 // Move array contents to flash recursively
4498 lbm_value *rptr = stack_reserve(ctx, 5);
4499 rptr[0] = flash_cell;
4500 rptr[1] = lbm_enc_u(0);
4501 rptr[2] = val;
4502 rptr[3] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4503 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4504 ctx->r = arrdata[0];
4505 ctx->app_cont = true1;
4506 return;
4507 }
4508 case ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u): {
4509 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4510 // arbitrary address: flash_arr.
4511 lbm_uint flash_arr;
4512 handle_flash_status(lbm_write_const_array_padded((uint8_t*)arr->data, arr->size, &flash_arr));
4513 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4514 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4515 lift_array_flash(flash_cell,
4516 true1,
4517 (char *)flash_arr,
4518 arr->size);
4519 ctx->r = flash_cell;
4520 } break;
4521 case ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u): /* fall through */
4522 case ENC_SYM_CUSTOM_TYPE(((0x38) << 4) | 0x00000000u):
4523 lbm_set_error_reason((char *)lbm_error_str_flash_not_possible);
4524 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4525 }
4526 } else {
4527 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4528 }
4529 ctx->app_cont = true1;
4530 return;
4531 }
4532 ctx->r = val;
4533 ctx->app_cont = true1;
4534}
4535
4536static void cont_move_list_to_flash(eval_context_t *ctx) {
4537
4538 // ctx->r holds the value that should go in car
4539
4540 lbm_value *sptr = get_stack_ptr(ctx, 3);
4541
4542 lbm_value fst = sptr[0];
4543 lbm_value lst = sptr[1];
4544 lbm_value val = sptr[2];
4545
4546
4547 lbm_value new_lst = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4548 // Allocate element ptr storage after storing the element to flash.
4549 handle_flash_status(request_flash_storage_cell(lbm_enc_cons_ptr(LBM_PTR_NULL(0x03FFFFFCu >> 2)), &new_lst));
4550
4551 if (lbm_is_symbol_nil(fst)) {
4552 lst = new_lst;
4553 fst = new_lst;
4554 handle_flash_status(write_const_car(lst, ctx->r));
4555 } else {
4556 handle_flash_status(write_const_cdr(lst, new_lst)); // low before high
4557 handle_flash_status(write_const_car(new_lst, ctx->r));
4558 lst = new_lst;
4559 }
4560
4561 if (lbm_is_cons(val)) {
4562 sptr[0] = fst;
4563 sptr[1] = lst;//rest_cell;
4564 sptr[2] = get_cdr(val);
4565 lbm_value *rptr = stack_reserve(ctx, 2);
4566 rptr[0] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4567 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4568 ctx->r = get_car(val);
4569 } else {
4570 sptr[0] = fst;
4571 sptr[1] = lst;
4572 sptr[2] = CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u);
4573 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4574 ctx->r = val;
4575 }
4576 ctx->app_cont = true1;
4577}
4578
4579static void cont_close_list_in_flash(eval_context_t *ctx) {
4580 lbm_value fst;
4581 lbm_value lst;
4582 lbm_pop_2(&ctx->K, &lst, &fst);
4583 lbm_value val = ctx->r;
4584 handle_flash_status(write_const_cdr(lst, val));
4585 ctx->r = fst;
4586 ctx->app_cont = true1;
4587}
4588
4589static void cont_move_array_elts_to_flash(eval_context_t *ctx) {
4590 lbm_value *sptr = get_stack_ptr(ctx, 3);
4591 // sptr[2] = source array in RAM
4592 // sptr[1] = current index
4593 // sptr[0] = target array in flash
4594 lbm_array_header_t *src_arr = (lbm_array_header_t*)get_car(sptr[2]);
4595 lbm_uint size = src_arr->size / sizeof(lbm_uint);
4596 lbm_value *srcdata = (lbm_value *)src_arr->data;
4597
4598 lbm_array_header_t *tgt_arr = (lbm_array_header_t*)get_car(sptr[0]);
4599 lbm_uint *tgtdata = (lbm_value *)tgt_arr->data;
4600 lbm_uint ix = lbm_dec_as_u32(sptr[1]);
4601 handle_flash_status(lbm_const_write(&tgtdata[ix], ctx->r));
4602 if (ix >= size-1) {
4603 ctx->r = sptr[0];
4604 lbm_stack_drop(&ctx->K, 3);
4605 ctx->app_cont = true1;
4606 return;
4607 }
4608 sptr[1] = lbm_enc_u(ix + 1);
4609 lbm_value *rptr = stack_reserve(ctx, 2);
4610 rptr[0] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4611 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4612 ctx->r = srcdata[ix+1];
4613 ctx->app_cont = true1;
4614 return;
4615}
4616
4617static void cont_qq_expand_start(eval_context_t *ctx) {
4618 lbm_value *rptr = stack_reserve(ctx, 2);
4619 rptr[0] = ctx->r;
4620 rptr[1] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4621 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4622 ctx->app_cont = true1;
4623}
4624
4625lbm_value quote_it(lbm_value qquoted) {
4626 if (lbm_is_symbol(qquoted) &&
4627 lbm_is_special(qquoted)) return qquoted;
4628
4629 lbm_value val = cons_with_gc(qquoted, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4630 return cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4631}
4632
4633bool_Bool is_append(lbm_value a) {
4634 return (lbm_is_cons(a) &&
4635 lbm_is_symbol(get_car(a)) &&
4636 (get_car(a) == ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u)));
4637}
4638
4639lbm_value append(lbm_value front, lbm_value back) {
4640 if (lbm_is_symbol_nil(front)) return back;
4641 if (lbm_is_symbol_nil(back)) return front;
4642
4643 if (lbm_is_quoted_list(front) &&
4644 lbm_is_quoted_list(back)) {
4645 lbm_value f = get_cadr(front);
4646 lbm_value b = get_cadr(back);
4647 return quote_it(lbm_list_append(f, b));
4648 }
4649
4650 if (is_append(back) &&
4651 lbm_is_quoted_list(get_cadr(back)) &&
4652 lbm_is_quoted_list(front)) {
4653 lbm_value ql = get_cadr(back);
4654 lbm_value f = get_cadr(front);
4655 lbm_value b = get_cadr(ql);
4656
4657 lbm_value v = lbm_list_append(f, b);
4658 lbm_set_car(get_cdr(ql), v);
4659 return back;
4660 }
4661
4662 if (is_append(back)) {
4663 back = get_cdr(back);
4664 lbm_value new = cons_with_gc(front, back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4665 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), new, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4666 }
4667
4668 lbm_value t0, t1;
4669
4670 t0 = cons_with_gc(back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), front);
4671 t1 = cons_with_gc(front, t0, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4672 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), t1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4673}
4674
4675/* Bawden's qq-expand implementation
4676(define (qq-expand x)
4677 (cond ((tag-comma? x)
4678 (tag-data x))
4679 ((tag-comma-atsign? x)
4680 (error "Illegal"))
4681 ((tag-backquote? x)
4682 (qq-expand
4683 (qq-expand (tag-data x))))
4684 ((pair? x)
4685 `(append
4686 ,(qq-expand-list (car x))
4687 ,(qq-expand (cdr x))))
4688 (else `',x)))
4689 */
4690static void cont_qq_expand(eval_context_t *ctx) {
4691 lbm_value qquoted;
4692 lbm_pop(&ctx->K, &qquoted);
4693
4694 switch(lbm_type_of(qquoted)) {
4695 case LBM_TYPE_CONS0x10000000u: {
4696 lbm_value car_val = get_car(qquoted);
4697 lbm_value cdr_val = get_cdr(qquoted);
4698 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4699 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4700 ctx->r = append(ctx->r, get_car(cdr_val));
4701 ctx->app_cont = true1;
4702 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4703 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4704 error_ctx(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u));
4705 } else {
4706 lbm_value *rptr = stack_reserve(ctx, 6);
4707 rptr[0] = ctx->r;
4708 rptr[1] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4709 rptr[2] = cdr_val;
4710 rptr[3] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4711 rptr[4] = car_val;
4712 rptr[5] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4713 ctx->app_cont = true1;
4714 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4715 }
4716
4717 } break;
4718 default: {
4719 lbm_value res = quote_it(qquoted);
4720 ctx->r = append(ctx->r, res);
4721 ctx->app_cont = true1;
4722 }
4723 }
4724}
4725
4726static void cont_qq_append(eval_context_t *ctx) {
4727 lbm_value head;
4728 lbm_pop(&ctx->K, &head);
4729 ctx->r = append(head, ctx->r);
4730 ctx->app_cont = true1;
4731}
4732
4733/* Bawden's qq-expand-list implementation
4734(define (qq-expand-list x)
4735 (cond ((tag-comma? x)
4736 `(list ,(tag-data x)))
4737 ((tag-comma-atsign? x)
4738 (tag-data x))
4739 ((tag-backquote? x)
4740 (qq-expand-list
4741 (qq-expand (tag-data x))))
4742 ((pair? x)
4743 `(list
4744 (append
4745 ,(qq-expand-list (car x))
4746 ,(qq-expand (cdr x)))))
4747 (else `'(,x))))
4748*/
4749
4750static void cont_qq_expand_list(eval_context_t* ctx) {
4751 lbm_value l;
4752 lbm_pop(&ctx->K, &l);
4753
4754 ctx->app_cont = true1;
4755 switch(lbm_type_of(l)) {
4756 case LBM_TYPE_CONS0x10000000u: {
4757 lbm_value car_val = get_car(l);
4758 lbm_value cdr_val = get_cdr(l);
4759 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4760 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4761 lbm_value tl = cons_with_gc(get_car(cdr_val), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4762 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4763 ctx->r = append(ctx->r, tmp);
4764 return;
4765 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4766 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4767 ctx->r = get_car(cdr_val);
4768 return;
4769 } else {
4770 lbm_value *rptr = stack_reserve(ctx, 7);
4771 rptr[0] = QQ_LIST(((39) << 2) | 0xF8000001u);
4772 rptr[1] = ctx->r;
4773 rptr[2] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4774 rptr[3] = cdr_val;
4775 rptr[4] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4776 rptr[5] = car_val;
4777 rptr[6] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4778 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4779 }
4780
4781 } break;
4782 default: {
4783 lbm_value a_list = cons_with_gc(l, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4784 lbm_value tl = cons_with_gc(a_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4785 lbm_value tmp = cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4786 ctx->r = append(ctx->r, tmp);
4787 }
4788 }
4789}
4790
4791static void cont_qq_list(eval_context_t *ctx) {
4792 lbm_value val = ctx->r;
4793 lbm_value apnd_app = cons_with_gc(val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4794 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), apnd_app, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4795 ctx->r = tmp;
4796 ctx->app_cont = true1;
4797}
4798
4799static void cont_kill(eval_context_t *ctx) {
4800 (void) ctx;
4801 finish_ctx();
4802}
4803
4804static void cont_pop_reader_flags(eval_context_t *ctx) {
4805 lbm_value flags;
4806 lbm_pop(&ctx->K, &flags);
4807 ctx->flags = ctx->flags & ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4808 ctx->flags |= (lbm_dec_as_u32(flags) & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4809 // r is unchanged.
4810 ctx->app_cont = true1;
4811}
4812
4813static void cont_exception_handler(eval_context_t *ctx) {
4814 lbm_value *sptr = pop_stack_ptr(ctx, 2);
4815 lbm_value retval = sptr[0];
4816 lbm_value flags = sptr[1];
4817 lbm_set_car(get_cdr(retval), ctx->r);
4818 ctx->flags = flags;
4819 ctx->r = retval;
4820 ctx->app_cont = true1;
4821}
4822
4823/*********************************************************/
4824/* Continuations table */
4825typedef void (*cont_fun)(eval_context_t *);
4826
4827static const cont_fun continuations[NUM_CONTINUATIONS49] =
4828 { advance_ctx, // CONT_DONE
4829 cont_set_global_env,
4830 cont_bind_to_key_rest,
4831 cont_if,
4832 cont_progn_rest,
4833 cont_application_args,
4834 cont_and,
4835 cont_or,
4836 cont_wait,
4837 cont_match,
4838 cont_application_start,
4839 cont_eval_r,
4840 cont_resume,
4841 cont_closure_application_args,
4842 cont_exit_atomic,
4843 cont_read_next_token,
4844 cont_read_append_continue,
4845 cont_read_eval_continue,
4846 cont_read_expect_closepar,
4847 cont_read_dot_terminate,
4848 cont_read_done,
4849 cont_read_quote_result,
4850 cont_read_commaat_result,
4851 cont_read_comma_result,
4852 cont_read_start_array,
4853 cont_read_append_array,
4854 cont_map,
4855 cont_match_guard,
4856 cont_terminate,
4857 cont_progn_var,
4858 cont_setq,
4859 cont_move_to_flash,
4860 cont_move_val_to_flash_dispatch,
4861 cont_move_list_to_flash,
4862 cont_close_list_in_flash,
4863 cont_qq_expand_start,
4864 cont_qq_expand,
4865 cont_qq_append,
4866 cont_qq_expand_list,
4867 cont_qq_list,
4868 cont_kill,
4869 cont_loop,
4870 cont_loop_condition,
4871 cont_merge_rest,
4872 cont_merge_layer,
4873 cont_closure_args_rest,
4874 cont_move_array_elts_to_flash,
4875 cont_pop_reader_flags,
4876 cont_exception_handler
4877 };
4878
4879/*********************************************************/
4880/* Evaluators lookup table (special forms) */
4881typedef void (*evaluator_fun)(eval_context_t *);
4882
4883static const evaluator_fun evaluators[] =
4884 {
4885 eval_quote,
4886 eval_define,
4887 eval_progn,
4888 eval_lambda,
4889 eval_if,
4890 eval_let,
4891 eval_and,
4892 eval_or,
4893 eval_match,
4894 eval_receive,
4895 eval_receive_timeout,
4896 eval_callcc,
4897 eval_atomic,
4898 eval_selfevaluating, // macro
4899 eval_selfevaluating, // cont
4900 eval_selfevaluating, // closure
4901 eval_cond,
4902 eval_app_cont,
4903 eval_var,
4904 eval_setq,
4905 eval_move_to_flash,
4906 eval_loop,
4907 eval_trap
4908 };
4909
4910
4911/*********************************************************/
4912/* Evaluator step function */
4913
4914static void evaluation_step(void){
4915 eval_context_t *ctx = ctx_running;
4916#ifdef VISUALIZE_HEAP
4917 heap_vis_gen_image();
4918#endif
4919
4920 if (ctx->app_cont) {
4921 lbm_value k;
4922 lbm_pop(&ctx->K, &k);
4923 ctx->app_cont = false0;
4924
4925 lbm_uint decoded_k = DEC_CONTINUATION(k)(((k) & ~0xF8000001u) >> 2);
4926
4927 if (decoded_k < NUM_CONTINUATIONS49) {
4928 continuations[decoded_k](ctx);
4929 } else {
4930 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4931 }
4932 return;
4933 }
4934
4935 if (lbm_is_symbol(ctx->curr_exp)) {
4936 eval_symbol(ctx);
4937 return;
4938 }
4939 if (lbm_is_cons(ctx->curr_exp)) {
4940 lbm_cons_t *cell = lbm_ref_cell(ctx->curr_exp);
4941 lbm_value h = cell->car;
4942 if (lbm_is_symbol(h) && ((h & ENC_SPECIAL_FORMS_MASK0xFFFFF000) == ENC_SPECIAL_FORMS_BIT0x00001000)) {
4943 lbm_uint eval_index = lbm_dec_sym(h) & SPECIAL_FORMS_INDEX_MASK0x000000FF;
4944 evaluators[eval_index](ctx);
4945 return;
4946 }
4947 /*
4948 * At this point head can be anything. It should evaluate
4949 * into a form that can be applied (closure, symbol, ...) though.
4950 */
4951 lbm_value *reserved = stack_reserve(ctx, 3);
4952 reserved[0] = ctx->curr_env;
4953 reserved[1] = cell->cdr;
4954 reserved[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
4955 ctx->curr_exp = h; // evaluate the function
4956 return;
4957 }
4958
4959 eval_selfevaluating(ctx);
4960 return;
4961}
4962
4963void lbm_pause_eval(void ) {
4964 eval_cps_next_state_arg = 0;
4965 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4966 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4967}
4968
4969void lbm_pause_eval_with_gc(uint32_t num_free) {
4970 eval_cps_next_state_arg = num_free;
4971 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4972 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4973}
4974
4975void lbm_continue_eval(void) {
4976 eval_cps_next_state = EVAL_CPS_STATE_RUNNING2;
4977 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4978}
4979
4980void lbm_kill_eval(void) {
4981 eval_cps_next_state = EVAL_CPS_STATE_KILL4;
4982 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4983}
4984
4985uint32_t lbm_get_eval_state(void) {
4986 return eval_cps_run_state;
4987}
4988
4989// Will wake up thread that is sleeping as well.
4990// Not sure this is good behavior.
4991static void handle_event_unblock_ctx(lbm_cid cid, lbm_value v) {
4992 eval_context_t *found = NULL((void*)0);
4993 mutex_lock(&qmutex);
4994
4995 found = lookup_ctx_nm(&blocked, cid);
4996 if (found) {
4997 drop_ctx_nm(&blocked,found);
4998 if (lbm_is_error(v)) {
4999 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
5000 found->app_cont = true1;
5001 }
5002 found->r = v;
5003 enqueue_ctx_nm(&queue,found);
5004 }
5005 mutex_unlock(&qmutex);
5006}
5007
5008static void handle_event_define(lbm_value key, lbm_value val) {
5009 lbm_uint dec_key = lbm_dec_sym(key);
5010 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
5011 lbm_value *global_env = lbm_get_global_env();
5012 lbm_uint orig_env = global_env[ix_key];
5013 lbm_value new_env;
5014 // A key is a symbol and should not need to be remembered.
5015 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
5016
5017 global_env[ix_key] = new_env;
5018}
5019
5020static lbm_value get_event_value(lbm_event_t *e) {
5021 lbm_value v;
5022 if (e->buf_len > 0) {
5023 lbm_flat_value_t fv;
5024 fv.buf = (uint8_t*)e->buf_ptr;
5025 fv.buf_size = e->buf_len;
5026 fv.buf_pos = 0;
5027 if (!lbm_unflatten_value(&fv, &v)) {
5028 lbm_set_flags(LBM_FLAG_HANDLER_EVENT_DELIVERY_FAILED(1 << 1));
5029 v = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
5030 }
5031 // Free the flat value buffer. GC is unaware of its existence.
5032 lbm_free(fv.buf);
5033 } else {
5034 v = (lbm_value)e->buf_ptr;
5035 }
5036 return v;
5037}
5038
5039static void process_events(void) {
5040
5041 if (!lbm_events) return;
5042 lbm_event_t e;
5043
5044 while (lbm_event_pop(&e)) {
5045
5046 lbm_value event_val = get_event_value(&e);
5047 switch(e.type) {
5048 case LBM_EVENT_UNBLOCK_CTX:
5049 handle_event_unblock_ctx((lbm_cid)e.parameter, event_val);
5050 break;
5051 case LBM_EVENT_DEFINE:
5052 handle_event_define((lbm_value)e.parameter, event_val);
5053 break;
5054 case LBM_EVENT_FOR_HANDLER:
5055 if (lbm_event_handler_pid >= 0) {
5056 lbm_find_receiver_and_send(lbm_event_handler_pid, event_val);
5057 }
5058 break;
5059 }
5060 }
5061}
5062
5063/* eval_cps_run can be paused
5064 I think it would be better use a mailbox for
5065 communication between other threads and the run_eval
5066 but for now a set of variables will be used. */
5067void lbm_run_eval(void){
5068
5069 if (setjmp(critical_error_jmp_buf)_setjmp (critical_error_jmp_buf) > 0) {
5070 printf_callback("GC stack overflow!\n");
5071 critical_error_callback();
5072 // terminate evaluation thread.
5073 return;
5074 }
5075
5076 setjmp(error_jmp_buf)_setjmp (error_jmp_buf);
5077
5078 while (eval_running) {
5079 if (eval_cps_state_changed || eval_cps_run_state == EVAL_CPS_STATE_PAUSED1) {
5080 eval_cps_state_changed = false0;
5081 switch (eval_cps_next_state) {
5082 case EVAL_CPS_STATE_PAUSED1:
5083 if (eval_cps_run_state != EVAL_CPS_STATE_PAUSED1) {
5084 if (lbm_heap_num_free() < eval_cps_next_state_arg) {
5085 gc();
5086 }
5087 eval_cps_next_state_arg = 0;
5088 }
5089 eval_cps_run_state = EVAL_CPS_STATE_PAUSED1;
5090 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5091 continue; /* jump back to start of eval_running loop */
5092 case EVAL_CPS_STATE_KILL4:
5093 eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
5094 eval_running = false0;
5095 continue;
5096 default: // running state
5097 eval_cps_run_state = eval_cps_next_state;
5098 break;
5099 }
5100 }
5101 while (true1) {
5102 if (eval_steps_quota && ctx_running) {
5103 eval_steps_quota--;
5104 evaluation_step();
5105 } else {
5106 if (eval_cps_state_changed) break;
5107 eval_steps_quota = eval_steps_refill;
5108 if (is_atomic) {
5109 if (!ctx_running) {
5110 lbm_set_flags(LBM_FLAG_ATOMIC_MALFUNCTION(1 << 0));
5111 is_atomic = 0;
5112 }
5113 } else {
5114 if (gc_requested) {
5115 gc();
5116 }
5117 process_events();
5118 mutex_lock(&qmutex);
5119 if (ctx_running) {
5120 enqueue_ctx_nm(&queue, ctx_running);
5121 ctx_running = NULL((void*)0);
5122 }
5123 wake_up_ctxs_nm();
5124 ctx_running = dequeue_ctx_nm(&queue);
5125 mutex_unlock(&qmutex);
5126 if (!ctx_running) {
5127 lbm_system_sleeping = true1;
5128 //Fixed sleep interval to poll events regularly.
5129 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5130 lbm_system_sleeping = false0;
5131 }
5132 }
5133 }
5134 }
5135 }
5136}
5137
5138lbm_cid lbm_eval_program(lbm_value lisp) {
5139 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), 256, NULL((void*)0));
5140}
5141
5142lbm_cid lbm_eval_program_ext(lbm_value lisp, unsigned int stack_size) {
5143 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), stack_size, NULL((void*)0));
5144}
5145
5146int lbm_eval_init() {
5147 if (!qmutex_initialized) {
5148 mutex_init(&qmutex);
5149 qmutex_initialized = true1;
5150 }
5151 if (!lbm_events_mutex_initialized) {
5152 mutex_init(&lbm_events_mutex);
5153 lbm_events_mutex_initialized = true1;
5154 }
5155 if (!blocking_extension_mutex_initialized) {
5156 mutex_init(&blocking_extension_mutex);
5157 blocking_extension_mutex_initialized = true1;
5158 }
5159
5160 mutex_lock(&qmutex);
5161 mutex_lock(&lbm_events_mutex);
5162
5163 blocked.first = NULL((void*)0);
5164 blocked.last = NULL((void*)0);
5165 queue.first = NULL((void*)0);
5166 queue.last = NULL((void*)0);
5167 ctx_running = NULL((void*)0);
5168
5169 eval_cps_run_state = EVAL_CPS_STATE_RUNNING2;
5170
5171 mutex_unlock(&lbm_events_mutex);
5172 mutex_unlock(&qmutex);
5173
5174 if (!lbm_init_env()) return 0;
5175 eval_running = true1;
5176 return 1;
5177}
5178
5179bool_Bool lbm_eval_init_events(unsigned int num_events) {
5180
5181 mutex_lock(&lbm_events_mutex);
5182 lbm_events = (lbm_event_t*)lbm_malloc(num_events * sizeof(lbm_event_t));
5183 bool_Bool r = false0;
5184 if (lbm_events) {
5185 lbm_events_max = num_events;
5186 lbm_events_head = 0;
5187 lbm_events_tail = 0;
5188 lbm_events_full = false0;
5189 lbm_event_handler_pid = -1;
5190 r = true1;
5191 }
5192 mutex_unlock(&lbm_events_mutex);
5193 return r;
5194}
+
+
←

./include/heap.h

+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1
2/*
3 Copyright 2018, 2024 Joel Svensson svenssonjoel@yahoo.se
4
5 This program is free software: you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation, either version 3 of the License, or
8 (at your option) any later version.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
14
15 You should have received a copy of the GNU General Public License
16 along with this program. If not, see <http://www.gnu.org/licenses/>.
17*/
18/** \file heap.h */
19
20#ifndef HEAP_H_
21#define HEAP_H_
22
23#include <string.h>
24#include <stdarg.h>
25
26#include "lbm_types.h"
27#include "symrepr.h"
28#include "stack.h"
29#include "lbm_memory.h"
30#include "lbm_defines.h"
31#include "lbm_channel.h"
32
33#ifdef __cplusplus
34extern "C" {
35#endif
36
37/*
38Planning for a more space efficient heap representation.
39TODO: Need to find a good reference to read up on this.
40 - List based heap
41 - Easy to implement and somewhat efficient
42
430000 0000 Size Free bits
44003F FFFF 4MB 10
45007F FFFF 8MB 9
4600FF FFFF 16MB 8
4701FF FFFF 32MB 7
4803FF FFFF 64MB 6 * Kind of heap size I am looking for
4907FF FFFF 128MB 5
500FFF FFFF 256MB 4
511FFF FFFF 512MB 3
52
53
54--- May 9 2021 ---
55Actually now I am much more interested in way smaller memories ;)
56
570000 0000 Size Free bits
580000 0FFF 4KB 20 |
590000 1FFF 8KB 19 |
600000 3FFF 16KB 18 |
610000 7FFF 32KB 17 |
620000 FFFF 64KB 16 |
630001 FFFF 128KB 15 |
640003 FFFF 256KB 14 | - This range is very interesting.
650007 FFFF 512KB 13
66000F FFFF 1MB 12
67001F FFFF 2MB 11
68003F FFFF 4MB 10
69007F FFFF 8MB 9
7000FF FFFF 16MB 8
7101FF FFFF 32MB 7
7203FF FFFF 64MB 6
7307FF FFFF 128MB 5
740FFF FFFF 256MB 4
751FFF FFFF 512MB 3
76
77Those are the kind of platforms that are fun... so a bunch of
78wasted bits in heap pointers if we run on small MCUs.
79
80-----------------
81
82it is also the case that not all addresses will be used if all "cells" are
83of the same size, 8 bytes...
84
85value 0: 0000 0000
86value 1: 0000 0008
87value 3: 0000 0010
88value 4: 0000 0018
89
90Means bits 0,1,2 will always be empty in a valid address.
91
92Cons cells also need to be have room for 2 pointers. So each ted cell from
93memory should be 8bytes.
94
95Things that needs to be represented within these bits:
96
97 - GC MARK one per cell
98 - TYPE: type of CAR and type of cons
99
100Types I would want:
101 - Full 32bit integer. Does not leave room for identification of type
102 - Float values. Same problem
103
104
105Free bits in pointers 64MB heap:
10631 30 29 28 27 26 2 1 0
1070 0 0 0 0 0 XX XXXX XXXX XXXX XXXX XXXX X 0 0 0
108
109
110Information needed for each cell:
111 Meaning | bits total | bits per car | bits per cdr
112 GC mark | 2 | 1 | 1 - only one of them will be used (the other is wasted)
113 Type | 2x | x | x
114 Ptr/!ptr | 2 | 1 | 1
115
116
117Types (unboxed):
118 - Symbols
119 - 28bit integer ( will need signed shift right functionality )
120 - 28bit unsigned integer
121 - Character
122
123If four types is all that should be possible (unboxed). then 2 bits are needed to differentiate.
1242 + 1 + 1 = 4 => 28bits for data.
125
126bit 0: ptr/!ptr
127bit 1: gc
128bit 2-3: type (if not ptr)
129bit 3 - 24 ptr (if ptr)
130bit 4 - 31 value (if value)
131
132An unboxed value can occupy a car or cdr field in a cons cell.
133
134types (boxed) extra information in pointer to cell can contain information
135 - 32 bit integer
136 - 32 bit unsigned integer
137 - 32 bit float
138
139boxed representation:
140 [ptr| cdr]
141 |
142 [Value | Aux + GC_MARK]
143
144Kinds of pointers:
145 - Pointer to cons cell.
146 - Pointer to unboxed value (fixnums not in a list, I hope this is so rare that it can be removed )
147 - integer
148 - unsigned integer
149 - symbol
150 - float
151 - Pointer to boxed value.
152 - 32 bit integer
153 - 32 bit unsigned integer
154 - 32 bit float
155 - (Maybe something else ? Vectors/strings allocated in memory not occupied by heap?)
156 - vector of int
157 - vector of uint
158 - vector of float
159 - vector of double
160 - String
161
16213 pointer"types" -> needs 4 bits
163for 64MB heap there are 6 free bits. So with this scheme going to 128MB or 256MB heap
164is also possible
165
166 a pointer to some off heap vector/string could be represented by
167
168 [ptr | cdr]
169 |
170 [full pointer | Aux + GC_MARK]
171 |
172 [VECTOR]
173
174Aux bits could be used for storing vector size. Up to 30bits should be available there
175>> This is problematic. Now the information that something is a vector is split up
176>> between 2 cons cells. This means GC needs both of these intact to be able to make
177>> proper decision.
178>> Will try to resolve this by adding some special symbols. But these must be symbols
179>> that cannot occur normally in programs. Then an array could be:
180
181 [Full pointer | ARRAY_SYM + GC_MARK]
182 |
183 [VECTOR]
184
185>> Boxed values same treatment as above.
186>> TODO: Could this be simpler?
187
188[ VALUE | TYPE_SYM + GC_MARK]
189
190
1910000 00XX XXXX XXXX XXXX XXXX XXXX X000 : 0x03FF FFF8
1921111 AA00 0000 0000 0000 0000 0000 0000 : 0xFC00 0000 (AA bits left unused for now, future heap growth?)
193 */
194
195typedef enum {
196 LBM_FLASH_WRITE_OK,
197 LBM_FLASH_FULL,
198 LBM_FLASH_WRITE_ERROR
199} lbm_flash_status;
200
201/** Struct representing a heap cons-cell.
202 *
203 */
204typedef struct {
205 lbm_value car;
206 lbm_value cdr;
207} lbm_cons_t;
208
209/**
210 * Heap state
211 */
212typedef struct {
213 lbm_cons_t *heap;
214 lbm_value freelist; // list of free cons cells.
215 lbm_stack_t gc_stack;
216
217 lbm_uint heap_size; // In number of cells.
218 lbm_uint heap_bytes; // In bytes.
219
220 lbm_uint num_alloc; // Number of cells allocated.
221 lbm_uint num_alloc_arrays; // Number of arrays allocated.
222
223 lbm_uint gc_num; // Number of times gc has been performed.
224 lbm_uint gc_marked; // Number of cells marked by mark phase.
225 lbm_uint gc_recovered; // Number of cells recovered by sweep phase.
226 lbm_uint gc_recovered_arrays;// Number of arrays recovered by sweep.
227 lbm_uint gc_least_free; // The smallest length of the freelist.
228 lbm_uint gc_last_free; // Number of elements on the freelist
229 // after most recent GC.
230} lbm_heap_state_t;
231
232extern lbm_heap_state_t lbm_heap_state;
233
234typedef bool_Bool (*const_heap_write_fun)(lbm_uint ix, lbm_uint w);
235
236typedef struct {
237 lbm_uint *heap;
238 lbm_uint next; // next free index.
239 lbm_uint size; // in lbm_uint words. (cons-cells = words / 2)
240} lbm_const_heap_t;
241
242/**
243 * The header portion of an array stored in array and symbol memory.
244 * An array is always a byte array. use the array-extensions for
245 * storing and reading larger values from arrays.
246 */
247typedef struct {
248 lbm_uint size; /// Number of elements
249 lbm_uint *data; /// pointer to lbm_memory array or C array.
250} lbm_array_header_t;
251
252typedef struct {
253 lbm_uint size;
254 lbm_uint *data;
255 uint32_t index; // Limits arrays to max 2^32-1 elements.
256} lbm_array_header_extended_t;
257
258/** Lock GC mutex
259 * Locks a mutex during GC marking when using the pointer reversal algorithm.
260 * Does nothing when using stack based GC mark.
261 */
262void lbm_gc_lock(void);
263/* Unlock GC mutex
264 */
265void lbm_gc_unlock(void);
266
267/** Initialize heap storage.
268 * \param addr Pointer to an array of lbm_cons_t elements. This array must at least be aligned 4.
269 * \param num_cells Number of lbm_cons_t elements in the array.
270 * \param gc_stack_size Size of the gc_stack in number of words.
271 * \return 1 on success or 0 for failure.
272 */
273int lbm_heap_init(lbm_cons_t *addr, lbm_uint num_cells,
274 lbm_uint gc_stack_size);
275
276/** Add GC time statistics to heap_stats
277 *
278 * \param dur Duration as reported by the timestamp callback.
279 */
280void lbm_heap_new_gc_time(lbm_uint dur);
281/** Add a new free_list length to the heap_stats.
282 * Calculates a new freelist length and updates
283 * the GC statistics.
284 */
285void lbm_heap_new_freelist_length(void);
286/** Check how many lbm_cons_t cells are on the free-list
287 *
288 * \return Number of free lbm_cons_t cells.
289 */
290lbm_uint lbm_heap_num_free(void);
291/** Check how many lbm_cons_t cells are allocated.
292 *
293 * \return Number of lbm_cons_t cells that are currently allocated.
294 */
295lbm_uint lbm_heap_num_allocated(void);
296/** Size of the heap in number of lbm_cons_t cells.
297 *
298 * \return Size of the heap in number of lbm_cons_t cells.
299 */
300lbm_uint lbm_heap_size(void);
301/** Size of the heap in bytes.
302 *
303 * \return Size of heap in bytes.
304 */
305lbm_uint lbm_heap_size_bytes(void);
306/** Allocate an lbm_cons_t cell from the heap.
307 *
308 * \param type A type that can be encoded onto the cell (most often LBM_PTR_TYPE_CONS).
309 * \param car Value to write into car position of allocated cell.
310 * \param cdr Value to write into cdr position of allocated cell.
311 * \return An lbm_value referring to a cons_cell or enc_sym(SYM_MERROR) in case the heap is full.
312 */
313lbm_value lbm_heap_allocate_cell(lbm_type type, lbm_value car, lbm_value cdr);
314/** Allocate a list of n heap-cells.
315 * \param n The number of heap-cells to allocate.
316 * \return A list of heap-cells of Memory error if unable to allocate.
317 */
318lbm_value lbm_heap_allocate_list(lbm_uint n);
319/** Allocate a list of n heap-cells and initialize the values.
320 * \pram ls The result list is passed through this ptr.
321 * \param n The length of list to allocate.
322 * \param valist The values in a va_list to initialize the list with.
323 * \return True of False depending on success of allocation.
324 */
325lbm_value lbm_heap_allocate_list_init_va(unsigned int n, va_list valist);
326/** Allocate a list of n heap-cells and initialize the values.
327 * \param n The length of list to allocate.
328 * \param ... The values to initialize the list with.
329 * \return allocated list or error symbol.
330 */
331lbm_value lbm_heap_allocate_list_init(unsigned int n, ...);
332/** Decode an lbm_value representing a string into a C string
333 *
334 * \param val Value
335 * \return allocated list or error symbol
336 */
337char *lbm_dec_str(lbm_value val);
338/** Decode an lbm_value representing a char channel into an lbm_char_channel_t pointer.
339 *
340 * \param val Value
341 * \return A pointer to an lbm_char_channel_t or NULL if the value does not encode a channel.
342 */
343lbm_char_channel_t *lbm_dec_channel(lbm_value val);
344/** Decode an lbm_value representing a custom type into a lbm_uint value.
345 *
346 * \param val Value.
347 * \return The custom type payload.
348 */
349lbm_uint lbm_dec_custom(lbm_value val);
350/** Decode a numerical value as if it is char
351 *
352 * \param val Value to decode
353 * \return The value encoded in val casted to a char. Returns 0 if val does not encode a number.
354 */
355uint8_t lbm_dec_as_char(lbm_value a);
356/** Decode a numerical value as if it is unsigned
357 *
358 * \param val Value to decode
359 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
360 */
361uint32_t lbm_dec_as_u32(lbm_value val);
362/** Decode a numerical value as a signed integer.
363 *
364 * \param val Value to decode
365 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
366 */
367int32_t lbm_dec_as_i32(lbm_value val);
368/** Decode a numerical value as a float.
369 *
370 * \param val Value to decode.
371 * \return The value encoded in val casted to a float. Returns 0 if val does not encode a number.
372 */
373float lbm_dec_as_float(lbm_value val);
374/** Decode a numerical value as if it is a 64bit unsigned
375 *
376 * \param val Value to decode
377 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
378 */
379uint64_t lbm_dec_as_u64(lbm_value val);
380/** Decode a numerical value as a 64bit signed integer.
381 *
382 * \param val Value to decode
383 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
384 */
385int64_t lbm_dec_as_i64(lbm_value val);
386/** Decode a numerical value as a float.
387 *
388 * \param val Value to decode.
389 * \return The value encoded in val casted to a float. Returns 0 if val does not encode a number.
390 */
391double lbm_dec_as_double(lbm_value val);
392
393/** Decode a numerical value into the architecture defined unsigned integer type.
394 *
395 * \param val Value to decode
396 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
397 */
398lbm_uint lbm_dec_as_uint(lbm_value val);
399
400/** Decode a numerical value into the architecture defined signed integer type.
401 *
402 * \param val Value to decode
403 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
404 */
405lbm_int lbm_dec_as_int(lbm_value val);
406
407lbm_uint lbm_dec_raw(lbm_value v);
408/** Allocates an lbm_cons_t cell from the heap and populates it.
409 *
410 * \param car The value to put in the car field of the allocated lbm_cons_t.
411 * \param cdr The value to put in the cdr field of the allocated lbm_cons_t.
412 * \return A value referencing the lbm_cons_t or enc_sym(SYM_MERROR) if heap is full.
413 */
414lbm_value lbm_cons(lbm_value car, lbm_value cdr);
415
416/** Accesses the car field of an lbm_cons_t.
417 *
418 * \param cons Value
419 * \return The car field of the lbm_cons_t if cons is a reference to a heap cell.
420 * If cons is nil, the return value is nil. If the value
421 * is not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
422 */
423lbm_value lbm_car(lbm_value cons);
424/** Accesses the car field the car field of an lbm_cons_t.
425 *
426 * \param cons Value
427 * \return The car of car field or nil.
428 */
429lbm_value lbm_caar(lbm_value c);
430/** Accesses the car of the cdr of an cons cell
431 *
432 * \param c Value
433 * \return the cdr field or type error.
434 */
435lbm_value lbm_cadr(lbm_value c);
436/** Accesses the cdr field of an lbm_cons_t.
437 *
438 * \param cons Value
439 * \return The cdr field of the lbm_cons_t if cons is a reference to a heap cell.
440 * If cons is nil, the return value is nil. If the value
441 * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
442 */
443lbm_value lbm_cdr(lbm_value cons);
444/** Accesses the cdr of an cdr field of an lbm_cons_t.
445 *
446 * \param cons Value
447 * \return The cdr of the cdr field of the lbm_cons_t if cons is a reference to a heap cell.
448 * If cons is nil, the return value is nil. If the value
449 * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
450 */
451lbm_value lbm_cddr(lbm_value c);
452/** Update the value stored in the car field of a heap cell.
453 *
454 * \param c Value referring to a heap cell.
455 * \param v Value to replace the car field with.
456 * \return 1 on success and 0 if the c value does not refer to a heap cell.
457 */
458int lbm_set_car(lbm_value c, lbm_value v);
459/** Update the value stored in the cdr field of a heap cell.
460 *
461 * \param c Value referring to a heap cell.
462 * \param v Value to replace the cdr field with.
463 * \return 1 on success and 0 if the c value does not refer to a heap cell.
464 */
465int lbm_set_cdr(lbm_value c, lbm_value v);
466/** Update the value stored in the car and cdr fields of a heap cell.
467 *
468 * \param c Value referring to a heap cell.
469 * \param car_val Value to replace the car field with.
470 * \param cdr_val Value to replace the cdr field with.
471 * \return 1 on success and 0 if the c value does not refer to a heap cell.
472 */
473int lbm_set_car_and_cdr(lbm_value c, lbm_value car_val, lbm_value cdr_val);
474// List functions
475/** Calculate the length of a proper list
476 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
477 * may lead to the function not terminating.
478 *
479 * \param c A list
480 * \return The length of the list. Unless the value is a cyclic structure on the heap, this function will terminate.
481 */
482lbm_uint lbm_list_length(lbm_value c);
483
484/** Calculate the length of a proper list and evaluate a predicate for each element.
485 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
486 * may lead to the function not terminating.
487 *
488 * \param c A list
489 * \param pres Boolean result of predicate, false if predicate is false for any of the elements in the list, otherwise true.
490 * \param pred Predicate to evaluate for each element of the list.
491 */
492unsigned int lbm_list_length_pred(lbm_value c, bool_Bool *pres, bool_Bool (*pred)(lbm_value));
493/** Reverse a proper list
494 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
495 * may lead to the function not terminating.
496 *
497 * \param list A list
498 * \return The list reversed or enc_sym(SYM_MERROR) if heap is full.
499 */
500lbm_value lbm_list_reverse(lbm_value list);
501/** Reverse a proper list destroying the original.
502 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
503 * may lead to the function not terminating.
504 *
505 * \param list A list
506 * \return The list reversed
507 */
508lbm_value lbm_list_destructive_reverse(lbm_value list);
509/** Copy a list
510 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
511 * may lead to the function not terminating.
512 *
513 * \param m Number of elements to copy or -1 for all. If 1, m will be updated with the length of the list
514 * \param list A list.
515 * \return Reversed list or enc_sym(SYM_MERROR) if heap is full.
516 */
517lbm_value lbm_list_copy(int *m, lbm_value list);
518
519/** A destructive append of two lists
520 *
521 * \param list1 A list
522 * \param list2 A list
523 * \return list1 with list2 appended at the end.
524 */
525lbm_value lbm_list_append(lbm_value list1, lbm_value list2);
526
527/** Drop values from the head of a list.
528 * \param n Number of values to drop.
529 * \param ls List to drop values from.
530 * \return The list with the n first elements removed.
531 */
532lbm_value lbm_list_drop(unsigned int n, lbm_value ls);
533/** Index into a list.
534 * \param l List to index into.
535 * \param n Position to read out of the list.
536 * \return Value at position n of l or nil if out of bounds.
537 */
538lbm_value lbm_index_list(lbm_value l, int32_t n);
539
540// State and statistics
541/** Get a copy of the heap statistics structure.
542 *
543 * \param A pointer to an lbm_heap_state_t to populate
544 * with the current statistics.
545 */
546void lbm_get_heap_state(lbm_heap_state_t *);
547/** Get the maximum stack level of the GC stack
548 * \return maximum value the gc stack sp reached so far.
549 */
550lbm_uint lbm_get_gc_stack_max(void);
551/** Get the size of the GC stack.
552 * \return the size of the gc stack.
553 */
554lbm_uint lbm_get_gc_stack_size(void);
555// Garbage collection
556/** Increment the counter that is counting the number of times GC ran
557 *
558 */
559void lbm_gc_state_inc(void);
560/** Set the freelist to NIL. Means that no memory will be available
561 * until after a garbage collection.
562 */
563void lbm_nil_freelist(void);
564/** Mark all heap cells reachable from an environment.
565 * \param environment.
566 */
567void lbm_gc_mark_env(lbm_value);
568/** Mark heap cells reachable from the lbm_value v.
569 * \param root
570 */
571void lbm_gc_mark_phase(lbm_value root);
572/** Performs lbm_gc_mark_phase on all the values of an array.
573 * This function is similar to lbm_gc_mark_roots but performs
574 * extra checks to not traverse into non-standard values.
575 * TODO: Check if this function is really needed.
576 * \param data Array of roots to traverse from.
577 * \param n Number of elements in roots-array.
578 */
579void lbm_gc_mark_aux(lbm_uint *data, lbm_uint n);
580/** Performs lbm_gc_mark_phase on all the values in the roots array.
581 * \param roots pointer to array of roots.
582 * \param num_roots size of array of roots.
583 */
584void lbm_gc_mark_roots(lbm_uint *roots, lbm_uint num_roots);
585/** Sweep up all non marked heap cells and place them on the free list.
586 *
587 * \return 1
588 */
589int lbm_gc_sweep_phase(void);
590
591// Array functionality
592/** Allocate an bytearray in symbols and arrays memory (lispbm_memory.h)
593 * and create a heap cell that refers to this bytearray.
594 * \param res The resulting lbm_value is returned through this argument.
595 * \param size Array size in number of 32 bit words.
596 * \return 1 for success of 0 for failure.
597 */
598int lbm_heap_allocate_array(lbm_value *res, lbm_uint size);
599/** Allocate an array in symbols and arrays memory (lispbm_memory.h)
600 * and create a heap cell that refers to this array.
601 * \param res The resulting lbm_value is returned through this argument.
602 * \param size Array size in number of 32 bit words.
603 * \return 1 for success of 0 for failure.
604 */
605int lbm_heap_allocate_lisp_array(lbm_value *res, lbm_uint size);
606/** Convert a C array into an lbm array. If the C array is allocated in LBM MEMORY
607 * the lifetime of the array will be managed by GC.
608 * \param res lbm_value result pointer for storage of the result array.
609 * \param data C array.
610 * \param type The type tag to assign to the resulting LBM array.
611 * \param num_elt Number of elements in the array.
612 * \return 1 for success and 0 for failure.
613 */
614int lbm_lift_array(lbm_value *value, char *data, lbm_uint num_elt);
615/** Get the size of an array value.
616 * \param arr lbm_value array to get size of.
617 * \return -1 for failure or length of array.
618 */
619lbm_int lbm_heap_array_get_size(lbm_value arr);
620/** Get a pointer to the data of an array for read only purposes.
621 * \param arr lbm_value array to get pointer from.
622 * \return NULL or valid pointer.
623 */
624const uint8_t *lbm_heap_array_get_data_ro(lbm_value arr);
625/** Get a pointer to the data of an array for read/write purposes.
626 * \param arr lbm_value array to get pointer from.
627 * \return NULL or valid pointer.
628 */
629uint8_t *lbm_heap_array_get_data_rw(lbm_value arr);
630/** Explicitly free an array.
631 * This function needs to be used with care and knowledge.
632 * \param arr Array value.
633 */
634int lbm_heap_explicit_free_array(lbm_value arr);
635/** Query the size in bytes of an lbm_type.
636 * \param t Type
637 * \return Size in bytes of type or 0 if the type represents a composite.
638 */
639lbm_uint lbm_size_of(lbm_type t);
640
641int lbm_const_heap_init(const_heap_write_fun w_fun,
642 lbm_const_heap_t *heap,
643 lbm_uint *addr,
644 lbm_uint num_words);
645
646lbm_flash_status lbm_allocate_const_cell(lbm_value *res);
647lbm_flash_status lbm_write_const_raw(lbm_uint *data, lbm_uint n, lbm_uint *res);
648lbm_flash_status lbm_allocate_const_raw(lbm_uint nwords, lbm_uint *res);
649lbm_flash_status write_const_cdr(lbm_value cell, lbm_value val);
650lbm_flash_status write_const_car(lbm_value cell, lbm_value val);
651lbm_flash_status lbm_const_write(lbm_uint *tgt, lbm_uint val);
652lbm_uint lbm_flash_memory_usage(void);
653
654/** Query the type information of a value.
655 *
656 * \param x Value to check the type of.
657 * \return The type information.
658 */
659static inline lbm_type lbm_type_of(lbm_value x) {
660 return (x & LBM_PTR_BIT0x00000001u) ? (x & LBM_PTR_TYPE_MASK0xFC000000u) : (x & LBM_VAL_TYPE_MASK0x0000000Cu);
661}
662
663// type-of check that is safe in functional code
664static inline lbm_type lbm_type_of_functional(lbm_value x) {
665 return (x & LBM_PTR_BIT0x00000001u) ?
666 (x & (LBM_PTR_TO_CONSTANT_MASK~0x04000000u & LBM_PTR_TYPE_MASK0xFC000000u)) :
667 (x & LBM_VAL_TYPE_MASK0x0000000Cu);
668}
669
670static inline lbm_value lbm_enc_cons_ptr(lbm_uint x) {
671 return ((x << LBM_ADDRESS_SHIFT2) | LBM_TYPE_CONS0x10000000u | LBM_PTR_BIT0x00000001u);
672}
673
674static inline lbm_uint lbm_dec_ptr(lbm_value p) {
675 return ((LBM_PTR_VAL_MASK0x03FFFFFCu & p) >> LBM_ADDRESS_SHIFT2);
676}
677
678extern lbm_cons_t *lbm_heaps[2];
679
680static inline lbm_uint lbm_dec_cons_cell_ptr(lbm_value p) {
681 lbm_uint h = (p & LBM_PTR_TO_CONSTANT_BIT0x04000000u) >> LBM_PTR_TO_CONSTANT_SHIFT26;
682 return lbm_dec_ptr(p) >> h;
683}
684
685static inline lbm_cons_t *lbm_dec_heap(lbm_value p) {
686 lbm_uint h = (p & LBM_PTR_TO_CONSTANT_BIT0x04000000u) >> LBM_PTR_TO_CONSTANT_SHIFT26;
687 return lbm_heaps[h];
688}
689
690static inline lbm_value lbm_set_ptr_type(lbm_value p, lbm_type t) {
691 return ((LBM_PTR_VAL_MASK0x03FFFFFCu & p) | t | LBM_PTR_BIT0x00000001u);
692}
693
694static inline lbm_value lbm_enc_sym(lbm_uint s) {
695 return (s << LBM_VAL_SHIFT4) | LBM_TYPE_SYMBOL0x00000000u;
696}
697
698static inline lbm_value lbm_enc_i(lbm_int x) {
699 return ((lbm_uint)x << LBM_VAL_SHIFT4) | LBM_TYPE_I0x00000008u;
700}
701
702static inline lbm_value lbm_enc_u(lbm_uint x) {
703 return (x << LBM_VAL_SHIFT4) | LBM_TYPE_U0x0000000Cu;
704}
705
706/** Encode 32 bit integer into an lbm_value.
707 * \param x Value to encode.
708 * \return result encoded value.
709 */
710extern lbm_value lbm_enc_i32(int32_t x);
711
712/** Encode 32 bit unsigned integer into an lbm_value.
713 * \param x Value to encode.
714 * \return result encoded value.
715 */
716extern lbm_value lbm_enc_u32(uint32_t x);
717
718/** Encode a float into an lbm_value.
719 * \param x float value to encode.
720 * \return result encoded value.
721 */
722extern lbm_value lbm_enc_float(float x);
723
724/** Encode a 64 bit integer into an lbm_value.
725 * \param x 64 bit integer to encode.
726 * \return result encoded value.
727 */
728extern lbm_value lbm_enc_i64(int64_t x);
729
730/** Encode a 64 bit unsigned integer into an lbm_value.
731 * \param x 64 bit unsigned integer to encode.
732 * \return result encoded value.
733 */
734extern lbm_value lbm_enc_u64(uint64_t x);
735
736/** Encode a double into an lbm_value.
737 * \param x double to encode.
738 * \return result encoded value.
739 */
740extern lbm_value lbm_enc_double(double x);
741
742static inline lbm_value lbm_enc_char(uint8_t x) {
743 return ((lbm_uint)x << LBM_VAL_SHIFT4) | LBM_TYPE_CHAR0x00000004u;
744}
745
746static inline lbm_int lbm_dec_i(lbm_value x) {
747 return (lbm_int)x >> LBM_VAL_SHIFT4;
748}
749
750static inline lbm_uint lbm_dec_u(lbm_value x) {
751 return x >> LBM_VAL_SHIFT4;
752}
753
754static inline uint8_t lbm_dec_char(lbm_value x) {
755 return (uint8_t)(x >> LBM_VAL_SHIFT4);
756}
757
758static inline lbm_uint lbm_dec_sym(lbm_value x) {
759 return x >> LBM_VAL_SHIFT4;
760}
761
762/** Decode an lbm_value representing a float.
763 * \param x Value to decode.
764 * \return decoded float.
765 */
766extern float lbm_dec_float(lbm_value x);
767
768/** Decode an lbm_value representing a double.
769 * \param x Value to decode.
770 * \return decoded float.
771 */
772extern double lbm_dec_double(lbm_value x);
773
774
775static inline uint32_t lbm_dec_u32(lbm_value x) {
776#ifndef LBM64
777 return (uint32_t)lbm_car(x);
778#else
779 return (uint32_t)(x >> LBM_VAL_SHIFT4);
780#endif
781}
782
783/** Decode an lbm_value representing a 64 bit unsigned integer.
784 * \param x Value to decode.
785 * \return decoded uint64_t.
786 */
787extern uint64_t lbm_dec_u64(lbm_value x);
788
789static inline int32_t lbm_dec_i32(lbm_value x) {
790#ifndef LBM64
791 return (int32_t)lbm_car(x);
792#else
793 return (int32_t)(x >> LBM_VAL_SHIFT4);
794#endif
795}
796
797/** Decode an lbm_value representing a 64 bit integer.
798 * \param x Value to decode.
799 * \return decoded int64_t.
800 */
801extern int64_t lbm_dec_i64(lbm_value x);
802
803/**
804 * Check if a value is a heap pointer
805 * \param x Value to check
806 * \return true if x is a pointer to a heap cell, false otherwise.
807 */
808static inline bool_Bool lbm_is_ptr(lbm_value x) {
809 return (x & LBM_PTR_BIT0x00000001u);
810}
811
812/**
813 * Check if a value is a Read/Writeable cons cell
814 * \param x Value to check
815 * \return true if x is a Read/Writeable cons cell, false otherwise.
816 */
817static inline bool_Bool lbm_is_cons_rw(lbm_value x) {
818 return (lbm_type_of(x) == LBM_TYPE_CONS0x10000000u);
819}
820
821/**
822 * Check if a value is a Readable cons cell
823 * \param x Value to check
824 * \return true if x is a readable cons cell, false otherwise.
825 */
826static inline bool_Bool lbm_is_cons(lbm_value x) {
827 return lbm_is_ptr(x) && ((x & LBM_CONS_TYPE_MASK0xF0000000u) == LBM_TYPE_CONS0x10000000u);
7
←
Assuming the condition is true
→
8
←
Assuming the condition is true
→
9
←
Returning the value 1, which participates in a condition later
→
828}
829
830/** Check if a value represents a number
831 * \param x Value to check.
832 * \return true is x represents a number and false otherwise.
833 */
834static inline bool_Bool lbm_is_number(lbm_value x) {
835 return
836 (x & LBM_PTR_BIT0x00000001u) ?
837 ((x & LBM_NUMBER_MASK0x08000000u) == LBM_NUMBER_MASK0x08000000u) :
838 (x & LBM_VAL_TYPE_MASK0x0000000Cu);
839}
840
841/** Check if value is an array that can be READ
842 * \param x Value to check.
843 * \return true if x represents a readable array and false otherwise.
844 */
845static inline bool_Bool lbm_is_array_r(lbm_value x) {
846 lbm_type t = lbm_type_of(x);
847 return ((t & LBM_PTR_TO_CONSTANT_MASK~0x04000000u) == LBM_TYPE_ARRAY0x80000000u);
848}
849
850static inline bool_Bool lbm_is_array_rw(lbm_value x) {
851 return( (lbm_type_of(x) == LBM_TYPE_ARRAY0x80000000u) && !(x & LBM_PTR_TO_CONSTANT_BIT0x04000000u));
852}
853
854static inline bool_Bool lbm_is_lisp_array_r(lbm_value x) {
855 lbm_type t = lbm_type_of(x);
856 return ((t & LBM_PTR_TO_CONSTANT_MASK~0x04000000u) == LBM_TYPE_LISPARRAY0xB0000000u);
857}
858
859static inline bool_Bool lbm_is_lisp_array_rw(lbm_value x) {
860 return( (lbm_type_of(x) == LBM_TYPE_LISPARRAY0xB0000000u) && !(x & LBM_PTR_TO_CONSTANT_BIT0x04000000u));
861}
862
863
864static inline bool_Bool lbm_is_channel(lbm_value x) {
865 return (lbm_type_of(x) == LBM_TYPE_CHANNEL0x90000000u &&
866 lbm_type_of(lbm_cdr(x)) == LBM_TYPE_SYMBOL0x00000000u &&
867 lbm_cdr(x) == ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
868}
869static inline bool_Bool lbm_is_char(lbm_value x) {
870 return (lbm_type_of(x) == LBM_TYPE_CHAR0x00000004u);
871}
872
873static inline bool_Bool lbm_is_special(lbm_value symrep) {
874 return ((lbm_type_of(symrep) == LBM_TYPE_SYMBOL0x00000000u) &&
875 (lbm_dec_sym(symrep) < SPECIAL_SYMBOLS_END0xFFFF));
876}
877
878static inline bool_Bool lbm_is_closure(lbm_value exp) {
879 return ((lbm_is_cons(exp)) &&
880 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
881 (lbm_car(exp) == ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u)));
882}
883
884static inline bool_Bool lbm_is_continuation(lbm_value exp) {
885 return ((lbm_type_of(exp) == LBM_TYPE_CONS0x10000000u) &&
886 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
887 (lbm_car(exp) == ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u)));
888}
889
890static inline bool_Bool lbm_is_macro(lbm_value exp) {
891 return ((lbm_type_of(exp) == LBM_TYPE_CONS0x10000000u) &&
892 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
893 (lbm_car(exp) == ENC_SYM_MACRO(((0x10D) << 4) | 0x00000000u)));
894}
895
896static inline bool_Bool lbm_is_match_binder(lbm_value exp) {
897 return (lbm_is_cons(exp) &&
898 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
899 (lbm_car(exp) == ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u)));
900}
901
902static inline bool_Bool lbm_is_comma_qualified_symbol(lbm_value exp) {
903 return (lbm_is_cons(exp) &&
904 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
905 (lbm_car(exp) == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) &&
906 (lbm_type_of(lbm_cadr(exp)) == LBM_TYPE_SYMBOL0x00000000u));
907}
908
909static inline bool_Bool lbm_is_symbol(lbm_value exp) {
910 return !(exp & LBM_LOW_RESERVED_BITS0x0000000Fu);
2
←
Assuming the condition is false
→
3
←
Returning zero, which participates in a condition later
→
911}
912
913static inline bool_Bool lbm_is_symbol_nil(lbm_value exp) {
914 return !exp;
30
←
Assuming 'exp' is 0
→
31
←
Returning the value 1, which participates in a condition later
→
915}
916
917static inline bool_Bool lbm_is_symbol_true(lbm_value exp) {
918 return (lbm_is_symbol(exp) && exp == ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u));
919}
920
921static inline bool_Bool lbm_is_symbol_eval(lbm_value exp) {
922 return (lbm_is_symbol(exp) && exp == ENC_SYM_EVAL(((0x30008) << 4) | 0x00000000u));
923}
924
925static inline bool_Bool lbm_is_symbol_merror(lbm_value exp) {
926 return lbm_is_symbol(exp) && (exp == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
927}
928
929static inline bool_Bool lbm_is_list(lbm_value x) {
930 return (lbm_is_cons(x) || lbm_is_symbol_nil(x));
931}
932
933static inline bool_Bool lbm_is_list_rw(lbm_value x) {
934 return (lbm_is_cons_rw(x) || lbm_is_symbol_nil(x));
935}
936
937static inline bool_Bool lbm_is_quoted_list(lbm_value x) {
938 return (lbm_is_cons(x) &&
939 lbm_is_symbol(lbm_car(x)) &&
940 (lbm_car(x) == ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u)) &&
941 lbm_is_cons(lbm_cdr(x)) &&
942 lbm_is_cons(lbm_cadr(x)));
943}
944
945#ifndef LBM64
946#define ERROR_SYMBOL_MASK0xFFFFFFF0 0xFFFFFFF0
947#else
948#define ERROR_SYMBOL_MASK0xFFFFFFF0 0xFFFFFFFFFFFFFFF0
949#endif
950
951/* all error signaling symbols are in the range 0x20 - 0x2F */
952static inline bool_Bool lbm_is_error(lbm_value v){
953 return (lbm_is_symbol(v) &&
954 ((lbm_dec_sym(v) & ERROR_SYMBOL_MASK0xFFFFFFF0) == 0x20));
955}
956
957// ref_cell: returns a reference to the cell addressed by bits 3 - 26
958// Assumes user has checked that is_ptr was set
959static inline lbm_cons_t* lbm_ref_cell(lbm_value addr) {
960 return &lbm_dec_heap(addr)[lbm_dec_cons_cell_ptr(addr)];
961 //return &lbm_heap_state.heap[lbm_dec_ptr(addr)];
962}
963
964
965// lbm_uint a = lbm_heaps[0];
966// lbm_uint b = lbm_heaps[1];
967// lbm_uint i = (addr & LBM_PTR_TO_CONSTANT_BIT) >> LBM_PTR_TO_CONSTANT_SHIFT) - 1;
968// lbm_uint h = (a & i) | (b & ~i);
969
970#ifdef __cplusplus
971}
972#endif
973#endif
diff --git a/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-3e0f11.html b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-3e0f11.html new file mode 100644 index 00000000..dc092a15 --- /dev/null +++ b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-3e0f11.html @@ -0,0 +1,6552 @@ + + + +src/eval_cps.c + + + + + + + + + + + + + + + + + + + + + + + + + + +

Bug Summary

+ + + + +
File:eval_cps.c
Warning:line 3757, column 25
Access to field 'data' results in a dereference of a null pointer (loaded from variable 'arr')
+ +

Annotated Source Code

+

Press '?' + to see keyboard shortcuts

+ + +
clang -cc1 -triple i386-pc-linux-gnu -analyze -disable-free -disable-llvm-verifier -discard-value-names -main-file-name eval_cps.c -analyzer-store=region -analyzer-opt-analyze-nested-blocks -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -mrelocation-model static -mthread-model posix -mframe-pointer=none -fmath-errno -fno-rounding-math -masm-verbose -mconstructor-aliases -target-cpu i686 -dwarf-column-info -fno-split-dwarf-inlining -debugger-tuning=gdb -resource-dir /usr/lib/llvm-10/lib/clang/10.0.0 -I ./include -I ./include/extensions -I platform/linux/include -D _PRELUDE -internal-isystem /usr/local/include -internal-isystem /usr/lib/llvm-10/lib/clang/10.0.0/include -internal-externc-isystem /usr/include/i386-linux-gnu -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -std=c99 -fdebug-compilation-dir /home/joels/Current/lispbm -ferror-limit 19 -fmessage-length 0 -fgnuc-version=4.2.1 -fobjc-runtime=gcc -fdiagnostics-show-option -vectorize-loops -vectorize-slp -analyzer-output=html -faddrsig -o /home/joels/Current/lispbm/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1 -x c src/eval_cps.c +
+ + + +
+ + +
+ + + + +
+

src/eval_cps.c

+
→
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1/*
2 Copyright 2018, 2020 - 2024 Joel Svensson svenssonjoel@yahoo.se
3
4 This program is free software: you can redistribute it and/or modify
5 it under the terms of the GNU General Public License as published by
6 the Free Software Foundation, either version 3 of the License, or
7 (at your option) any later version.
8
9 This program is distributed in the hope that it will be useful,
10 but WITHOUT ANY WARRANTY; without even the implied warranty of
11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 GNU General Public License for more details.
13
14 You should have received a copy of the GNU General Public License
15 along with this program. If not, see <http://www.gnu.org/licenses/>.
16*/
17
18#include <lbm_memory.h>
19#include <lbm_types.h>
20#include "symrepr.h"
21#include "heap.h"
22#include "env.h"
23#include "eval_cps.h"
24#include "stack.h"
25#include "fundamental.h"
26#include "extensions.h"
27#include "tokpar.h"
28#include "lbm_channel.h"
29#include "print.h"
30#include "platform_mutex.h"
31#include "lbm_flat_value.h"
32#include "lbm_flags.h"
33
34#ifdef VISUALIZE_HEAP
35#include "heap_vis.h"
36#endif
37
38#include <setjmp.h>
39#include <stdarg.h>
40
41static jmp_buf error_jmp_buf;
42static jmp_buf critical_error_jmp_buf;
43
44#define S_TO_US(X)(lbm_uint)((X) * 1000000) (lbm_uint)((X) * 1000000)
45
46#define DEC_CONTINUATION(x)(((x) & ~0xF8000001u) >> 2) (((x) & ~LBM_CONTINUATION_INTERNAL0xF8000001u) >> LBM_ADDRESS_SHIFT2)
47#define IS_CONTINUATION(x)(((x) & 0xF8000001u) == 0xF8000001u) (((x) & LBM_CONTINUATION_INTERNAL0xF8000001u) == LBM_CONTINUATION_INTERNAL0xF8000001u)
48#define CONTINUATION(x)(((x) << 2) | 0xF8000001u) (((x) << LBM_ADDRESS_SHIFT2) | LBM_CONTINUATION_INTERNAL0xF8000001u)
49
50#define DONE(((0) << 2) | 0xF8000001u) CONTINUATION(0)(((0) << 2) | 0xF8000001u)
51#define SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u) CONTINUATION(1)(((1) << 2) | 0xF8000001u)
52#define BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u) CONTINUATION(2)(((2) << 2) | 0xF8000001u)
53#define IF(((3) << 2) | 0xF8000001u) CONTINUATION(3)(((3) << 2) | 0xF8000001u)
54#define PROGN_REST(((4) << 2) | 0xF8000001u) CONTINUATION(4)(((4) << 2) | 0xF8000001u)
55#define APPLICATION_ARGS(((5) << 2) | 0xF8000001u) CONTINUATION(5)(((5) << 2) | 0xF8000001u)
56#define AND(((6) << 2) | 0xF8000001u) CONTINUATION(6)(((6) << 2) | 0xF8000001u)
57#define OR(((7) << 2) | 0xF8000001u) CONTINUATION(7)(((7) << 2) | 0xF8000001u)
58#define WAIT(((8) << 2) | 0xF8000001u) CONTINUATION(8)(((8) << 2) | 0xF8000001u)
59#define MATCH(((9) << 2) | 0xF8000001u) CONTINUATION(9)(((9) << 2) | 0xF8000001u)
60#define APPLICATION_START(((10) << 2) | 0xF8000001u) CONTINUATION(10)(((10) << 2) | 0xF8000001u)
61#define EVAL_R(((11) << 2) | 0xF8000001u) CONTINUATION(11)(((11) << 2) | 0xF8000001u)
62#define RESUME(((12) << 2) | 0xF8000001u) CONTINUATION(12)(((12) << 2) | 0xF8000001u)
63#define CLOSURE_ARGS(((13) << 2) | 0xF8000001u) CONTINUATION(13)(((13) << 2) | 0xF8000001u)
64#define EXIT_ATOMIC(((14) << 2) | 0xF8000001u) CONTINUATION(14)(((14) << 2) | 0xF8000001u)
65#define READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u) CONTINUATION(15)(((15) << 2) | 0xF8000001u)
66#define READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u) CONTINUATION(16)(((16) << 2) | 0xF8000001u)
67#define READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u) CONTINUATION(17)(((17) << 2) | 0xF8000001u)
68#define READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u) CONTINUATION(18)(((18) << 2) | 0xF8000001u)
69#define READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u) CONTINUATION(19)(((19) << 2) | 0xF8000001u)
70#define READ_DONE(((20) << 2) | 0xF8000001u) CONTINUATION(20)(((20) << 2) | 0xF8000001u)
71#define READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u) CONTINUATION(21)(((21) << 2) | 0xF8000001u)
72#define READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u) CONTINUATION(22)(((22) << 2) | 0xF8000001u)
73#define READ_COMMA_RESULT(((23) << 2) | 0xF8000001u) CONTINUATION(23)(((23) << 2) | 0xF8000001u)
74#define READ_START_ARRAY(((24) << 2) | 0xF8000001u) CONTINUATION(24)(((24) << 2) | 0xF8000001u)
75#define READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u) CONTINUATION(25)(((25) << 2) | 0xF8000001u)
76#define MAP(((26) << 2) | 0xF8000001u) CONTINUATION(26)(((26) << 2) | 0xF8000001u)
77#define MATCH_GUARD(((27) << 2) | 0xF8000001u) CONTINUATION(27)(((27) << 2) | 0xF8000001u)
78#define TERMINATE(((28) << 2) | 0xF8000001u) CONTINUATION(28)(((28) << 2) | 0xF8000001u)
79#define PROGN_VAR(((29) << 2) | 0xF8000001u) CONTINUATION(29)(((29) << 2) | 0xF8000001u)
80#define SETQ(((30) << 2) | 0xF8000001u) CONTINUATION(30)(((30) << 2) | 0xF8000001u)
81#define MOVE_TO_FLASH(((31) << 2) | 0xF8000001u) CONTINUATION(31)(((31) << 2) | 0xF8000001u)
82#define MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u) CONTINUATION(32)(((32) << 2) | 0xF8000001u)
83#define MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u) CONTINUATION(33)(((33) << 2) | 0xF8000001u)
84#define CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u) CONTINUATION(34)(((34) << 2) | 0xF8000001u)
85#define QQ_EXPAND_START(((35) << 2) | 0xF8000001u) CONTINUATION(35)(((35) << 2) | 0xF8000001u)
86#define QQ_EXPAND(((36) << 2) | 0xF8000001u) CONTINUATION(36)(((36) << 2) | 0xF8000001u)
87#define QQ_APPEND(((37) << 2) | 0xF8000001u) CONTINUATION(37)(((37) << 2) | 0xF8000001u)
88#define QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u) CONTINUATION(38)(((38) << 2) | 0xF8000001u)
89#define QQ_LIST(((39) << 2) | 0xF8000001u) CONTINUATION(39)(((39) << 2) | 0xF8000001u)
90#define KILL(((40) << 2) | 0xF8000001u) CONTINUATION(40)(((40) << 2) | 0xF8000001u)
91#define LOOP(((41) << 2) | 0xF8000001u) CONTINUATION(41)(((41) << 2) | 0xF8000001u)
92#define LOOP_CONDITION(((42) << 2) | 0xF8000001u) CONTINUATION(42)(((42) << 2) | 0xF8000001u)
93#define MERGE_REST(((43) << 2) | 0xF8000001u) CONTINUATION(43)(((43) << 2) | 0xF8000001u)
94#define MERGE_LAYER(((44) << 2) | 0xF8000001u) CONTINUATION(44)(((44) << 2) | 0xF8000001u)
95#define CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u) CONTINUATION(45)(((45) << 2) | 0xF8000001u)
96#define MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u) CONTINUATION(46)(((46) << 2) | 0xF8000001u)
97#define POP_READER_FLAGS(((47) << 2) | 0xF8000001u) CONTINUATION(47)(((47) << 2) | 0xF8000001u)
98#define EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u) CONTINUATION(48)(((48) << 2) | 0xF8000001u)
99#define NUM_CONTINUATIONS49 49
100
101#define FM_NEED_GC-1 -1
102#define FM_NO_MATCH-2 -2
103#define FM_PATTERN_ERROR-3 -3
104
105typedef enum {
106 BL_OK = 0,
107 BL_NO_MEMORY,
108 BL_INCORRECT_KEY
109} binding_location_status;
110
111#define FB_OK0 0
112#define FB_TYPE_ERROR-1 -1
113
114const char* lbm_error_str_parse_eof = "End of parse stream.";
115const char* lbm_error_str_parse_dot = "Incorrect usage of '.'.";
116const char* lbm_error_str_parse_close = "Expected closing parenthesis.";
117const char* lbm_error_str_num_args = "Incorrect number of arguments.";
118const char* lbm_error_str_forbidden_in_atomic = "Operation is forbidden in an atomic block.";
119const char* lbm_error_str_no_number = "Argument(s) must be a number.";
120const char* lbm_error_str_not_a_boolean = "Argument must be t or nil (true or false).";
121const char* lbm_error_str_incorrect_arg = "Incorrect argument.";
122const char* lbm_error_str_var_outside_progn = "Usage of var outside of progn.";
123const char* lbm_error_str_flash_not_possible = "Value cannot be written to flash.";
124const char* lbm_error_str_flash_error = "Error writing to flash.";
125const char* lbm_error_str_flash_full = "Flash memory is full.";
126const char* lbm_error_str_variable_not_bound = "Variable not bound.";
127
128static lbm_value lbm_error_suspect;
129static bool_Bool lbm_error_has_suspect = false0;
130#ifdef LBM_ALWAYS_GC
131
132#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
133 gc(); \
134 (y) = (x); \
135 if (lbm_is_symbol_merror((y))) { \
136 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
137 }
138
139#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
140 lbm_gc_mark_phase(r); \
141 gc(); \
142 (y) = (x); \
143 if (lbm_is_symbol_merror((y))) { \
144 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
145 }
146
147#else
148
149#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
150 (y) = (x); \
151 if (lbm_is_symbol_merror((y))) { \
152 gc(); \
153 (y) = (x); \
154 if (lbm_is_symbol_merror((y))) { \
155 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
156 } \
157 /* continue executing statements below */ \
158 }
159#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
160 (y) = (x); \
161 if (lbm_is_symbol_merror((y))) { \
162 lbm_gc_mark_phase(r); \
163 gc(); \
164 (y) = (x); \
165 if (lbm_is_symbol_merror((y))) { \
166 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
167 } \
168 /* continue executing statements below */ \
169 }
170
171#endif
172
173typedef struct {
174 eval_context_t *first;
175 eval_context_t *last;
176} eval_context_queue_t;
177
178#ifdef CLEAN_UP_CLOSURES
179static lbm_value clean_cl_env_symbol = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
180#endif
181
182static int gc(void);
183static void error_ctx(lbm_value);
184static void error_at_ctx(lbm_value err_val, lbm_value at);
185static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx);
186static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail);
187
188// The currently executing context.
189eval_context_t *ctx_running = NULL((void*)0);
190volatile bool_Bool lbm_system_sleeping = false0;
191
192static volatile bool_Bool gc_requested = false0;
193void lbm_request_gc(void) {
194 gc_requested = true1;
195}
196
197/*
198 On ChibiOs the CH_CFG_ST_FREQUENCY setting in chconf.h sets the
199 resolution of the timer used for sleep operations. If this is set
200 to 10KHz the resolution is 100us.
201
202 The CH_CFG_ST_TIMEDELTA specifies the minimum number of ticks that
203 can be safely specified in a timeout directive (wonder if that
204 means sleep-period). The timedelta is set to 2.
205
206 If I have understood these correctly it means that the minimum
207 sleep duration possible is 2 * 100us = 200us.
208*/
209
210#define EVAL_CPS_DEFAULT_STACK_SIZE256 256
211#define EVAL_CPS_MIN_SLEEP200 200
212#define EVAL_STEPS_QUOTA10 10
213
214static volatile uint32_t eval_steps_refill = EVAL_STEPS_QUOTA10;
215static uint32_t eval_steps_quota = EVAL_STEPS_QUOTA10;
216
217void lbm_set_eval_step_quota(uint32_t quota) {
218 eval_steps_refill = quota;
219}
220
221static uint32_t eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
222static volatile uint32_t eval_cps_next_state = EVAL_CPS_STATE_NONE0;
223static volatile uint32_t eval_cps_next_state_arg = 0;
224static volatile bool_Bool eval_cps_state_changed = false0;
225
226static void usleep_nonsense(uint32_t us) {
227 (void) us;
228}
229
230static bool_Bool dynamic_load_nonsense(const char *sym, const char **code) {
231 (void) sym;
232 (void) code;
233 return false0;
234}
235
236static uint32_t timestamp_nonsense(void) {
237 return 0;
238}
239
240static int printf_nonsense(const char *fmt, ...) {
241 (void) fmt;
242 return 0;
243}
244
245static void ctx_done_nonsense(eval_context_t *ctx) {
246 (void) ctx;
247}
248
249static void critical_nonsense(void) {
250 return;
251}
252
253static void (*critical_error_callback)(void) = critical_nonsense;
254static void (*usleep_callback)(uint32_t) = usleep_nonsense;
255static uint32_t (*timestamp_us_callback)(void) = timestamp_nonsense;
256static void (*ctx_done_callback)(eval_context_t *) = ctx_done_nonsense;
257static int (*printf_callback)(const char *, ...) = printf_nonsense;
258static bool_Bool (*dynamic_load_callback)(const char *, const char **) = dynamic_load_nonsense;
259
260void lbm_set_critical_error_callback(void (*fptr)(void)) {
261 if (fptr == NULL((void*)0)) critical_error_callback = critical_nonsense;
262 else critical_error_callback = fptr;
263}
264
265void lbm_set_usleep_callback(void (*fptr)(uint32_t)) {
266 if (fptr == NULL((void*)0)) usleep_callback = usleep_nonsense;
267 else usleep_callback = fptr;
268}
269
270void lbm_set_timestamp_us_callback(uint32_t (*fptr)(void)) {
271 if (fptr == NULL((void*)0)) timestamp_us_callback = timestamp_nonsense;
272 else timestamp_us_callback = fptr;
273}
274
275void lbm_set_ctx_done_callback(void (*fptr)(eval_context_t *)) {
276 if (fptr == NULL((void*)0)) ctx_done_callback = ctx_done_nonsense;
277 else ctx_done_callback = fptr;
278}
279
280void lbm_set_printf_callback(int (*fptr)(const char*, ...)){
281 if (fptr == NULL((void*)0)) printf_callback = printf_nonsense;
282 else printf_callback = fptr;
283}
284
285void lbm_set_dynamic_load_callback(bool_Bool (*fptr)(const char *, const char **)) {
286 if (fptr == NULL((void*)0)) dynamic_load_callback = dynamic_load_nonsense;
287 else dynamic_load_callback = fptr;
288}
289
290static volatile lbm_event_t *lbm_events = NULL((void*)0);
291static unsigned int lbm_events_head = 0;
292static unsigned int lbm_events_tail = 0;
293static unsigned int lbm_events_max = 0;
294static bool_Bool lbm_events_full = false0;
295static mutex_t lbm_events_mutex;
296static bool_Bool lbm_events_mutex_initialized = false0;
297static volatile lbm_cid lbm_event_handler_pid = -1;
298
299lbm_cid lbm_get_event_handler_pid(void) {
300 return lbm_event_handler_pid;
301}
302
303void lbm_set_event_handler_pid(lbm_cid pid) {
304 lbm_event_handler_pid = pid;
305}
306
307bool_Bool lbm_event_handler_exists(void) {
308 return(lbm_event_handler_pid > 0);
309}
310
311
312static bool_Bool event_internal(lbm_event_type_t event_type, lbm_uint parameter, lbm_uint buf_ptr, lbm_uint buf_len) {
313 bool_Bool r = false0;
314 if (lbm_events) {
315 mutex_lock(&lbm_events_mutex);
316 if (!lbm_events_full) {
317 lbm_event_t event;
318 event.type = event_type;
319 event.parameter = parameter;
320 event.buf_ptr = buf_ptr;
321 event.buf_len = buf_len;
322 lbm_events[lbm_events_head] = event;
323 lbm_events_head = (lbm_events_head + 1) % lbm_events_max;
324 lbm_events_full = lbm_events_head == lbm_events_tail;
325 r = true1;
326 }
327 mutex_unlock(&lbm_events_mutex);
328 }
329 return r;
330}
331
332bool_Bool lbm_event_define(lbm_value key, lbm_flat_value_t *fv) {
333 return event_internal(LBM_EVENT_DEFINE, key, (lbm_uint)fv->buf, fv->buf_size);
334}
335
336bool_Bool lbm_event_unboxed(lbm_value unboxed) {
337 lbm_uint t = lbm_type_of(unboxed);
338 if (t == LBM_TYPE_SYMBOL0x00000000u ||
339 t == LBM_TYPE_I0x00000008u ||
340 t == LBM_TYPE_U0x0000000Cu ||
341 t == LBM_TYPE_CHAR0x00000004u) {
342 if (lbm_event_handler_pid > 0) {
343 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)unboxed, 0);
344 }
345 }
346 return false0;
347}
348
349bool_Bool lbm_event(lbm_flat_value_t *fv) {
350 if (lbm_event_handler_pid > 0) {
351 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)fv->buf, fv->buf_size);
352 }
353 return false0;
354}
355
356static bool_Bool lbm_event_pop(lbm_event_t *event) {
357 mutex_lock(&lbm_events_mutex);
358 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
359 mutex_unlock(&lbm_events_mutex);
360 return false0;
361 }
362 *event = lbm_events[lbm_events_tail];
363 lbm_events_tail = (lbm_events_tail + 1) % lbm_events_max;
364 lbm_events_full = false0;
365 mutex_unlock(&lbm_events_mutex);
366 return true1;
367}
368
369bool_Bool lbm_event_queue_is_empty(void) {
370 mutex_lock(&lbm_events_mutex);
371 bool_Bool empty = false0;
372 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
373 empty = true1;
374 }
375 mutex_unlock(&lbm_events_mutex);
376 return empty;
377}
378
379static bool_Bool eval_running = false0;
380static volatile bool_Bool blocking_extension = false0;
381static mutex_t blocking_extension_mutex;
382static bool_Bool blocking_extension_mutex_initialized = false0;
383static lbm_uint blocking_extension_timeout_us = 0;
384static bool_Bool blocking_extension_timeout = false0;
385
386static uint32_t is_atomic = 0;
387
388/* Process queues */
389static eval_context_queue_t blocked = {NULL((void*)0), NULL((void*)0)};
390static eval_context_queue_t queue = {NULL((void*)0), NULL((void*)0)};
391
392/* one mutex for all queue operations */
393mutex_t qmutex;
394bool_Bool qmutex_initialized = false0;
395
396
397// MODES
398static volatile bool_Bool lbm_verbose = false0;
399
400void lbm_toggle_verbose(void) {
401 lbm_verbose = !lbm_verbose;
402}
403
404void lbm_set_verbose(bool_Bool verbose) {
405 lbm_verbose = verbose;
406}
407
408lbm_cid lbm_get_current_cid(void) {
409 if (ctx_running)
410 return ctx_running->id;
411 else
412 return -1;
413}
414
415eval_context_t *lbm_get_current_context(void) {
416 return ctx_running;
417}
418
419/****************************************************/
420/* Utilities used locally in this file */
421
422static lbm_value cons_with_gc(lbm_value head, lbm_value tail, lbm_value remember) {
423#ifdef LBM_ALWAYS_GC
424 lbm_value roots[3] = {head, tail, remember};
425 lbm_gc_mark_roots(roots, 3);
426 gc();
427 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
428 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
429 if (lbm_is_symbol_merror(res)) {
430 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
431 }
432 return res;
433#else
434 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
435 if (lbm_is_symbol_merror(res)) {
436 lbm_value roots[3] = {head, tail, remember};
437 lbm_gc_mark_roots(roots,3);
438 gc();
439 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
440 if (lbm_is_symbol_merror(res)) {
441 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
442 }
443 }
444 return res;
445#endif
446}
447
448static lbm_uint *get_stack_ptr(eval_context_t *ctx, unsigned int n) {
449 if (n <= ctx->K.sp) {
450 lbm_uint index = ctx->K.sp - n;
451 return &ctx->K.data[index];
452 }
453 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
454 return 0; // dead code cannot be reached, but C compiler doesn't realise.
455}
456
457// pop_stack_ptr is safe when no GC is performed and
458// the values of the stack will be dropped.
459static lbm_uint *pop_stack_ptr(eval_context_t *ctx, unsigned int n) {
460 if (n <= ctx->K.sp) {
461 ctx->K.sp -= n;
462 return &ctx->K.data[ctx->K.sp];
463 }
464 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
465 return 0; // dead code cannot be reached, but C compiler doesn't realise.
466}
467
468static inline lbm_uint *stack_reserve(eval_context_t *ctx, unsigned int n) {
469 if (ctx->K.sp + n < ctx->K.size) {
470 lbm_uint *ptr = &ctx->K.data[ctx->K.sp];
471 ctx->K.sp += n;
472 return ptr;
473 }
474 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
475 return 0; // dead code cannot be reached, but C compiler doesn't realise.
476}
477
478static void handle_flash_status(lbm_flash_status s) {
479 if ( s == LBM_FLASH_FULL) {
480 lbm_set_error_reason((char*)lbm_error_str_flash_full);
481 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
482 }
483 if (s == LBM_FLASH_WRITE_ERROR) {
484 lbm_set_error_reason((char*)lbm_error_str_flash_error);
485 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
486 }
487}
488
489static void lift_array_flash(lbm_value flash_cell, bool_Bool bytearray, char *data, lbm_uint num_elt) {
490
491 lbm_array_header_t flash_array_header;
492 flash_array_header.size = num_elt;
493 flash_array_header.data = (lbm_uint*)data;
494 lbm_uint flash_array_header_ptr;
495 handle_flash_status(lbm_write_const_raw((lbm_uint*)&flash_array_header,
496 sizeof(lbm_array_header_t) / sizeof(lbm_uint),
497 &flash_array_header_ptr));
498 handle_flash_status(write_const_car(flash_cell, flash_array_header_ptr));
499 lbm_uint t = bytearray ? ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u) : ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u);
500 handle_flash_status(write_const_cdr(flash_cell, t));
501}
502
503static void get_car_and_cdr(lbm_value a, lbm_value *a_car, lbm_value *a_cdr) {
504 if (lbm_is_ptr(a)) {
505 lbm_cons_t *cell = lbm_ref_cell(a);
506 *a_car = cell->car;
507 *a_cdr = cell->cdr;
508 } else if (lbm_is_symbol_nil(a)) {
509 *a_car = *a_cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
510 } else {
511 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
512 }
513}
514
515/* car cdr caar cadr replacements that are evaluator safe. */
516static lbm_value get_car(lbm_value a) {
517 if (lbm_is_ptr(a)) {
21
←
Assuming the condition is false
→
22
←
Taking false branch
→
518 lbm_cons_t *cell = lbm_ref_cell(a);
519 return cell->car;
520 } else if (lbm_is_symbol_nil(a)) {
23
←
Calling 'lbm_is_symbol_nil'
→
26
←
Returning from 'lbm_is_symbol_nil'
→
27
←
Taking true branch
→
521 return a;
28
←
Returning zero (loaded from 'a')
→
522 }
523 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
524 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
525}
526
527static lbm_value get_cdr(lbm_value a) {
528 if (lbm_is_ptr(a)) {
529 lbm_cons_t *cell = lbm_ref_cell(a);
530 return cell->cdr;
531 } else if (lbm_is_symbol_nil(a)) {
532 return a;
533 }
534 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
535 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
536}
537
538static lbm_value get_cadr(lbm_value a) {
539 if (lbm_is_ptr(a)) {
540 lbm_cons_t *cell = lbm_ref_cell(a);
541 lbm_value tmp = cell->cdr;
542 if (lbm_is_ptr(tmp)) {
543 return lbm_ref_cell(tmp)->car;
544 } else if (lbm_is_symbol_nil(tmp)) {
545 return tmp;
546 }
547 } else if (lbm_is_symbol_nil(a)) {
548 return a;
549 }
550 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
551 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
552}
553
554static lbm_value allocate_closure(lbm_value params, lbm_value body, lbm_value env) {
555
556#ifdef LBM_ALWAYS_GC
557 gc();
558 if (lbm_heap_num_free() < 4) {
559 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
560 }
561#else
562 if (lbm_heap_num_free() < 4) {
563 gc();
564 if (lbm_heap_num_free() < 4) {
565 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
566 }
567 }
568#endif
569 // The freelist will always contain just plain heap-cells.
570 // So dec_ptr is sufficient.
571 lbm_value res = lbm_heap_state.freelist;
572 if (lbm_type_of(res) == LBM_TYPE_CONS0x10000000u) {
573 lbm_cons_t *heap = lbm_heap_state.heap;
574 lbm_uint ix = lbm_dec_ptr(res);
575 heap[ix].car = ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u);
576 ix = lbm_dec_ptr(heap[ix].cdr);
577 heap[ix].car = params;
578 ix = lbm_dec_ptr(heap[ix].cdr);
579 heap[ix].car = body;
580 ix = lbm_dec_ptr(heap[ix].cdr);
581 heap[ix].car = env;
582 lbm_heap_state.freelist = heap[ix].cdr;
583 heap[ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
584 lbm_heap_state.num_alloc+=4;
585 } else {
586 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
587 }
588 return res;
589}
590
591// Allocate a binding and attach it to a list (if so desired)
592static lbm_value allocate_binding(lbm_value key, lbm_value val, lbm_value the_cdr) {
593 if (lbm_heap_num_free() < 2) {
594 gc();
595 if (lbm_heap_num_free() < 2) {
596 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
597 }
598 }
599 lbm_cons_t* heap = lbm_heap_state.heap;
600 lbm_value binding_cell = lbm_heap_state.freelist;
601 lbm_uint binding_cell_ix = lbm_dec_ptr(binding_cell);
602 lbm_value list_cell = heap[binding_cell_ix].cdr;
603 lbm_uint list_cell_ix = lbm_dec_ptr(list_cell);
604 lbm_heap_state.freelist = heap[list_cell_ix].cdr;
605 lbm_heap_state.num_alloc += 2;
606 heap[binding_cell_ix].car = key;
607 heap[binding_cell_ix].cdr = val;
608 heap[list_cell_ix].car = binding_cell;
609 heap[list_cell_ix].cdr = the_cdr;
610 return list_cell;
611}
612
613#define CLO_PARAMS0 0
614#define CLO_BODY1 1
615#define CLO_ENV2 2
616#define LOOP_BINDS0 0
617#define LOOP_COND1 1
618#define LOOP_BODY2 2
619
620// (a b c) -> [a b c]
621static lbm_value extract_n(lbm_value curr, lbm_value *res, unsigned int n) {
622 for (unsigned int i = 0; i < n; i ++) {
623 if (lbm_is_ptr(curr)) {
624 lbm_cons_t *cell = lbm_ref_cell(curr);
625 res[i] = cell->car;
626 curr = cell->cdr;
627 } else {
628 res[i] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
629 }
630 }
631 return curr; // Rest of list is returned here.
632}
633
634static void call_fundamental(lbm_uint fundamental, lbm_value *args, lbm_uint arg_count, eval_context_t *ctx) {
635 lbm_value res;
636 res = fundamental_table[fundamental](args, arg_count, ctx);
637 if (lbm_is_error(res)) {
638 if (lbm_is_symbol_merror(res)) {
639 gc();
640 res = fundamental_table[fundamental](args, arg_count, ctx);
641 }
642 if (lbm_is_error(res)) {
643 error_at_ctx(res, lbm_enc_sym(FUNDAMENTAL_SYMBOLS_START0x20000 | fundamental));
644 }
645 }
646 lbm_stack_drop(&ctx->K, arg_count+1);
647 ctx->app_cont = true1;
648 ctx->r = res;
649}
650
651// block_current_ctx blocks a context until it is
652// woken up externally or a timeout period of time passes.
653static void block_current_ctx(uint32_t state, lbm_uint sleep_us, bool_Bool do_cont) {
654 ctx_running->timestamp = timestamp_us_callback();
655 ctx_running->sleep_us = sleep_us;
656 ctx_running->state = state;
657 ctx_running->app_cont = do_cont;
658 enqueue_ctx(&blocked, ctx_running);
659 ctx_running = NULL((void*)0);
660}
661
662lbm_flash_status lbm_write_const_array_padded(uint8_t *data, lbm_uint n, lbm_uint *res) {
663 lbm_uint full_words = n / sizeof(lbm_uint);
664 lbm_uint n_mod = n % sizeof(lbm_uint);
665
666 if (n_mod == 0) { // perfect fit.
667 return lbm_write_const_raw((lbm_uint*)data, full_words, res);
668 } else {
669 lbm_uint last_word = 0;
670 memcpy(&last_word, &data[full_words * sizeof(lbm_uint)], n_mod);
671 if (full_words >= 1) {
672 lbm_flash_status s = lbm_write_const_raw((lbm_uint*)data, full_words, res);
673 if ( s == LBM_FLASH_WRITE_OK) {
674 lbm_uint dummy;
675 s = lbm_write_const_raw(&last_word, 1, &dummy);
676 }
677 return s;
678 } else {
679 return lbm_write_const_raw(&last_word, 1, res);
680 }
681 }
682}
683
684/****************************************************/
685/* Error message creation */
686
687#define ERROR_MESSAGE_BUFFER_SIZE_BYTES256 256
688
689void print_environments(char *buf, unsigned int size) {
690
691 lbm_value curr_l = ctx_running->curr_env;
692 printf_callback("\tCurrent local environment:\n");
693 while (lbm_type_of(curr_l) == LBM_TYPE_CONS0x10000000u) {
694 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_l));
695 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_l)));
696 printf_callback("\t%s = %s\n", buf, buf+(size/2));
697 curr_l = lbm_cdr(curr_l);
698 }
699 printf_callback("\n\n");
700 printf_callback("\tCurrent global environment:\n");
701 lbm_value *glob_env = lbm_get_global_env();
702
703 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
704 lbm_value curr_g = glob_env[i];;
705 while (lbm_type_of(curr_g) == LBM_TYPE_CONS0x10000000u) {
706
707 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_g));
708 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_g)));
709 printf_callback("\t%s = %s\n", buf, buf+(size/2));
710 curr_g = lbm_cdr(curr_g);
711 }
712 }
713}
714
715void print_error_message(lbm_value error, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int col, lbm_int row0, lbm_int row1) {
716 if (!printf_callback) return;
717
718 /* try to allocate a lbm_print_value buffer on the lbm_memory */
719 char *buf = lbm_malloc_reserve(ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
720 if (!buf) {
721 printf_callback("Error: Not enough free memory to create a human readable error message\n");
722 return;
723 }
724
725 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, error);
726 printf_callback( "*** Error: %s\n", buf);
727 if (has_at) {
728 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, at);
729 printf_callback("*** In: %s\n",buf);
730 if (lbm_error_has_suspect) {
731 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, lbm_error_suspect);
732 lbm_error_has_suspect = false0;
733 printf_callback("*** At: %s\n", buf);
734 } else {
735 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
736 printf_callback("*** After: %s\n",buf);
737 }
738 } else {
739 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
740 printf_callback("*** Near: %s\n",buf);
741 }
742
743 printf_callback("\n");
744
745 if (lbm_is_symbol(error) &&
746 error == ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u)) {
747 printf_callback("*** Line: %u\n", row);
748 printf_callback("*** Column: %u\n", col);
749 } else if (row0 != -1 || row1 != -1 ) {
750 printf_callback("*** Between rows: (-1 unknown) \n");
751 printf_callback("*** Start: %d\n", (int32_t)row0);
752 printf_callback("*** End: %d\n", (int32_t)row1);
753 }
754
755 printf_callback("\n");
756
757 if (ctx_running->error_reason) {
758 printf_callback("Reason:\n %s\n\n", ctx_running->error_reason);
759 }
760 if (lbm_verbose) {
761 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
762 printf_callback(" In context: %d\n", ctx_running->id);
763 printf_callback(" Current intermediate result: %s\n\n", buf);
764
765 print_environments(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
766 printf_callback("\n\n");
767
768 printf_callback(" Stack:\n");
769 for (unsigned int i = 0; i < ctx_running->K.sp; i ++) {
770 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->K.data[i]);
771 printf_callback(" %s\n", buf);
772 }
773 }
774 lbm_free(buf);
775}
776
777/****************************************************/
778/* Tokenizing and parsing */
779
780bool_Bool create_string_channel(char *str, lbm_value *res) {
781
782 lbm_char_channel_t *chan = NULL((void*)0);
783 lbm_string_channel_state_t *st = NULL((void*)0);
784
785 st = (lbm_string_channel_state_t*)lbm_memory_allocate(sizeof(lbm_string_channel_state_t) / sizeof(lbm_uint) +1);
786 if (st == NULL((void*)0)) {
787 return false0;
788 }
789 chan = (lbm_char_channel_t*)lbm_memory_allocate(sizeof(lbm_char_channel_t) / sizeof(lbm_uint) + 1);
790 if (chan == NULL((void*)0)) {
791 lbm_memory_free((lbm_uint*)st);
792 return false0;
793 }
794
795 lbm_create_string_char_channel(st, chan, str);
796 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
797 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
798 lbm_memory_free((lbm_uint*)st);
799 lbm_memory_free((lbm_uint*)chan);
800 return false0;
801 }
802
803 *res = cell;
804 return true1;
805}
806
807bool_Bool lift_char_channel(lbm_char_channel_t *chan , lbm_value *res) {
808 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
809 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
810 return false0;
811 }
812 *res = cell;
813 return true1;
814}
815
816
817/****************************************************/
818/* Queue functions */
819
820static void queue_iterator_nm(eval_context_queue_t *q, ctx_fun f, void *arg1, void *arg2) {
821 eval_context_t *curr;
822 curr = q->first;
823
824 while (curr != NULL((void*)0)) {
825 f(curr, arg1, arg2);
826 curr = curr->next;
827 }
828}
829
830void lbm_running_iterator(ctx_fun f, void *arg1, void *arg2){
831 mutex_lock(&qmutex);
832 queue_iterator_nm(&queue, f, arg1, arg2);
833 mutex_unlock(&qmutex);
834}
835
836void lbm_blocked_iterator(ctx_fun f, void *arg1, void *arg2){
837 mutex_lock(&qmutex);
838 queue_iterator_nm(&blocked, f, arg1, arg2);
839 mutex_unlock(&qmutex);
840}
841
842static void enqueue_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
843 if (q->last == NULL((void*)0)) {
844 ctx->prev = NULL((void*)0);
845 ctx->next = NULL((void*)0);
846 q->first = ctx;
847 q->last = ctx;
848 } else {
849 ctx->prev = q->last;
850 ctx->next = NULL((void*)0);
851 q->last->next = ctx;
852 q->last = ctx;
853 }
854}
855
856static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx) {
857 mutex_lock(&qmutex);
858 enqueue_ctx_nm(q,ctx);
859 mutex_unlock(&qmutex);
860}
861
862static eval_context_t *lookup_ctx_nm(eval_context_queue_t *q, lbm_cid cid) {
863 eval_context_t *curr;
864 curr = q->first;
865 while (curr != NULL((void*)0)) {
866 if (curr->id == cid) {
867 return curr;
868 }
869 curr = curr->next;
870 }
871 return NULL((void*)0);
872}
873
874static bool_Bool drop_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
875
876 bool_Bool res = false0;
877 if (q->first == NULL((void*)0) || q->last == NULL((void*)0)) {
878 if (!(q->last == NULL((void*)0) && q->first == NULL((void*)0))) {
879 /* error state that should not happen */
880 return res;
881 }
882 /* Queue is empty */
883 return res;
884 }
885
886 eval_context_t *curr = q->first;
887 while (curr) {
888 if (curr->id == ctx->id) {
889 res = true1;
890 eval_context_t *tmp = curr->next;
891 if (curr->prev == NULL((void*)0)) {
892 if (curr->next == NULL((void*)0)) {
893 q->last = NULL((void*)0);
894 q->first = NULL((void*)0);
895 } else {
896 q->first = tmp;
897 tmp->prev = NULL((void*)0);
898 }
899 } else { /* curr->prev != NULL */
900 if (curr->next == NULL((void*)0)) {
901 q->last = curr->prev;
902 q->last->next = NULL((void*)0);
903 } else {
904 curr->prev->next = tmp;
905 tmp->prev = curr->prev;
906 }
907 }
908 break;
909 }
910 curr = curr->next;
911 }
912 return res;
913}
914
915/* End execution of the running context. */
916static void finish_ctx(void) {
917
918 if (!ctx_running) {
919 return;
920 }
921 /* Drop the continuation stack immediately to free up lbm_memory */
922 lbm_stack_free(&ctx_running->K);
923 ctx_done_callback(ctx_running);
924 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->name)) {
925 lbm_free(ctx_running->name);
926 }
927 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->error_reason)) {
928 lbm_memory_free((lbm_uint*)ctx_running->error_reason);
929 }
930 lbm_memory_free((lbm_uint*)ctx_running->mailbox);
931 lbm_memory_free((lbm_uint*)ctx_running);
932 ctx_running = NULL((void*)0);
933}
934
935static void context_exists(eval_context_t *ctx, void *cid, void *b) {
936 if (ctx->id == *(lbm_cid*)cid) {
937 *(bool_Bool*)b = true1;
938 }
939}
940
941bool_Bool lbm_wait_ctx(lbm_cid cid, lbm_uint timeout_ms) {
942
943 bool_Bool exists;
944 uint32_t i = 0;
945
946 do {
947 exists = false0;
948 lbm_blocked_iterator(context_exists, &cid, &exists);
949 lbm_running_iterator(context_exists, &cid, &exists);
950
951 if (ctx_running &&
952 ctx_running->id == cid) {
953 exists = true1;
954 }
955
956 if (exists) {
957 if (usleep_callback) {
958 usleep_callback(1000);
959 }
960 if (timeout_ms > 0) i ++;
961 }
962 } while (exists && i < timeout_ms);
963
964 if (exists) return false0;
965 return true1;
966}
967
968void lbm_set_error_suspect(lbm_value suspect) {
969 lbm_error_suspect = suspect;
970 lbm_error_has_suspect = true1;
971}
972
973void lbm_set_error_reason(char *error_str) {
974 if (ctx_running != NULL((void*)0)) {
975 ctx_running->error_reason = error_str;
976 }
977}
978
979// Not possible to CONS_WITH_GC in error_ctx_base (potential loop)
980static void error_ctx_base(lbm_value err_val, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int column) {
981
982 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
983 if (lbm_heap_num_free() < 3) {
984 gc();
985 }
986
987 if (lbm_heap_num_free() >= 3) {
988 lbm_value msg = lbm_cons(err_val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
989 msg = lbm_cons(lbm_enc_i(ctx_running->id), msg);
990 msg = lbm_cons(ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u), msg);
991 if (!lbm_is_symbol_merror(msg)) {
992 lbm_find_receiver_and_send(ctx_running->parent, msg);
993 goto error_ctx_base_done;
994 }
995 }
996 }
997 if ((ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10) &&
998 (err_val != ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u))) {
999 lbm_uint v;
1000 while (ctx_running->K.sp > 0) {
1001 lbm_pop(&ctx_running->K, &v);
1002 if (v == EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u)) {
1003 lbm_value *sptr = get_stack_ptr(ctx_running, 2);
1004 lbm_set_car(sptr[0], ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
1005 stack_reserve(ctx_running, 1)[0] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1006 ctx_running->app_cont = true1;
1007 ctx_running->r = err_val;
1008 longjmp(error_jmp_buf, 1);
1009 }
1010 }
1011 err_val = ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u);
1012 }
1013 print_error_message(err_val,
1014 has_at,
1015 at,
1016 row,
1017 column,
1018 ctx_running->row0,
1019 ctx_running->row1);
1020 error_ctx_base_done:
1021 ctx_running->r = err_val;
1022 finish_ctx();
1023 longjmp(error_jmp_buf, 1);
1024}
1025
1026static void error_at_ctx(lbm_value err_val, lbm_value at) {
1027 error_ctx_base(err_val, true1, at, 0, 0);
1028}
1029
1030static void error_ctx(lbm_value err_val) {
1031 error_ctx_base(err_val, false0, 0, 0, 0);
1032}
1033
1034static void read_error_ctx(unsigned int row, unsigned int column) {
1035 error_ctx_base(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u), false0, 0, row, column);
1036}
1037
1038void lbm_critical_error(void) {
1039 longjmp(critical_error_jmp_buf, 1);
1040}
1041
1042// successfully finish a context
1043static void ok_ctx(void) {
1044 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
1045 lbm_value msg;
1046 WITH_GC(msg, lbm_heap_allocate_list_init(3,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1047 ENC_SYM_EXIT_OK,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1048 lbm_enc_i(ctx_running->id),(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1049 ctx_running->r))(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
1050 lbm_find_receiver_and_send(ctx_running->parent, msg);
1051 }
1052 finish_ctx();
1053}
1054
1055static eval_context_t *dequeue_ctx_nm(eval_context_queue_t *q) {
1056 if (q->last == NULL((void*)0)) {
1057 return NULL((void*)0);
1058 }
1059 // q->first should only be NULL if q->last is.
1060 eval_context_t *res = q->first;
1061
1062 if (q->first == q->last) { // One thing in queue
1063 q->first = NULL((void*)0);
1064 q->last = NULL((void*)0);
1065 } else {
1066 q->first = q->first->next;
1067 q->first->prev = NULL((void*)0);
1068 }
1069 res->prev = NULL((void*)0);
1070 res->next = NULL((void*)0);
1071 return res;
1072}
1073
1074static void wake_up_ctxs_nm(void) {
1075 lbm_uint t_now;
1076
1077 if (timestamp_us_callback) {
1078 t_now = timestamp_us_callback();
1079 } else {
1080 t_now = 0;
1081 }
1082
1083 eval_context_queue_t *q = &blocked;
1084 eval_context_t *curr = q->first;
1085
1086 while (curr != NULL((void*)0)) {
1087 lbm_uint t_diff;
1088 eval_context_t *next = curr->next;
1089 if (curr->state != LBM_THREAD_STATE_BLOCKED(uint32_t)1) {
1090 if ( curr->timestamp > t_now) {
1091 /* There was an overflow on the counter */
1092#ifndef LBM64
1093 t_diff = (0xFFFFFFFF - curr->timestamp) + t_now;
1094#else
1095 t_diff = (0xFFFFFFFFFFFFFFFF - curr->timestamp) + t_now;
1096#endif
1097 } else {
1098 t_diff = t_now - curr->timestamp;
1099 }
1100
1101 if (t_diff >= curr->sleep_us) {
1102 eval_context_t *wake_ctx = curr;
1103 if (curr == q->last) {
1104 if (curr->prev) {
1105 q->last = curr->prev;
1106 q->last->next = NULL((void*)0);
1107 } else {
1108 q->first = NULL((void*)0);
1109 q->last = NULL((void*)0);
1110 }
1111 } else if (curr->prev == NULL((void*)0)) {
1112 q->first = curr->next;
1113 q->first->prev = NULL((void*)0);
1114 } else {
1115 curr->prev->next = curr->next;
1116 if (curr->next) {
1117 curr->next->prev = curr->prev;
1118 }
1119 }
1120 wake_ctx->next = NULL((void*)0);
1121 wake_ctx->prev = NULL((void*)0);
1122 if (curr->state == LBM_THREAD_STATE_TIMEOUT(uint32_t)2) {
1123 mailbox_add_mail(wake_ctx, ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u));
1124 wake_ctx->r = ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u);
1125 }
1126 wake_ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1127 enqueue_ctx_nm(&queue, wake_ctx);
1128 }
1129 }
1130 curr = next;
1131 }
1132}
1133
1134static void yield_ctx(lbm_uint sleep_us) {
1135 if (timestamp_us_callback) {
1136 ctx_running->timestamp = timestamp_us_callback();
1137 ctx_running->sleep_us = sleep_us;
1138 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1139 } else {
1140 ctx_running->timestamp = 0;
1141 ctx_running->sleep_us = 0;
1142 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1143 }
1144 ctx_running->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1145 ctx_running->app_cont = true1;
1146 enqueue_ctx(&blocked,ctx_running);
1147 ctx_running = NULL((void*)0);
1148}
1149
1150static lbm_cid lbm_create_ctx_parent(lbm_value program, lbm_value env, lbm_uint stack_size, lbm_cid parent, uint32_t context_flags, char *name) {
1151
1152 if (!lbm_is_cons(program)) return -1;
1153
1154 eval_context_t *ctx = NULL((void*)0);
1155
1156 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1157 if (ctx == NULL((void*)0)) {
1158 lbm_uint roots[2] = {program, env};
1159 lbm_gc_mark_roots(roots, 2);
1160 gc();
1161 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1162 }
1163 if (ctx == NULL((void*)0)) return -1;
1164
1165 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1166 lbm_uint roots[2] = {program, env};
1167 lbm_gc_mark_roots(roots, 2);
1168 gc();
1169 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1170 lbm_memory_free((lbm_uint*)ctx);
1171 return -1;
1172 }
1173 }
1174
1175 lbm_value *mailbox = NULL((void*)0);
1176 mailbox = (lbm_value*)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1177 if (mailbox == NULL((void*)0)) {
1178 lbm_value roots[2] = {program, env};
1179 lbm_gc_mark_roots(roots,2);
1180 gc();
1181 mailbox = (lbm_value *)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1182 }
1183 if (mailbox == NULL((void*)0)) {
1184 lbm_stack_free(&ctx->K);
1185 lbm_memory_free((lbm_uint*)ctx);
1186 return -1;
1187 }
1188
1189 // TODO: Limit names to 19 chars + 1 char for 0? (or something similar).
1190 if (name) {
1191 lbm_uint name_len = strlen(name) + 1;
1192 ctx->name = lbm_malloc(strlen(name) + 1);
1193 if (ctx->name == NULL((void*)0)) {
1194 lbm_value roots[2] = {program, env};
1195 lbm_gc_mark_roots(roots, 2);
1196 gc();
1197 ctx->name = lbm_malloc(strlen(name) + 1);
1198 }
1199 if (ctx->name == NULL((void*)0)) {
1200 lbm_stack_free(&ctx->K);
1201 lbm_memory_free((lbm_uint*)mailbox);
1202 lbm_memory_free((lbm_uint*)ctx);
1203 return -1;
1204 }
1205 memcpy(ctx->name, name, name_len+1);
1206 } else {
1207 ctx->name = NULL((void*)0);
1208 }
1209
1210 lbm_int cid = lbm_memory_address_to_ix((lbm_uint*)ctx);
1211
1212 ctx->program = lbm_cdr(program);
1213 ctx->curr_exp = lbm_car(program);
1214 ctx->curr_env = env;
1215 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1216 ctx->error_reason = NULL((void*)0);
1217 ctx->mailbox = mailbox;
1218 ctx->mailbox_size = EVAL_CPS_DEFAULT_MAILBOX_SIZE10;
1219 ctx->flags = context_flags;
1220 ctx->num_mail = 0;
1221 ctx->app_cont = false0;
1222 ctx->timestamp = 0;
1223 ctx->sleep_us = 0;
1224 ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1225 ctx->prev = NULL((void*)0);
1226 ctx->next = NULL((void*)0);
1227
1228 ctx->row0 = -1;
1229 ctx->row1 = -1;
1230
1231 ctx->id = cid;
1232 ctx->parent = parent;
1233
1234 if (!lbm_push(&ctx->K, DONE(((0) << 2) | 0xF8000001u))) {
1235 lbm_memory_free((lbm_uint*)ctx->mailbox);
1236 lbm_stack_free(&ctx->K);
1237 lbm_memory_free((lbm_uint*)ctx);
1238 return -1;
1239 }
1240
1241 enqueue_ctx(&queue,ctx);
1242
1243 return ctx->id;
1244}
1245
1246lbm_cid lbm_create_ctx(lbm_value program, lbm_value env, lbm_uint stack_size, char *name) {
1247 // Creates a parentless context.
1248 return lbm_create_ctx_parent(program,
1249 env,
1250 stack_size,
1251 -1,
1252 EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00,
1253 name);
1254}
1255
1256bool_Bool lbm_mailbox_change_size(eval_context_t *ctx, lbm_uint new_size) {
1257
1258 lbm_value *mailbox = NULL((void*)0);
1259 mailbox = (lbm_value*)lbm_memory_allocate(new_size);
1260 if (mailbox == NULL((void*)0)) {
1261 gc();
1262 mailbox = (lbm_value *)lbm_memory_allocate(new_size);
1263 }
1264 if (mailbox == NULL((void*)0)) {
1265 return false0;
1266 }
1267
1268 for (lbm_uint i = 0; i < ctx->num_mail; i ++ ) {
1269 mailbox[i] = ctx->mailbox[i];
1270 }
1271 lbm_memory_free(ctx->mailbox);
1272 ctx->mailbox = mailbox;
1273 ctx->mailbox_size = (uint32_t)new_size;
1274 return true1;
1275}
1276
1277static void mailbox_remove_mail(eval_context_t *ctx, lbm_uint ix) {
1278
1279 for (lbm_uint i = ix; i < ctx->num_mail-1; i ++) {
1280 ctx->mailbox[i] = ctx->mailbox[i+1];
1281 }
1282 ctx->num_mail --;
1283}
1284
1285static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail) {
1286
1287 if (ctx->num_mail >= ctx->mailbox_size) {
1288 mailbox_remove_mail(ctx, 0);
1289 }
1290
1291 ctx->mailbox[ctx->num_mail] = mail;
1292 ctx->num_mail ++;
1293 return true1;
1294}
1295
1296/* Advance execution to the next expression in the program */
1297static void advance_ctx(eval_context_t *ctx) {
1298 if (lbm_is_cons(ctx->program)) {
1299 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);;
1300 get_car_and_cdr(ctx->program, &ctx->curr_exp, &ctx->program);
1301 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1302 } else {
1303 if (ctx_running == ctx) { // This should always be the case because of odd historical reasons.
1304 ok_ctx();
1305 }
1306 }
1307}
1308
1309bool_Bool lbm_unblock_ctx(lbm_cid cid, lbm_flat_value_t *fv) {
1310 return event_internal(LBM_EVENT_UNBLOCK_CTX, (lbm_uint)cid, (lbm_uint)fv->buf, fv->buf_size);
1311}
1312
1313bool_Bool lbm_unblock_ctx_r(lbm_cid cid) {
1314 mutex_lock(&blocking_extension_mutex);
1315 bool_Bool r = false0;
1316 eval_context_t *found = NULL((void*)0);
1317 mutex_lock(&qmutex);
1318 found = lookup_ctx_nm(&blocked, cid);
1319 if (found) {
1320 drop_ctx_nm(&blocked,found);
1321 enqueue_ctx_nm(&queue,found);
1322 r = true1;
1323 }
1324 mutex_unlock(&qmutex);
1325 mutex_unlock(&blocking_extension_mutex);
1326 return r;
1327}
1328
1329// unblock unboxed is also safe for rmbr:ed things.
1330bool_Bool lbm_unblock_ctx_unboxed(lbm_cid cid, lbm_value unboxed) {
1331 mutex_lock(&blocking_extension_mutex);
1332 bool_Bool r = false0;
1333 eval_context_t *found = NULL((void*)0);
1334 mutex_lock(&qmutex);
1335 found = lookup_ctx_nm(&blocked, cid);
1336 if (found) {
1337 drop_ctx_nm(&blocked,found);
1338 found->r = unboxed;
1339 if (lbm_is_error(unboxed)) {
1340 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
1341 found->app_cont = true1;
1342 }
1343 enqueue_ctx_nm(&queue,found);
1344 r = true1;
1345 }
1346 mutex_unlock(&qmutex);
1347 mutex_unlock(&blocking_extension_mutex);
1348 return r;
1349}
1350
1351static bool_Bool lbm_block_ctx_base(bool_Bool timeout, float t_s) {
1352 mutex_lock(&blocking_extension_mutex);
1353 blocking_extension = true1;
1354 if (timeout) {
1355 blocking_extension_timeout_us = S_TO_US(t_s)(lbm_uint)((t_s) * 1000000);
1356 blocking_extension_timeout = true1;
1357 } else {
1358 blocking_extension_timeout = false0;
1359 }
1360 return true1;
1361}
1362
1363void lbm_block_ctx_from_extension_timeout(float s) {
1364 lbm_block_ctx_base(true1, s);
1365}
1366
1367void lbm_block_ctx_from_extension(void) {
1368 lbm_block_ctx_base(false0, 0);
1369}
1370
1371// todo: May need to pop rmbrs from stack, if present.
1372// Suspect that the letting the discard cont run is really not a problem.
1373// Either way will be quite confusing what happens to allocated things when undoing block.
1374void lbm_undo_block_ctx_from_extension(void) {
1375 blocking_extension = false0;
1376 blocking_extension_timeout_us = 0;
1377 blocking_extension_timeout = false0;
1378 mutex_unlock(&blocking_extension_mutex);
1379}
1380
1381lbm_value lbm_find_receiver_and_send(lbm_cid cid, lbm_value msg) {
1382 mutex_lock(&qmutex);
1383 eval_context_t *found = NULL((void*)0);
1384 bool_Bool found_blocked = false0;
1385
1386 found = lookup_ctx_nm(&blocked, cid);
1387 if (found) found_blocked = true1;
1388
1389 if (found == NULL((void*)0)) {
1390 found = lookup_ctx_nm(&queue, cid);
1391 }
1392
1393 if (found) {
1394 if (!mailbox_add_mail(found, msg)) {
1395 mutex_unlock(&qmutex);
1396 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1397 }
1398
1399 if (found_blocked){
1400 drop_ctx_nm(&blocked,found);
1401 enqueue_ctx_nm(&queue,found);
1402 }
1403 mutex_unlock(&qmutex);
1404 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1405 }
1406
1407 /* check the current context */
1408 if (ctx_running && ctx_running->id == cid) {
1409 if (!mailbox_add_mail(ctx_running, msg)) {
1410 mutex_unlock(&qmutex);
1411 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1412 }
1413 mutex_unlock(&qmutex);
1414 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1415 }
1416 mutex_unlock(&qmutex);
1417 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1418}
1419
1420/* Pattern matching is currently implemented as a recursive
1421 function and make use of stack relative to the size of
1422 expressions that are being matched. */
1423static bool_Bool match(lbm_value p, lbm_value e, lbm_value *env, bool_Bool *gc) {
1424
1425 lbm_value binding;
1426
1427 if (lbm_is_match_binder(p)) {
1428 lbm_value var = get_cadr(p);
1429 lbm_value bindertype = get_car(p);
1430
1431 if (!lbm_is_symbol(var)) return false0;
1432
1433 switch (bindertype) {
1434 case ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u):
1435 if ( var == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) {
1436 return true1;
1437 }
1438 break;
1439 default: /* this should be an error case */
1440 return false0;
1441 }
1442 binding = lbm_cons(var, e);
1443 if ( lbm_type_of(binding) == LBM_TYPE_SYMBOL0x00000000u ) {
1444 *gc = true1;
1445 return false0;
1446 }
1447 *env = lbm_cons(binding, *env);
1448 if ( lbm_type_of(*env) == LBM_TYPE_SYMBOL0x00000000u ) {
1449 *gc = true1;
1450 return false0;
1451 }
1452 return true1;
1453 }
1454
1455 if (lbm_is_symbol(p)) {
1456 if (p == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return true1;
1457 return (p == e);
1458 }
1459 if (lbm_is_cons(p) &&
1460 lbm_is_cons(e) ) {
1461
1462 lbm_value headp, tailp;
1463 lbm_value heade, taile;
1464 get_car_and_cdr(p, &headp, &tailp);
1465 get_car_and_cdr(e, &heade, &taile); // Static analysis warns, but execution does not
1466 // past this point unless head and tail get initialized.
1467 if (!match(headp, heade, env, gc)) {
1468 return false0;
1469 }
1470 return match (tailp, taile, env, gc);
1471 }
1472 return struct_eq(p, e);
1473}
1474
1475// Find match is not very picky about syntax.
1476// A completely malformed recv form is most likely to
1477// just return no_match.
1478static int find_match(lbm_value plist, lbm_value *earr, lbm_uint num, lbm_value *e, lbm_value *env) {
1479
1480 // A pattern list is a list of pattern, expression lists.
1481 // ( (p1 e1) (p2 e2) ... (pn en))
1482 lbm_value curr_p = plist;
1483 int n = 0;
1484 bool_Bool gc = false0;
1485 for (int i = 0; i < (int)num; i ++ ) {
1486 lbm_value curr_e = earr[i];
1487 while (!lbm_is_symbol_nil(curr_p)) {
1488 lbm_value me = get_car(curr_p);
1489 if (match(get_car(me), curr_e, env, &gc)) {
1490 if (gc) return FM_NEED_GC-1;
1491 *e = get_cadr(me);
1492
1493 if (!lbm_is_symbol_nil(get_cadr(get_cdr(me)))) {
1494 return FM_PATTERN_ERROR-3;
1495 }
1496 return n;
1497 }
1498 curr_p = get_cdr(curr_p);
1499 }
1500 curr_p = plist; /* search all patterns against next exp */
1501 n ++;
1502 }
1503
1504 return FM_NO_MATCH-2;
1505}
1506
1507/****************************************************/
1508/* Garbage collection */
1509
1510static void mark_context(eval_context_t *ctx, void *arg1, void *arg2) {
1511 (void) arg1;
1512 (void) arg2;
1513 lbm_value roots[3] = {ctx->curr_exp, ctx->program, ctx->r };
1514 lbm_gc_mark_env(ctx->curr_env);
1515 lbm_gc_mark_roots(roots, 3);
1516 lbm_gc_mark_roots(ctx->mailbox, ctx->num_mail);
1517 lbm_gc_mark_aux(ctx->K.data, ctx->K.sp);
1518}
1519
1520static int gc(void) {
1521 if (ctx_running) {
1522 ctx_running->state = ctx_running->state | LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1523 }
1524
1525 gc_requested = false0;
1526 lbm_gc_state_inc();
1527
1528 // The freelist should generally be NIL when GC runs.
1529 lbm_nil_freelist();
1530 lbm_value *env = lbm_get_global_env();
1531 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
1532 lbm_gc_mark_env(env[i]);
1533 }
1534
1535 mutex_lock(&qmutex); // Lock the queues.
1536 // Any concurrent messing with the queues
1537 // while doing GC cannot possibly be good.
1538 queue_iterator_nm(&queue, mark_context, NULL((void*)0), NULL((void*)0));
1539 queue_iterator_nm(&blocked, mark_context, NULL((void*)0), NULL((void*)0));
1540
1541 if (ctx_running) {
1542 mark_context(ctx_running, NULL((void*)0), NULL((void*)0));
1543 }
1544 mutex_unlock(&qmutex);
1545
1546#ifdef VISUALIZE_HEAP
1547 heap_vis_gen_image();
1548#endif
1549
1550 int r = lbm_gc_sweep_phase();
1551 lbm_heap_new_freelist_length();
1552
1553 if (ctx_running) {
1554 ctx_running->state = ctx_running->state & ~LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1555 }
1556 return r;
1557}
1558
1559int lbm_perform_gc(void) {
1560 return gc();
1561}
1562
1563/****************************************************/
1564/* Evaluation functions */
1565
1566
1567static void eval_symbol(eval_context_t *ctx) {
1568 lbm_uint s = lbm_dec_sym(ctx->curr_exp);
1569 if (s >= RUNTIME_SYMBOLS_START0x40000) {
1570 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1571 if (lbm_env_lookup_b(&res, ctx->curr_exp, ctx->curr_env) ||
1572 lbm_global_env_lookup(&res, ctx->curr_exp)) {
1573 ctx->r = res;
1574 ctx->app_cont = true1;
1575 return;
1576 }
1577 // Dynamic load attempt
1578 // Only symbols of kind RUNTIME can be dynamically loaded.
1579 const char *sym_str = lbm_get_name_by_symbol(s);
1580 const char *code_str = NULL((void*)0);
1581 if (!dynamic_load_callback(sym_str, &code_str)) {
1582 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), ctx->curr_exp);
1583 }
1584 lbm_value *sptr = stack_reserve(ctx, 3);
1585 sptr[0] = ctx->curr_exp;
1586 sptr[1] = ctx->curr_env;
1587 sptr[2] = RESUME(((12) << 2) | 0xF8000001u);
1588
1589 lbm_value chan;
1590 if (!create_string_channel((char *)code_str, &chan)) {
1591 gc();
1592 if (!create_string_channel((char *)code_str, &chan)) {
1593 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1594 }
1595 }
1596
1597 lbm_value loader;
1598 WITH_GC_RMBR_1(loader, lbm_heap_allocate_list_init(2,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1599 ENC_SYM_READ,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1600 chan), chan)(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} };
1601 lbm_value evaluator;
1602 WITH_GC_RMBR_1(evaluator, lbm_heap_allocate_list_init(2,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1603 ENC_SYM_EVAL,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1604 loader), loader)(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } };
1605 ctx->curr_exp = evaluator;
1606 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // dynamics should be evaluable in empty local env
1607 } else {
1608 //special symbols and extensions can be handled the same way.
1609 ctx->r = ctx->curr_exp;
1610 ctx->app_cont = true1;
1611 }
1612}
1613
1614static void eval_quote(eval_context_t *ctx) {
1615 ctx->r = get_cadr(ctx->curr_exp);
1616 ctx->app_cont = true1;
1617}
1618
1619static void eval_selfevaluating(eval_context_t *ctx) {
1620 ctx->r = ctx->curr_exp;
1621 ctx->app_cont = true1;
1622}
1623
1624static void eval_progn(eval_context_t *ctx) {
1625 lbm_value exps = get_cdr(ctx->curr_exp);
1626
1627 if (lbm_is_cons(exps)) {
1628 lbm_uint *sptr = stack_reserve(ctx, 4);
1629 sptr[0] = ctx->curr_env; // env to restore between expressions in progn
1630 sptr[1] = lbm_enc_u(0); // Has env been copied (needed for progn local bindings)
1631 sptr[3] = PROGN_REST(((4) << 2) | 0xF8000001u);
1632 get_car_and_cdr(exps, &ctx->curr_exp, &sptr[2]);
1633 if (lbm_is_symbol(sptr[2])) /* The only symbol it can be is nil */
1634 lbm_stack_drop(&ctx->K, 4);
1635 } else if (lbm_is_symbol_nil(exps)) {
1636 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1637 ctx->app_cont = true1;
1638 } else {
1639 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1640 }
1641}
1642
1643static void eval_atomic(eval_context_t *ctx) {
1644 if (is_atomic) {
1645 lbm_set_error_reason("Atomic blocks cannot be nested!");
1646 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1647 }
1648 stack_reserve(ctx, 1)[0] = EXIT_ATOMIC(((14) << 2) | 0xF8000001u);
1649 is_atomic ++;
1650 eval_progn(ctx);
1651}
1652
1653/* (call-cc (lambda (k) .... )) */
1654static void eval_callcc(eval_context_t *ctx) {
1655 lbm_value cont_array;
1656 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1657 gc();
1658 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1659 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1660 return; // dead return but static analysis doesn't know :)
1661 }
1662 }
1663 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(cont_array);
1664 memcpy(arr->data, ctx->K.data, ctx->K.sp * sizeof(lbm_uint));
1665
1666 lbm_value acont = cons_with_gc(ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u), cont_array, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1667 lbm_value arg_list = cons_with_gc(acont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1668 // Go directly into application evaluation without passing go
1669 lbm_uint *sptr = stack_reserve(ctx, 3);
1670 sptr[0] = ctx->curr_env;
1671 sptr[1] = arg_list;
1672 sptr[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
1673 ctx->curr_exp = get_cadr(ctx->curr_exp);
1674}
1675
1676// (define sym exp)
1677#define KEY1 1
1678#define VAL2 2
1679static void eval_define(eval_context_t *ctx) {
1680 lbm_value parts[3];
1681 lbm_value rest = extract_n(ctx->curr_exp, parts, 3);
1682 lbm_uint *sptr = stack_reserve(ctx, 2);
1683 if (lbm_is_symbol(parts[KEY1]) && lbm_is_symbol_nil(rest)) {
1684 lbm_uint sym_val = lbm_dec_sym(parts[KEY1]);
1685 sptr[0] = parts[KEY1];
1686 if (sym_val >= RUNTIME_SYMBOLS_START0x40000) {
1687 sptr[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
1688 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02) {
1689 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
1690 }
1691 ctx->curr_exp = parts[VAL2];
1692 return;
1693 }
1694 }
1695 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
1696}
1697
1698
1699/* Eval lambda is cheating, a lot! It does this
1700 for performance reasons. The cheats are that
1701 1. When closure is created, a reference to the local env
1702 in which the lambda was evaluated is added to the closure.
1703 Ideally it should have created a list of free variables in the function
1704 and then looked up the values of these creating a new environment.
1705 2. The global env is considered global constant. As there is no copying
1706 of environment bindings into the closure, undefine may break closures.
1707
1708 Correct closure creation is a lot more expensive than what happens here.
1709 However, one can try to write programs in such a way that closures are created
1710 seldomly. If one does that the space-usage benefits of "correct" closures
1711 may outweigh the performance gain of "incorrect" ones.
1712
1713 some obscure programs such as test_setq_local_closure.lisp does not
1714 work properly due to this cheating.
1715 */
1716// (lambda param-list body-exp) -> (closure param-list body-exp env)
1717static void eval_lambda(eval_context_t *ctx) {
1718 lbm_value vals[3];
1719 extract_n(ctx->curr_exp, vals, 3);
1720 ctx->r = allocate_closure(vals[1],vals[2], ctx->curr_env);
1721#ifdef CLEAN_UP_CLOSURES
1722 lbm_uint sym_id = 0;
1723 if (clean_cl_env_symbol) {
1724 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1725 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1726 ctx->curr_exp = app;
1727 } else if (lbm_get_symbol_by_name("clean-cl-env", &sym_id)) {
1728 clean_cl_env_symbol = lbm_enc_sym(sym_id);
1729 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1730 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1731 ctx->curr_exp = app;
1732 } else {
1733 ctx->app_cont = true1;
1734 }
1735#else
1736 ctx->app_cont = true1;
1737#endif
1738}
1739
1740// (if cond-expr then-expr else-expr)
1741static void eval_if(eval_context_t *ctx) {
1742 lbm_value cdr = get_cdr(ctx->curr_exp);
1743 lbm_value *sptr = stack_reserve(ctx, 3);
1744 sptr[0] = get_cdr(cdr);
1745 sptr[1] = ctx->curr_env;
1746 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1747 ctx->curr_exp = get_car(cdr);
1748}
1749
1750// (cond (cond-expr-1 expr-1)
1751// ...
1752// (cond-expr-N expr-N))
1753static void eval_cond(eval_context_t *ctx) {
1754 lbm_value cond1[2];
1755 lbm_value rest_conds = extract_n(ctx->curr_exp, cond1, 2);
1756
1757 // end recursion at (cond )
1758 if (lbm_is_symbol_nil(cond1[1])) {
1759 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1760 ctx->app_cont = true1;
1761 } else {
1762 // Cond is one of the few places where a bit of syntax checking takes place at runtime..
1763 // Maybe dont bother?
1764 lbm_uint len = lbm_list_length(cond1[1]);
1765 if (len != 2) {
1766 lbm_set_error_reason("Incorrect syntax in cond");
1767 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1768 }
1769 lbm_value cond_expr[2];
1770 extract_n(cond1[1], cond_expr, 2);
1771 lbm_value rest;
1772 WITH_GC(rest, lbm_heap_allocate_list_init(2,(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1773 cond_expr[1], // Then branch(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1774 cons_with_gc(ENC_SYM_COND, rest_conds , ENC_SYM_NIL)))(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
1775 lbm_value *sptr = stack_reserve(ctx, 3);
1776 sptr[0] = rest;
1777 sptr[1] = ctx->curr_env;
1778 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1779 ctx->curr_exp = cond_expr[0]; //condition;
1780 }
1781}
1782
1783static void eval_app_cont(eval_context_t *ctx) {
1784 lbm_stack_drop(&ctx->K, 1);
1785 ctx->app_cont = true1;
1786}
1787
1788// Create a named location in an environment to later receive a value.
1789static binding_location_status create_binding_location_internal(lbm_value key, lbm_value *env) {
1790
1791 if (lbm_is_symbol(key) &&
1792 (key == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u) ||
1793 key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)))
1794 return BL_OK;
1795
1796 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) { // default case
1797 lbm_value binding;
1798 lbm_value new_env_tmp;
1799 binding = lbm_cons(key, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1800 new_env_tmp = lbm_cons(binding, *env);
1801 if (lbm_is_symbol(binding) || lbm_is_symbol(new_env_tmp)) {
1802 return BL_NO_MEMORY;
1803 }
1804 *env = new_env_tmp;
1805 } else if (lbm_is_cons(key)) { // deconstruct case
1806 int r = create_binding_location_internal(get_car(key), env);
1807 if (r == BL_OK) {
1808 r = create_binding_location_internal(get_cdr(key), env);
1809 }
1810 return r;
1811 }
1812 return BL_OK;
1813}
1814
1815static void create_binding_location(lbm_value key, lbm_value *env) {
1816
1817 lbm_value env_tmp = *env;
1818 binding_location_status r = create_binding_location_internal(key, &env_tmp);
1819 if (r != BL_OK) {
1820 if (r == BL_NO_MEMORY) {
1821 env_tmp = *env;
1822 lbm_gc_mark_phase(env_tmp);
1823 gc();
1824 r = create_binding_location_internal(key, &env_tmp);
1825 }
1826 switch(r) {
1827 case BL_OK:
1828 break;
1829 case BL_NO_MEMORY:
1830 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1831 break;
1832 case BL_INCORRECT_KEY:
1833 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
1834 break;
1835 }
1836 }
1837 *env = env_tmp;
1838}
1839
1840static void let_bind_values_eval(lbm_value binds, lbm_value exp, lbm_value env, eval_context_t *ctx) {
1841
1842 if (!lbm_is_cons(binds)) {
1843 // binds better be nil or there is a programmer error.
1844 ctx->curr_exp = exp;
1845 return;
1846 }
1847
1848 // Preallocate binding locations.
1849 lbm_value curr = binds;
1850 while (lbm_is_cons(curr)) {
1851 lbm_value new_env_tmp = env;
1852 lbm_value car_curr, cdr_curr;
1853 get_car_and_cdr(curr, &car_curr, &cdr_curr);
1854 lbm_value key = get_car(car_curr);
1855 create_binding_location(key, &new_env_tmp);
1856 env = new_env_tmp;
1857 curr = cdr_curr;
1858 }
1859
1860 lbm_value car_binds;
1861 lbm_value cdr_binds;
1862 get_car_and_cdr(binds, &car_binds, &cdr_binds);
1863 lbm_value key_val[2];
1864 extract_n(car_binds, key_val, 2);
1865
1866 lbm_uint *sptr = stack_reserve(ctx, 5);
1867 sptr[0] = exp;
1868 sptr[1] = cdr_binds;
1869 sptr[2] = env;
1870 sptr[3] = key_val[0];
1871 sptr[4] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
1872 ctx->curr_exp = key_val[1];
1873 ctx->curr_env = env;
1874}
1875
1876// (var x (...)) - local binding inside of an progn
1877// var has to take, place root-level nesting within progn.
1878// (progn ... (var a 10) ...) OK!
1879// (progn ... (something (var a 10)) ... ) NOT OK!
1880/* progn stack
1881 sp-4 : env
1882 sp-3 : 0
1883 sp-2 : rest
1884 sp-1 : PROGN_REST
1885*/
1886static void eval_var(eval_context_t *ctx) {
1887
1888 if (ctx->K.sp >= 4) { // Possibly in progn
1889 lbm_value sv = ctx->K.data[ctx->K.sp - 1];
1890 if (IS_CONTINUATION(sv)(((sv) & 0xF8000001u) == 0xF8000001u) && (sv == PROGN_REST(((4) << 2) | 0xF8000001u))) {
1891 lbm_uint sp = ctx->K.sp;
1892 uint32_t is_copied = lbm_dec_as_u32(ctx->K.data[sp-3]);
1893 if (is_copied == 0) {
1894 lbm_value env;
1895 WITH_GC(env, lbm_env_copy_spine(ctx->K.data[sp-4]))(env) = (lbm_env_copy_spine(ctx->K.data[sp-4])); if (lbm_is_symbol_merror
((env))) { gc(); (env) = (lbm_env_copy_spine(ctx->K.data[sp
-4])); if (lbm_is_symbol_merror((env))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1896 ctx->K.data[sp-3] = lbm_enc_u(1);
1897 ctx->K.data[sp-4] = env;
1898 }
1899 lbm_value new_env = ctx->K.data[sp-4];
1900 lbm_value args = get_cdr(ctx->curr_exp);
1901 lbm_value key = get_car(args);
1902 create_binding_location(key, &new_env);
1903 ctx->K.data[sp-4] = new_env;
1904
1905 lbm_value v_exp = get_cadr(args);
1906 lbm_value *sptr = stack_reserve(ctx, 3);
1907 sptr[0] = new_env;
1908 sptr[1] = key;
1909 sptr[2] = PROGN_VAR(((29) << 2) | 0xF8000001u);
1910 // Activating the new environment before the evaluation of the value to be bound,
1911 // means that other variables with same name will be shadowed already in the value
1912 // body.
1913 // The way closures work, the var-variable needs to be in scope during val evaluation
1914 // for a recursive closure to be possible.
1915 ctx->curr_env = new_env;
1916 ctx->curr_exp = v_exp;
1917 return;
1918 }
1919 }
1920 lbm_set_error_reason((char*)lbm_error_str_var_outside_progn);
1921 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1922}
1923
1924// (setq x (...)) - same as (set 'x (...)) or (setvar 'x (...))
1925static void eval_setq(eval_context_t *ctx) {
1926 lbm_value parts[3];
1927 extract_n(ctx->curr_exp, parts, 3);
1928 lbm_value *sptr = stack_reserve(ctx, 3);
1929 sptr[0] = ctx->curr_env;
1930 sptr[1] = parts[1];
1931 sptr[2] = SETQ(((30) << 2) | 0xF8000001u);
1932 ctx->curr_exp = parts[2];
1933}
1934
1935static void eval_move_to_flash(eval_context_t *ctx) {
1936 lbm_value args = get_cdr(ctx->curr_exp);
1937 lbm_value *sptr = stack_reserve(ctx,2);
1938 sptr[0] = args;
1939 sptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
1940 ctx->app_cont = true1;
1941}
1942
1943// (loop list-of-local-bindings
1944// condition-exp
1945// body-exp)
1946static void eval_loop(eval_context_t *ctx) {
1947 lbm_value env = ctx->curr_env;
1948 lbm_value parts[3];
1949 extract_n(get_cdr(ctx->curr_exp), parts, 3);
1950 lbm_value *sptr = stack_reserve(ctx, 3);
1951 sptr[0] = parts[LOOP_BODY2];
1952 sptr[1] = parts[LOOP_COND1];
1953 sptr[2] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
1954 let_bind_values_eval(parts[LOOP_BINDS0], parts[LOOP_COND1], env, ctx);
1955}
1956
1957/* (trap expression)
1958 *
1959 * suggested use:
1960 * (match (trap expression)
1961 * ((exit-error (? err)) (error-handler err))
1962 * ((exit-ok (? v)) (value-handler v)))
1963 */
1964static void eval_trap(eval_context_t *ctx) {
1965
1966 lbm_value expr = get_cadr(ctx->curr_exp);
1967 lbm_value retval;
1968 WITH_GC(retval, lbm_heap_allocate_list(2))(retval) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((retval))) { gc(); (retval) = (lbm_heap_allocate_list(2)); if
(lbm_is_symbol_merror((retval))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1969 lbm_set_car(retval, ENC_SYM_EXIT_OK(((0x3000B) << 4) | 0x00000000u)); // Assume things will go well.
1970 lbm_uint *sptr = stack_reserve(ctx,3);
1971 sptr[0] = retval;
1972 sptr[1] = ctx->flags;
1973 sptr[2] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1974 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10;
1975 ctx->curr_exp = expr;
1976}
1977
1978// (let list-of-binding s
1979// body-exp)
1980static void eval_let(eval_context_t *ctx) {
1981 lbm_value env = ctx->curr_env;
1982 lbm_value parts[3];
1983 extract_n(ctx->curr_exp, parts, 3);
1984 let_bind_values_eval(parts[1], parts[2], env, ctx);
1985}
1986
1987// (and exp0 ... expN)
1988static void eval_and(eval_context_t *ctx) {
1989 lbm_value rest = get_cdr(ctx->curr_exp);
1990 if (lbm_is_symbol_nil(rest)) {
1991 ctx->app_cont = true1;
1992 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1993 } else {
1994 lbm_value *sptr = stack_reserve(ctx, 3);
1995 sptr[0] = ctx->curr_env;
1996 sptr[1] = get_cdr(rest);
1997 sptr[2] = AND(((6) << 2) | 0xF8000001u);
1998 ctx->curr_exp = get_car(rest);
1999 }
2000}
2001
2002// (or exp0 ... expN)
2003static void eval_or(eval_context_t *ctx) {
2004 lbm_value rest = get_cdr(ctx->curr_exp);
2005 if (lbm_is_symbol_nil(rest)) {
2006 ctx->app_cont = true1;
2007 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2008 } else {
2009 lbm_value *sptr = stack_reserve(ctx, 3);
2010 sptr[0] = ctx->curr_env;
2011 sptr[1] = get_cdr(rest);
2012 sptr[2] = OR(((7) << 2) | 0xF8000001u);
2013 ctx->curr_exp = get_car(rest);
2014 }
2015}
2016
2017// Pattern matching
2018// format:
2019// (match e (pattern body)
2020// (pattern body)
2021// ... )
2022//
2023// There can be an optional pattern guard:
2024// (match e (pattern guard body)
2025// ... )
2026// a guard is a boolean expression.
2027// Guards make match, pattern matching more complicated
2028// than the recv pattern matching and requires staged execution
2029// via the continuation system rather than a while loop over a list.
2030static void eval_match(eval_context_t *ctx) {
2031
2032 lbm_value rest = get_cdr(ctx->curr_exp);
2033 if (lbm_type_of(rest) == LBM_TYPE_SYMBOL0x00000000u &&
2034 rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
2035 // Someone wrote the program (match)
2036 ctx->app_cont = true1;
2037 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2038 } else {
2039 lbm_value cdr_rest;
2040 get_car_and_cdr(rest, &ctx->curr_exp, &cdr_rest);
2041 lbm_value *sptr = stack_reserve(ctx, 3);
2042 sptr[0] = cdr_rest;
2043 sptr[1] = ctx->curr_env;
2044 sptr[2] = MATCH(((9) << 2) | 0xF8000001u);
2045 }
2046}
2047
2048static void receive_base(eval_context_t *ctx, lbm_value pats, float timeout_time, bool_Bool timeout) {
2049 if (ctx->num_mail == 0) {
2050 if (timeout) {
2051 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000), false0);
2052 } else {
2053 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1,0,false0);
2054 }
2055 } else {
2056 lbm_value *msgs = ctx->mailbox;
2057 lbm_uint num = ctx->num_mail;
2058
2059 if (lbm_is_symbol_nil(pats)) {
2060 /* A receive statement without any patterns */
2061 ctx->app_cont = true1;
2062 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2063 } else {
2064 /* The common case */
2065 lbm_value e;
2066 lbm_value new_env = ctx->curr_env;
2067 int n = find_match(pats, msgs, num, &e, &new_env);
2068 if (n == FM_NEED_GC-1) {
2069 gc();
2070 new_env = ctx->curr_env;
2071 n = find_match(pats, msgs, num, &e, &new_env);
2072 if (n == FM_NEED_GC-1) {
2073 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2074 }
2075 }
2076 if (n == FM_PATTERN_ERROR-3) {
2077 lbm_set_error_reason("Incorrect pattern format for recv");
2078 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),pats);
2079 } else if (n >= 0 ) { /* Match */
2080 mailbox_remove_mail(ctx, (lbm_uint)n);
2081 ctx->curr_env = new_env;
2082 ctx->curr_exp = e;
2083 } else { /* No match go back to sleep */
2084 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
2085 if (timeout) {
2086 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2,S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000),false0);
2087 } else {
2088 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,false0);
2089 }
2090 }
2091 }
2092 }
2093 return;
2094}
2095
2096static void eval_receive_timeout(eval_context_t *ctx) {
2097 if (is_atomic) {
2098 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2099 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2100 }
2101 lbm_value timeout_val = get_cadr(ctx->curr_exp);
2102 if (!lbm_is_number(timeout_val)) {
2103 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2104 }
2105 float timeout_time = lbm_dec_as_float(timeout_val);
2106 lbm_value pats = get_cdr(get_cdr(ctx->curr_exp));
2107 receive_base(ctx, pats, timeout_time, true1);
2108}
2109
2110// Receive
2111// (recv (pattern expr)
2112// (pattern expr))
2113static void eval_receive(eval_context_t *ctx) {
2114
2115 if (is_atomic) {
2116 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2117 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
2118 }
2119 lbm_value pats = get_cdr(ctx->curr_exp);
2120 receive_base(ctx, pats, 0, false0);
2121}
2122
2123/*********************************************************/
2124/* Continuation functions */
2125
2126/* cont_set_global_env
2127 sp-1 : Key-symbol
2128 */
2129static void cont_set_global_env(eval_context_t *ctx){
2130
2131 lbm_value key;
2132 lbm_value val = ctx->r;
2133
2134 lbm_pop(&ctx->K, &key);
2135 lbm_uint dec_key = lbm_dec_sym(key);
2136 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
2137 lbm_value *global_env = lbm_get_global_env();
2138 lbm_uint orig_env = global_env[ix_key];
2139 lbm_value new_env;
2140 // A key is a symbol and should not need to be remembered.
2141 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2142
2143 global_env[ix_key] = new_env;
2144 ctx->r = val;
2145
2146 ctx->app_cont = true1;
2147
2148 return;
2149}
2150
2151static void cont_resume(eval_context_t *ctx) {
2152 lbm_pop_2(&ctx->K, &ctx->curr_env, &ctx->curr_exp);
2153}
2154
2155static void cont_progn_rest(eval_context_t *ctx) {
2156 lbm_value *sptr = get_stack_ptr(ctx, 3);
2157
2158 lbm_value rest = sptr[2];
2159 lbm_value env = sptr[0];
2160
2161 lbm_value rest_car, rest_cdr;
2162 get_car_and_cdr(rest, &rest_car, &rest_cdr);
2163 ctx->curr_exp = rest_car;
2164 ctx->curr_env = env;
2165 if (lbm_is_symbol_nil(rest_cdr)) {
2166 // allow for tail recursion
2167 lbm_stack_drop(&ctx->K, 3);
2168 } else {
2169 sptr[2] = rest_cdr;
2170 stack_reserve(ctx, 1)[0] = PROGN_REST(((4) << 2) | 0xF8000001u);
2171 }
2172}
2173
2174static void cont_wait(eval_context_t *ctx) {
2175
2176 lbm_value cid_val;
2177 lbm_pop(&ctx->K, &cid_val);
2178 lbm_cid cid = (lbm_cid)lbm_dec_i(cid_val);
2179
2180 bool_Bool exists = false0;
2181
2182 lbm_blocked_iterator(context_exists, &cid, &exists);
2183 lbm_running_iterator(context_exists, &cid, &exists);
2184
2185 if (ctx_running->id == cid) {
2186 exists = true1;
2187 }
2188
2189 if (exists) {
2190 lbm_value *sptr = stack_reserve(ctx, 2);
2191 sptr[0] = lbm_enc_i(cid);
2192 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2193 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2194 ctx->app_cont = true1;
2195 yield_ctx(50000);
2196 } else {
2197 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2198 ctx->app_cont = true1;
2199 }
2200}
2201
2202static lbm_value perform_setvar(lbm_value key, lbm_value val, lbm_value env) {
2203
2204 lbm_uint s = lbm_dec_sym(key);
2205 if (s >= RUNTIME_SYMBOLS_START0x40000) {
2206 lbm_value new_env = lbm_env_modify_binding(env, key, val);
2207 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2208 lbm_uint ix_key = lbm_dec_sym(key) & GLOBAL_ENV_MASK0x1F;
2209 lbm_value *glob_env = lbm_get_global_env();
2210 new_env = lbm_env_modify_binding(glob_env[ix_key], key, val);
2211 glob_env[ix_key] = new_env;
2212 }
2213 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2214 lbm_set_error_reason((char*)lbm_error_str_variable_not_bound);
2215 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), key);
2216 }
2217 return val;
2218 }
2219 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2220 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // unreachable
2221}
2222
2223static void apply_setvar(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2224 if (nargs == 2 && lbm_is_symbol(args[0])) {
2225 lbm_value res;
2226 WITH_GC(res, perform_setvar(args[0], args[1], ctx->curr_env))(res) = (perform_setvar(args[0], args[1], ctx->curr_env));
if (lbm_is_symbol_merror((res))) { gc(); (res) = (perform_setvar
(args[0], args[1], ctx->curr_env)); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2227 ctx->r = args[1];
2228 lbm_stack_drop(&ctx->K, nargs+1);
2229 ctx->app_cont = true1;
2230 } else {
2231 if (nargs == 2) lbm_set_error_reason((char*)lbm_error_str_incorrect_arg);
2232 else lbm_set_error_reason((char*)lbm_error_str_num_args);
2233 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2234 }
2235}
2236
2237static void apply_read_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, bool_Bool program, bool_Bool incremental) {
2238 if (nargs == 1) {
2239 lbm_value chan = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2240 if (lbm_type_of_functional(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2241 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2242 gc();
2243 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2244 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2245 }
2246 }
2247 } else if (lbm_type_of(args[0]) == LBM_TYPE_CHANNEL0x90000000u) {
2248 chan = args[0];
2249 } else {
2250 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2251 }
2252 lbm_value *sptr = get_stack_ptr(ctx, 2);
2253
2254 // If we are inside a reader, its settings are stored.
2255 sptr[0] = lbm_enc_u(ctx->flags); // flags stored.
2256 sptr[1] = chan;
2257 lbm_value *rptr = stack_reserve(ctx,1);
2258 rptr[0] = READ_DONE(((20) << 2) | 0xF8000001u);
2259
2260 // Each reader starts in a fresh situation
2261 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
2262
2263 if (program) {
2264 if (incremental) {
2265 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2266 lbm_value *rptr1 = stack_reserve(ctx,3);
2267 rptr1[0] = chan;
2268 rptr1[1] = ctx->curr_env;
2269 rptr1[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
2270 } else {
2271 ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2272 lbm_value *rptr1 = stack_reserve(ctx,4);
2273 rptr1[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2274 rptr1[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2275 rptr1[2] = chan;
2276 rptr1[3] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
2277 }
2278 }
2279 rptr = stack_reserve(ctx,3); // reuse of variable rptr
2280 rptr[0] = chan;
2281 rptr[1] = lbm_enc_u(1);
2282 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
2283 ctx->app_cont = true1;
2284 } else {
2285 lbm_set_error_reason((char*)lbm_error_str_num_args);
2286 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2287 }
2288}
2289
2290static void apply_read_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2291 apply_read_base(args,nargs,ctx,true1,false0);
2292}
2293
2294static void apply_read_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2295 apply_read_base(args,nargs,ctx,true1,true1);
2296}
2297
2298static void apply_read(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2299 apply_read_base(args,nargs,ctx,false0,false0);
2300}
2301
2302static void apply_spawn_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, uint32_t context_flags) {
2303
2304 lbm_uint stack_size = EVAL_CPS_DEFAULT_STACK_SIZE256;
2305 lbm_uint closure_pos = 0;
2306 char *name = NULL((void*)0);
2307
2308 if (nargs >= 1 &&
2309 lbm_is_closure(args[0])) {
2310 closure_pos = 0;
2311 } else if (nargs >= 2 &&
2312 lbm_is_number(args[0]) &&
2313 lbm_is_closure(args[1])) {
2314 stack_size = lbm_dec_as_u32(args[0]);
2315 closure_pos = 1;
2316 } else if (nargs >= 2 &&
2317 lbm_is_array_r(args[0]) &&
2318 lbm_is_closure(args[1])) {
2319 name = lbm_dec_str(args[0]);
2320 closure_pos = 1;
2321 }else if (nargs >= 3 &&
2322 lbm_is_array_r(args[0]) &&
2323 lbm_is_number(args[1]) &&
2324 lbm_is_closure(args[2])) {
2325 stack_size = lbm_dec_as_u32(args[1]);
2326 closure_pos = 2;
2327 name = lbm_dec_str(args[0]);
2328 } else {
2329 if (context_flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01)
2330 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN_TRAP(((0x30005) << 4) | 0x00000000u));
2331 else
2332 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN(((0x30004) << 4) | 0x00000000u));
2333 }
2334
2335 lbm_value cl[3];
2336 extract_n(get_cdr(args[closure_pos]), cl, 3);
2337 lbm_value curr_param = cl[CLO_PARAMS0];
2338 lbm_value clo_env = cl[CLO_ENV2];
2339 lbm_uint i = closure_pos + 1;
2340 while (lbm_is_cons(curr_param) && i <= nargs) {
2341 lbm_value entry = cons_with_gc(get_car(curr_param), args[i], clo_env);
2342 lbm_value aug_env = cons_with_gc(entry, clo_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2343 clo_env = aug_env;
2344 curr_param = get_cdr(curr_param);
2345 i ++;
2346 }
2347
2348 lbm_stack_drop(&ctx->K, nargs+1);
2349
2350 lbm_value program = cons_with_gc(cl[CLO_BODY1], ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), clo_env);
2351
2352 lbm_cid cid = lbm_create_ctx_parent(program,
2353 clo_env,
2354 stack_size,
2355 lbm_get_current_cid(),
2356 context_flags,
2357 name);
2358 ctx->r = lbm_enc_i(cid);
2359 ctx->app_cont = true1;
2360}
2361
2362static void apply_spawn(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2363 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00);
2364}
2365
2366static void apply_spawn_trap(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2367 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01);
2368}
2369
2370static void apply_yield(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2371 if (is_atomic) {
2372 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2373 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2374 }
2375 if (nargs == 1 && lbm_is_number(args[0])) {
2376 lbm_uint ts = lbm_dec_as_u32(args[0]);
2377 lbm_stack_drop(&ctx->K, nargs+1);
2378 yield_ctx(ts);
2379 } else {
2380 lbm_set_error_reason((char*)lbm_error_str_no_number);
2381 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2382 }
2383}
2384
2385static void apply_sleep(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2386 if (is_atomic) {
2387 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2388 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2389 }
2390 if (nargs == 1 && lbm_is_number(args[0])) {
2391 lbm_uint ts = (lbm_uint)(1000000.0f * lbm_dec_as_float(args[0]));
2392 lbm_stack_drop(&ctx->K, nargs+1);
2393 yield_ctx(ts);
2394 } else {
2395 lbm_set_error_reason((char*)lbm_error_str_no_number);
2396 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2397 }
2398}
2399
2400static void apply_wait(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2401 if (nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2402 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2403 lbm_value *sptr = get_stack_ptr(ctx, 2);
2404 sptr[0] = lbm_enc_i(cid);
2405 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2406 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2407 ctx->app_cont = true1;
2408 yield_ctx(50000);
2409 } else {
2410 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_WAIT(((0x30007) << 4) | 0x00000000u));
2411 }
2412}
2413
2414/* (eval expr)
2415 (eval env expr) */
2416static void apply_eval(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2417 if ( nargs == 1) {
2418 ctx->curr_exp = args[0];
2419 } else if (nargs == 2) {
2420 ctx->curr_exp = args[1];
2421 ctx->curr_env = args[0];
2422 } else {
2423 lbm_set_error_reason((char*)lbm_error_str_num_args);
2424 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL(((0x30008) << 4) | 0x00000000u));
2425 }
2426 lbm_stack_drop(&ctx->K, nargs+1);
2427}
2428
2429static void apply_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2430 int prg_pos = 0;
2431 if (nargs == 2) {
2432 prg_pos = 1;
2433 ctx->curr_env = args[0];
2434 }
2435 if (nargs == 1 || nargs == 2) {
2436 lbm_value prg = args[prg_pos];
2437 lbm_value app_cont;
2438 lbm_value app_cont_prg;
2439 lbm_value new_prg;
2440 lbm_value prg_copy;
2441
2442 int len = -1;
2443 WITH_GC(prg_copy, lbm_list_copy(&len, prg))(prg_copy) = (lbm_list_copy(&len, prg)); if (lbm_is_symbol_merror
((prg_copy))) { gc(); (prg_copy) = (lbm_list_copy(&len, prg
)); if (lbm_is_symbol_merror((prg_copy))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2444 lbm_stack_drop(&ctx->K, nargs+1);
2445
2446 if (ctx->K.sp > nargs+2) { // if there is a continuation
2447 app_cont = cons_with_gc(ENC_SYM_APP_CONT(((0x111) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2448 app_cont_prg = cons_with_gc(app_cont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2449 new_prg = lbm_list_append(app_cont_prg, ctx->program);
2450 new_prg = lbm_list_append(prg_copy, new_prg);
2451 } else {
2452 new_prg = lbm_list_append(prg_copy, ctx->program);
2453 }
2454 if (!lbm_is_list(new_prg)) {
2455 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2456 }
2457 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);
2458 ctx->program = get_cdr(new_prg);
2459 ctx->curr_exp = get_car(new_prg);
2460 } else {
2461 lbm_set_error_reason((char*)lbm_error_str_num_args);
2462 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2463 }
2464}
2465
2466static void apply_send(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2467 if (nargs == 2) {
2468 if (lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2469 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2470 lbm_value msg = args[1];
2471 lbm_value status = lbm_find_receiver_and_send(cid, msg);
2472 /* return the status */
2473 lbm_stack_drop(&ctx->K, nargs+1);
2474 ctx->r = status;
2475 ctx->app_cont = true1;
2476 } else {
2477 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2478 }
2479 } else {
2480 lbm_set_error_reason((char*)lbm_error_str_num_args);
2481 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2482 }
2483}
2484
2485static void apply_ok(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2486 lbm_value ok_val = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2487 if (nargs >= 1) {
2488 ok_val = args[0];
2489 }
2490 ctx->r = ok_val;
2491 ok_ctx();
2492}
2493
2494static void apply_error(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2495 (void) ctx;
2496 lbm_value err_val = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
2497 if (nargs >= 1) {
2498 err_val = args[0];
2499 }
2500 error_at_ctx(err_val, ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
2501}
2502
2503// (map f arg-list)
2504static void apply_map(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2505 if (nargs == 2 && lbm_is_cons(args[1])) {
2506 lbm_value *sptr = get_stack_ptr(ctx, 3);
2507
2508 lbm_value f = args[0];
2509 lbm_value h = get_car(args[1]);
2510 lbm_value t = get_cdr(args[1]);
2511
2512 lbm_value appli_1;
2513 lbm_value appli;
2514 WITH_GC(appli_1, lbm_heap_allocate_list(2))(appli_1) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli_1))) { gc(); (appli_1) = (lbm_heap_allocate_list(2));
if (lbm_is_symbol_merror((appli_1))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2515 WITH_GC_RMBR_1(appli, lbm_heap_allocate_list(2), appli_1)(appli) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli))) { lbm_gc_mark_phase(appli_1); gc(); (appli) = (lbm_heap_allocate_list
(2)); if (lbm_is_symbol_merror((appli))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2516
2517 lbm_value appli_0 = get_cdr(appli_1);
2518
2519 lbm_set_car_and_cdr(appli_0, h, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2520 lbm_set_car(appli_1, ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u));
2521
2522 lbm_set_car_and_cdr(get_cdr(appli), appli_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2523 lbm_set_car(appli, f);
2524
2525 lbm_value elt = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), appli);
2526 sptr[0] = t; // reuse stack space
2527 sptr[1] = ctx->curr_env;
2528 sptr[2] = elt;
2529 lbm_value *rptr = stack_reserve(ctx,4);
2530 rptr[0] = elt;
2531 rptr[1] = appli;
2532 rptr[2] = appli_0;
2533 rptr[3] = MAP(((26) << 2) | 0xF8000001u);
2534 ctx->curr_exp = appli;
2535 } else if (nargs == 2 && lbm_is_symbol_nil(args[1])) {
2536 lbm_stack_drop(&ctx->K, 3);
2537 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2538 ctx->app_cont = true1;
2539 return;
2540 } else {
2541 lbm_set_error_reason((char*)lbm_error_str_num_args);
2542 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_MAP(((0x3000D) << 4) | 0x00000000u));
2543 }
2544}
2545
2546static void apply_reverse(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2547 if (nargs == 1 && lbm_is_list(args[0])) {
2548 lbm_value curr = args[0];
2549
2550 lbm_value new_list = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2551 while (lbm_is_cons(curr)) {
2552 lbm_value tmp = cons_with_gc(get_car(curr), new_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2553 new_list = tmp;
2554 curr = get_cdr(curr);
2555 }
2556 lbm_stack_drop(&ctx->K, 2);
2557 ctx->r = new_list;
2558 ctx->app_cont = true1;
2559 } else {
2560 lbm_set_error_reason("Reverse requires a list argument");
2561 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_REVERSE(((0x3000E) << 4) | 0x00000000u));
2562 }
2563}
2564
2565static void apply_flatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2566 if (nargs == 1) {
2567
2568 lbm_value v = flatten_value(args[0]);
2569 if ( v == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)) {
2570 gc();
2571 v = flatten_value(args[0]);
2572 }
2573
2574 if (lbm_is_symbol(v)) {
2575 error_at_ctx(v, ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2576 } else {
2577 lbm_stack_drop(&ctx->K, 2);
2578 ctx->r = v;
2579 ctx->app_cont = true1;
2580 }
2581 return;
2582 }
2583 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2584}
2585
2586static void apply_unflatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2587 if(nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2588 lbm_array_header_t *array;
2589 array = (lbm_array_header_t *)get_car(args[0]);
2590
2591 lbm_flat_value_t fv;
2592 fv.buf = (uint8_t*)array->data;
2593 fv.buf_size = array->size;
2594 fv.buf_pos = 0;
2595
2596 lbm_value res;
2597
2598 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2599 if (lbm_unflatten_value(&fv, &res)) {
2600 ctx->r = res;
2601 }
2602 lbm_stack_drop(&ctx->K, 2);
2603 ctx->app_cont = true1;
2604 return;
2605 }
2606 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_UNFLATTEN(((0x30010) << 4) | 0x00000000u));
2607}
2608
2609static void apply_kill(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2610 if (nargs == 2 && lbm_is_number(args[0])) {
2611 lbm_cid cid = lbm_dec_as_i32(args[0]);
2612
2613 if (ctx->id == cid) {
2614 ctx->r = args[1];
2615 finish_ctx();
2616 return;
2617 }
2618 mutex_lock(&qmutex);
2619 eval_context_t *found = NULL((void*)0);
2620 found = lookup_ctx_nm(&blocked, cid);
2621 if (found)
2622 drop_ctx_nm(&blocked, found);
2623 else
2624 found = lookup_ctx_nm(&queue, cid);
2625 if (found)
2626 drop_ctx_nm(&queue, found);
2627
2628 if (found) {
2629 found->K.data[found->K.sp - 1] = KILL(((40) << 2) | 0xF8000001u);
2630 found->r = args[1];
2631 found->app_cont = true1;
2632 enqueue_ctx_nm(&queue,found);
2633 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2634 } else {
2635 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2636 }
2637 lbm_stack_drop(&ctx->K, 3);
2638 ctx->app_cont = true1;
2639 mutex_unlock(&qmutex);
2640 return;
2641 }
2642 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_KILL(((0x30011) << 4) | 0x00000000u));
2643}
2644
2645// (merge comparator list1 list2)
2646static void apply_merge(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2647 if (nargs == 3 && lbm_is_list(args[1]) && lbm_is_list(args[2])) {
2648
2649 if (!lbm_is_closure(args[0])) {
2650 lbm_value closure;
2651 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2652 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2653 lbm_value cl1 = lbm_cdr(closure);
2654 lbm_value par;
2655 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2656 lbm_set_car(cl1, par);
2657 lbm_value cl2 = lbm_cdr(cl1);
2658 lbm_value body;
2659 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2660 lbm_set_car(cl2, body);
2661 lbm_value cl3 = lbm_cdr(cl2);
2662 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2663
2664 // Replace operator on stack with closure and rest of the code is
2665 // compatible.
2666 args[0] = closure;
2667 }
2668
2669 // Copy input lists for functional behaviour at top-level
2670 // merge itself is in-place in the copied lists.
2671 lbm_value a;
2672 lbm_value b;
2673 int len_a = -1;
2674 int len_b = -1;
2675 WITH_GC(a, lbm_list_copy(&len_a, args[1]))(a) = (lbm_list_copy(&len_a, args[1])); if (lbm_is_symbol_merror
((a))) { gc(); (a) = (lbm_list_copy(&len_a, args[1])); if
(lbm_is_symbol_merror((a))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } };
2676 WITH_GC_RMBR_1(b, lbm_list_copy(&len_b, args[2]), a)(b) = (lbm_list_copy(&len_b, args[2])); if (lbm_is_symbol_merror
((b))) { lbm_gc_mark_phase(a); gc(); (b) = (lbm_list_copy(&
len_b, args[2])); if (lbm_is_symbol_merror((b))) { error_ctx(
(((0x23) << 4) | 0x00000000u)); } };
2677
2678 if (len_a == 0) {
2679 ctx->r = b;
2680 lbm_stack_drop(&ctx->K, 4);
2681 ctx->app_cont = true1;
2682 return;
2683 }
2684 if (len_b == 0) {
2685 ctx->r = a;
2686 lbm_stack_drop(&ctx->K, 4);
2687 ctx->app_cont = true1;
2688 return;
2689 }
2690
2691 args[1] = a; // keep safe by replacing the original on stack.
2692 args[2] = b;
2693
2694 lbm_value a_1 = a;
2695 lbm_value a_rest = lbm_cdr(a);
2696 lbm_value b_1 = b;
2697 lbm_value b_rest = lbm_cdr(b);
2698
2699 lbm_value cl[3]; // Comparator closure
2700 extract_n(lbm_cdr(args[0]), cl, 3);
2701 lbm_value cmp_env = cl[CLO_ENV2];
2702 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2703 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2704 lbm_uint len = lbm_list_length(cl[CLO_PARAMS0]);
2705 if (len == 2) {
2706 par1 = get_car(cl[CLO_PARAMS0]);
2707 par2 = get_cadr(cl[CLO_PARAMS0]);
2708 lbm_value new_env0;
2709 lbm_value new_env;
2710 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a_1)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a_1))); if (
lbm_is_symbol_merror((new_env0))) { gc(); (new_env0) = (lbm_env_set
(cmp_env, par1, lbm_car(a_1))); if (lbm_is_symbol_merror((new_env0
))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2711 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b_1)),new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1))); if (
lbm_is_symbol_merror((new_env))) { lbm_gc_mark_phase(new_env0
); gc(); (new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1
))); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2712 cmp_env = new_env;
2713 } else {
2714 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2715 }
2716 lbm_set_cdr(a_1, b_1);
2717 lbm_set_cdr(b_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2718 lbm_value cmp = cl[CLO_BODY1];
2719
2720 lbm_stack_drop(&ctx->K, 4); // TODO: Optimize drop 4 alloc 10 into alloc 6
2721 lbm_uint *sptr = stack_reserve(ctx, 10);
2722 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged list
2723 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged list
2724 sptr[2] = a_1;
2725 sptr[3] = a_rest;
2726 sptr[4] = b_rest;
2727 sptr[5] = cmp;
2728 sptr[6] = cmp_env;
2729 sptr[7] = par1;
2730 sptr[8] = par2;
2731 sptr[9] = MERGE_REST(((43) << 2) | 0xF8000001u);
2732 ctx->curr_exp = cl[CLO_BODY1];
2733 ctx->curr_env = cmp_env;
2734 return;
2735 }
2736 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MERGE(((0x30013) << 4) | 0x00000000u));
2737}
2738
2739// (sort comparator list)
2740static void apply_sort(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2741 if (nargs == 2 && lbm_is_list(args[1])) {
2742
2743 if (!lbm_is_closure(args[0])) {
2744 lbm_value closure;
2745 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2746 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2747 lbm_value cl1 = lbm_cdr(closure);
2748 lbm_value par;
2749 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2750 lbm_set_car(cl1, par);
2751 lbm_value cl2 = lbm_cdr(cl1);
2752 lbm_value body;
2753 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2754 lbm_set_car(cl2, body);
2755 lbm_value cl3 = lbm_cdr(cl2);
2756 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2757
2758 // Replace operator on stack with closure and rest of the code is
2759 // compatible.
2760 args[0] = closure;
2761 }
2762
2763 int len = -1;
2764 lbm_value list_copy;
2765 WITH_GC(list_copy, lbm_list_copy(&len, args[1]))(list_copy) = (lbm_list_copy(&len, args[1])); if (lbm_is_symbol_merror
((list_copy))) { gc(); (list_copy) = (lbm_list_copy(&len,
args[1])); if (lbm_is_symbol_merror((list_copy))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2766 if (len <= 1) {
2767 lbm_stack_drop(&ctx->K, 3);
2768 ctx->r = list_copy;
2769 ctx->app_cont = true1;
2770 return;
2771 }
2772
2773 args[1] = list_copy; // Keep safe, original replaced on stack.
2774
2775 // Take the headmost 2, 1-element sublists.
2776 lbm_value a = list_copy;
2777 lbm_value b = lbm_cdr(a);
2778 lbm_value rest = lbm_cdr(b);
2779 // Do not terminate b. keep rest of list safe from GC in the following
2780 // closure extraction.
2781 //lbm_set_cdr(a, b); // This is void
2782
2783 lbm_value cl[3]; // Comparator closure
2784 extract_n(lbm_cdr(args[0]), cl, 3);
2785 lbm_value cmp_env = cl[CLO_ENV2];
2786 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2787 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2788 lbm_uint cl_len = lbm_list_length(cl[CLO_PARAMS0]);
2789 if (cl_len == 2) {
2790 par1 = get_car(cl[CLO_PARAMS0]);
2791 par2 = get_cadr(cl[CLO_PARAMS0]);
2792 lbm_value new_env0;
2793 lbm_value new_env;
2794 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a))); if (lbm_is_symbol_merror
((new_env0))) { gc(); (new_env0) = (lbm_env_set(cmp_env, par1
, lbm_car(a))); if (lbm_is_symbol_merror((new_env0))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2795 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b)), new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { lbm_gc_mark_phase(new_env0); gc(); (new_env) =
(lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { error_ctx((((0x23) << 4) | 0x00000000u))
; } };
2796 cmp_env = new_env;
2797 } else {
2798 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2799 }
2800 lbm_value cmp = cl[CLO_BODY1];
2801
2802 // Terminate the comparator argument list.
2803 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2804
2805 lbm_stack_drop(&ctx->K, 3); //TODO: optimize drop 3, alloc 20 into alloc 17
2806 lbm_uint *sptr = stack_reserve(ctx, 20);
2807 sptr[0] = cmp;
2808 sptr[1] = cmp_env;
2809 sptr[2] = par1;
2810 sptr[3] = par2;
2811 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged accumulation of sublists
2812 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged accumulation of sublists
2813 sptr[6] = rest;
2814 sptr[7] = lbm_enc_i(1);
2815 sptr[8] = lbm_enc_i(len); //TODO: 28 bit i vs 32 bit i
2816 sptr[9] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
2817 sptr[10] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged sublist
2818 sptr[11] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged sublist
2819 sptr[12] = a;
2820 sptr[13] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no a_rest, 1 element lists in layer 1.
2821 sptr[14] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no b_rest, 1 element lists in layer 1.
2822 sptr[15] = cmp;
2823 sptr[16] = cmp_env;
2824 sptr[17] = par1;
2825 sptr[18] = par2;
2826 sptr[19] = MERGE_REST(((43) << 2) | 0xF8000001u);
2827 ctx->curr_exp = cmp;
2828 ctx->curr_env = cmp_env;
2829 return;
2830 }
2831 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
2832}
2833
2834static void apply_rest_args(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2835 lbm_value res;
2836 if (lbm_env_lookup_b(&res, ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ctx->curr_env)) {
2837 if (nargs == 1 && lbm_is_number(args[0])) {
2838 int32_t ix = lbm_dec_as_i32(args[0]);
2839 res = lbm_index_list(res, ix);
2840 }
2841 ctx->r = res;
2842 } else {
2843 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2844 }
2845 lbm_stack_drop(&ctx->K, nargs+1);
2846 ctx->app_cont = true1;
2847}
2848
2849/* (rotate list-expr dist/dir-expr) */
2850static void apply_rotate(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2851 if (nargs == 2 && lbm_is_list(args[0]) && lbm_is_number(args[1])) {
2852 int len = -1;
2853 lbm_value ls = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2854 WITH_GC(ls, lbm_list_copy(&len, args[0]))(ls) = (lbm_list_copy(&len, args[0])); if (lbm_is_symbol_merror
((ls))) { gc(); (ls) = (lbm_list_copy(&len, args[0])); if
(lbm_is_symbol_merror((ls))) { error_ctx((((0x23) << 4
) | 0x00000000u)); } };
2855 int dist = lbm_dec_as_i32(args[1]);
2856 if (len > 0 && dist != 0) {
2857 int d = dist;
2858 if (dist > 0) {
2859 ls = lbm_list_destructive_reverse(ls);
2860 } else {
2861 d = -dist;
2862 }
2863
2864 lbm_value start = ls;
2865 lbm_value end = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2866 lbm_value curr = start;
2867 while (lbm_is_cons(curr)) {
2868 end = curr;
2869 curr = get_cdr(curr);
2870 }
2871
2872 for (int i = 0; i < d; i ++) {
2873 lbm_value a = start;
2874 start = lbm_cdr(start);
2875 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2876 lbm_set_cdr(end, a);
2877 end = a;
2878 }
2879 ls = start;
2880 if (dist > 0) {
2881 ls = lbm_list_destructive_reverse(ls);
2882 }
2883 }
2884 lbm_stack_drop(&ctx->K, nargs+1);
2885 ctx->app_cont = true1;
2886 ctx->r = ls;
2887 return;
2888 }
2889 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2890}
2891
2892/***************************************************/
2893/* Application lookup table */
2894
2895typedef void (*apply_fun)(lbm_value *, lbm_uint, eval_context_t *);
2896static const apply_fun fun_table[] =
2897 {
2898 apply_setvar,
2899 apply_read,
2900 apply_read_program,
2901 apply_read_eval_program,
2902 apply_spawn,
2903 apply_spawn_trap,
2904 apply_yield,
2905 apply_wait,
2906 apply_eval,
2907 apply_eval_program,
2908 apply_send,
2909 apply_ok,
2910 apply_error,
2911 apply_map,
2912 apply_reverse,
2913 apply_flatten,
2914 apply_unflatten,
2915 apply_kill,
2916 apply_sleep,
2917 apply_merge,
2918 apply_sort,
2919 apply_rest_args,
2920 apply_rotate,
2921 };
2922
2923/***************************************************/
2924/* Application of function that takes arguments */
2925/* passed over the stack. */
2926
2927static void application(eval_context_t *ctx, lbm_value *fun_args, lbm_uint arg_count) {
2928 /* If arriving here, we know that the fun is a symbol.
2929 * and can be a built in operation or an extension.
2930 */
2931 lbm_value fun = fun_args[0];
2932
2933 lbm_uint fun_val = lbm_dec_sym(fun);
2934 lbm_uint fun_kind = SYMBOL_KIND(fun_val)((fun_val) >> 16);
2935
2936 switch (fun_kind) {
2937 case SYMBOL_KIND_EXTENSION1: {
2938 extension_fptr f = extension_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)].fptr;
2939
2940 lbm_value ext_res;
2941 WITH_GC(ext_res, f(&fun_args[1], arg_count))(ext_res) = (f(&fun_args[1], arg_count)); if (lbm_is_symbol_merror
((ext_res))) { gc(); (ext_res) = (f(&fun_args[1], arg_count
)); if (lbm_is_symbol_merror((ext_res))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2942 if (lbm_is_error(ext_res)) { //Error other than merror
2943 error_at_ctx(ext_res, fun);
2944 }
2945 lbm_stack_drop(&ctx->K, arg_count + 1);
2946
2947 ctx->app_cont = true1;
2948 ctx->r = ext_res;
2949
2950 if (blocking_extension) {
2951 blocking_extension = false0;
2952 if (blocking_extension_timeout) {
2953 blocking_extension_timeout = false0;
2954 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, blocking_extension_timeout_us,true1);
2955 } else {
2956 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,true1);
2957 }
2958 mutex_unlock(&blocking_extension_mutex);
2959 }
2960 } break;
2961 case SYMBOL_KIND_FUNDAMENTAL2:
2962 call_fundamental(SYMBOL_IX(fun_val)((fun_val) & 0xFFFF), &fun_args[1], arg_count, ctx);
2963 break;
2964 case SYMBOL_KIND_APPFUN3:
2965 fun_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)](&fun_args[1], arg_count, ctx);
2966 break;
2967 default:
2968 // Symbols that are "special" but not in the way caught above
2969 // ends up here.
2970 lbm_set_error_reason("Symbol does not represent a function");
2971 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),fun_args[0]);
2972 break;
2973 }
2974}
2975
2976static void cont_closure_application_args(eval_context_t *ctx) {
2977 lbm_uint* sptr = get_stack_ptr(ctx, 5);
2978
2979 lbm_value arg_env = (lbm_value)sptr[0];
2980 lbm_value exp = (lbm_value)sptr[1];
2981 lbm_value clo_env = (lbm_value)sptr[2];
2982 lbm_value params = (lbm_value)sptr[3];
2983 lbm_value args = (lbm_value)sptr[4];
2984
2985 lbm_value car_params, cdr_params;
2986 get_car_and_cdr(params, &car_params, &cdr_params);
2987
2988 bool_Bool a_nil = lbm_is_symbol_nil(args);
2989 bool_Bool p_nil = lbm_is_symbol_nil(cdr_params);
2990
2991 lbm_value binder = allocate_binding(car_params, ctx->r, clo_env);
2992
2993 if (!a_nil && !p_nil) {
2994 lbm_value car_args, cdr_args;
2995 get_car_and_cdr(args, &car_args, &cdr_args);
2996 sptr[2] = binder;
2997 sptr[3] = cdr_params;
2998 sptr[4] = cdr_args;
2999 stack_reserve(ctx,1)[0] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
3000 ctx->curr_exp = car_args;
3001 ctx->curr_env = arg_env;
3002 } else if (a_nil && p_nil) {
3003 // Arguments and parameters match up in number
3004 lbm_stack_drop(&ctx->K, 5);
3005 ctx->curr_env = binder;
3006 ctx->curr_exp = exp;
3007 } else if (p_nil) {
3008 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), binder);
3009 sptr[2] = rest_binder;
3010 sptr[3] = get_cdr(args);
3011 sptr[4] = get_car(rest_binder); // last element of rest_args so far
3012 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3013 ctx->curr_exp = get_car(args);
3014 ctx->curr_env = arg_env;
3015 } else {
3016 lbm_set_error_reason((char*)lbm_error_str_num_args);
3017 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
3018 }
3019}
3020
3021
3022static void cont_closure_args_rest(eval_context_t *ctx) {
3023 lbm_uint* sptr = get_stack_ptr(ctx, 5);
3024 lbm_value arg_env = (lbm_value)sptr[0];
3025 lbm_value exp = (lbm_value)sptr[1];
3026 lbm_value clo_env = (lbm_value)sptr[2];
3027 lbm_value args = (lbm_value)sptr[3];
3028 lbm_value last = (lbm_value)sptr[4];
3029 lbm_cons_t* heap = lbm_heap_state.heap;
3030
3031 lbm_value binding = lbm_heap_state.freelist;
3032 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3033 gc();
3034 binding = lbm_heap_state.freelist;
3035 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3036 }
3037 lbm_uint binding_ix = lbm_dec_ptr(binding);
3038 lbm_heap_state.freelist = heap[binding_ix].cdr;
3039 lbm_heap_state.num_alloc += 1;
3040 heap[binding_ix].car = ctx->r;
3041 heap[binding_ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3042
3043
3044 lbm_set_cdr(last, binding);
3045 sptr[4] = binding;
3046
3047 if (args == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3048 lbm_stack_drop(&ctx->K, 5);
3049 ctx->curr_env = clo_env;
3050 ctx->curr_exp = exp;
3051 } else {
3052 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3053 sptr[3] = get_cdr(args);
3054 ctx->curr_exp = get_car(args);
3055 ctx->curr_env = arg_env;
3056 }
3057}
3058
3059static void cont_application_args(eval_context_t *ctx) {
3060 lbm_uint *sptr = get_stack_ptr(ctx, 3);
3061
3062 lbm_value env = sptr[0];
3063 lbm_value rest = sptr[1];
3064 lbm_value count = sptr[2];
3065
3066 ctx->curr_env = env;
3067 sptr[0] = ctx->r; // Function 1st then Arguments
3068 if (lbm_is_cons(rest)) {
3069 lbm_cons_t *cell = lbm_ref_cell(rest);
3070 sptr[1] = env;
3071 sptr[2] = cell->cdr;
3072 lbm_value *rptr = stack_reserve(ctx,2);
3073 rptr[0] = count + (1 << LBM_VAL_SHIFT4);
3074 rptr[1] = APPLICATION_ARGS(((5) << 2) | 0xF8000001u);
3075 ctx->curr_exp = cell->car;
3076 } else {
3077 // No more arguments
3078 lbm_stack_drop(&ctx->K, 2);
3079 lbm_uint nargs = lbm_dec_u(count);
3080 lbm_value *args = get_stack_ptr(ctx, (uint32_t)(nargs + 1));
3081 application(ctx,args, nargs);
3082 }
3083}
3084
3085static void cont_and(eval_context_t *ctx) {
3086 lbm_value env;
3087 lbm_value rest;
3088 lbm_value arg = ctx->r;
3089 lbm_pop_2(&ctx->K, &rest, &env);
3090 if (lbm_is_symbol_nil(arg)) {
3091 ctx->app_cont = true1;
3092 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3093 } else if (lbm_is_symbol_nil(rest)) {
3094 ctx->app_cont = true1;
3095 } else {
3096 lbm_value *sptr = stack_reserve(ctx, 3);
3097 sptr[0] = env;
3098 sptr[1] = get_cdr(rest);
3099 sptr[2] = AND(((6) << 2) | 0xF8000001u);
3100 ctx->curr_env = env;
3101 ctx->curr_exp = get_car(rest);
3102 }
3103}
3104
3105static void cont_or(eval_context_t *ctx) {
3106 lbm_value env;
3107 lbm_value rest;
3108 lbm_value arg = ctx->r;
3109 lbm_pop_2(&ctx->K, &rest, &env);
3110 if (!lbm_is_symbol_nil(arg)) {
3111 ctx->app_cont = true1;
3112 } else if (lbm_is_symbol_nil(rest)) {
3113 ctx->app_cont = true1;
3114 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3115 } else {
3116 lbm_value *sptr = stack_reserve(ctx, 3);
3117 sptr[0] = env;
3118 sptr[1] = get_cdr(rest);
3119 sptr[2] = OR(((7) << 2) | 0xF8000001u);
3120 ctx->curr_exp = get_car(rest);
3121 ctx->curr_env = env;
3122 }
3123}
3124
3125static int fill_binding_location(lbm_value key, lbm_value value, lbm_value env) {
3126 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) {
3127 if (key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return FB_OK0;
3128 lbm_env_modify_binding(env,key,value);
3129 return FB_OK0;
3130 } else if (lbm_is_cons(key) &&
3131 lbm_is_cons(value)) {
3132 int r = fill_binding_location(get_car(key), get_car(value), env);
3133 if (r == FB_OK0) {
3134 r = fill_binding_location(get_cdr(key), get_cdr(value), env);
3135 }
3136 return r;
3137 }
3138 return FB_TYPE_ERROR-1;
3139}
3140
3141static void cont_bind_to_key_rest(eval_context_t *ctx) {
3142
3143 lbm_value *sptr = get_stack_ptr(ctx, 4);
3144
3145 lbm_value rest = sptr[1];
3146 lbm_value env = sptr[2];
3147 lbm_value key = sptr[3];
3148
3149 if (fill_binding_location(key, ctx->r, env) < 0) {
3150 lbm_set_error_reason("Incorrect type of name/key in let-binding");
3151 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
3152 }
3153
3154 if (lbm_is_cons(rest)) {
3155 lbm_value car_rest = get_car(rest);
3156 lbm_value key_val[2];
3157 extract_n(car_rest, key_val, 2);
3158
3159 sptr[1] = get_cdr(rest);
3160 sptr[3] = key_val[0];
3161 stack_reserve(ctx,1)[0] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
3162 ctx->curr_exp = key_val[1];
3163 ctx->curr_env = env;
3164 } else {
3165 // Otherwise evaluate the expression in the populated env
3166 ctx->curr_exp = sptr[0];
3167 ctx->curr_env = env;
3168 lbm_stack_drop(&ctx->K, 4);
3169 }
3170}
3171
3172static void cont_if(eval_context_t *ctx) {
3173
3174 lbm_value arg = ctx->r;
3175
3176 lbm_value *sptr = pop_stack_ptr(ctx, 2);
3177
3178 ctx->curr_env = sptr[1];
3179 if (lbm_is_symbol_nil(arg)) {
3180 ctx->curr_exp = get_cadr(sptr[0]); // else branch
3181 } else {
3182 ctx->curr_exp = get_car(sptr[0]); // then branch
3183 }
3184}
3185
3186static void cont_match(eval_context_t *ctx) {
3187 lbm_value e = ctx->r;
3188 bool_Bool do_gc = false0;
3189
3190 lbm_uint *sptr = get_stack_ptr(ctx, 2);
3191 lbm_value patterns = (lbm_value)sptr[0];
3192 lbm_value orig_env = (lbm_value)sptr[1]; // restore enclosing environment.
3193 lbm_value new_env = orig_env;
3194
3195 if (lbm_is_symbol_nil(patterns)) {
3196 // no more patterns
3197 lbm_stack_drop(&ctx->K, 2);
3198 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
3199 ctx->app_cont = true1;
3200 } else if (lbm_is_cons(patterns)) {
3201 lbm_value match_case = get_car(patterns);
3202 lbm_value pattern = get_car(match_case);
3203 lbm_value n1 = get_cadr(match_case);
3204 lbm_value n2 = get_cadr(get_cdr(match_case));
3205 lbm_value body;
3206 bool_Bool check_guard = false0;
3207 if (lbm_is_symbol_nil(n2)) { // TODO: Not a very robust check.
3208 body = n1;
3209 } else {
3210 body = n2;
3211 check_guard = true1;
3212 }
3213
3214 bool_Bool is_match = match(pattern, e, &new_env, &do_gc);
3215 if (do_gc) {
3216 gc();
3217 do_gc = false0;
3218 new_env = orig_env;
3219 is_match = match(pattern, e, &new_env, &do_gc);
3220 if (do_gc) {
3221 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3222 }
3223 }
3224 if (is_match) {
3225 if (check_guard) {
3226 lbm_value *rptr = stack_reserve(ctx,5);
3227 sptr[0] = get_cdr(patterns);
3228 sptr[1] = ctx->curr_env;
3229 rptr[0] = MATCH(((9) << 2) | 0xF8000001u);
3230 rptr[1] = new_env;
3231 rptr[2] = body;
3232 rptr[3] = e;
3233 rptr[4] = MATCH_GUARD(((27) << 2) | 0xF8000001u);
3234 ctx->curr_env = new_env;
3235 ctx->curr_exp = n1; // The guard
3236 } else {
3237 lbm_stack_drop(&ctx->K, 2);
3238 ctx->curr_env = new_env;
3239 ctx->curr_exp = body;
3240 }
3241 } else {
3242 // set up for checking of next pattern
3243 sptr[0] = get_cdr(patterns);
3244 sptr[1] = orig_env;
3245 stack_reserve(ctx,1)[0] = MATCH(((9) << 2) | 0xF8000001u);
3246 // leave r unaltered
3247 ctx->app_cont = true1;
3248 }
3249 } else {
3250 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MATCH(((0x108) << 4) | 0x00000000u));
3251 }
3252}
3253
3254static void cont_exit_atomic(eval_context_t *ctx) {
3255 is_atomic --;
3256 ctx->app_cont = true1;
3257}
3258
3259static void cont_map(eval_context_t *ctx) {
3260 lbm_value *sptr = get_stack_ptr(ctx, 6);
3261
3262 lbm_value ls = sptr[0];
3263 lbm_value env = sptr[1];
3264 lbm_value t = sptr[3];
3265 lbm_set_car(t, ctx->r); // update car field tailmost position.
3266 if (lbm_is_cons(ls)) {
3267 lbm_value next, rest;
3268 get_car_and_cdr(ls, &next, &rest);
3269 sptr[0] = rest;
3270 stack_reserve(ctx,1)[0] = MAP(((26) << 2) | 0xF8000001u);
3271 lbm_set_car(sptr[5], next); // new arguments
3272
3273 lbm_value elt = cons_with_gc(ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3274 lbm_set_cdr(t, elt);
3275 sptr[3] = elt; // (r1 ... rN . (nil . nil))
3276 ctx->curr_exp = sptr[4];
3277 ctx->curr_env = env;
3278 } else {
3279 ctx->r = sptr[2]; //head of result list
3280 ctx->curr_env = env;
3281 lbm_stack_drop(&ctx->K, 6);
3282 ctx->app_cont = true1;
3283 }
3284}
3285
3286static void cont_match_guard(eval_context_t *ctx) {
3287 if (lbm_is_symbol_nil(ctx->r)) {
3288 lbm_value e;
3289 lbm_pop(&ctx->K, &e);
3290 lbm_stack_drop(&ctx->K, 2);
3291 ctx->r = e;
3292 ctx->app_cont = true1;
3293 } else {
3294 lbm_value body;
3295 lbm_value env;
3296 lbm_stack_drop(&ctx->K, 1);
3297 lbm_pop_2(&ctx->K, &body, &env);
3298 lbm_stack_drop(&ctx->K, 3);
3299 ctx->curr_env = env;
3300 ctx->curr_exp = body;
3301 }
3302}
3303
3304static void cont_terminate(eval_context_t *ctx) {
3305 error_ctx(ctx->r);
3306}
3307
3308static void cont_loop(eval_context_t *ctx) {
3309 lbm_value *sptr = get_stack_ptr(ctx, 2);
3310 stack_reserve(ctx,1)[0] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
3311 ctx->curr_exp = sptr[1];
3312}
3313
3314static void cont_loop_condition(eval_context_t *ctx) {
3315 if (lbm_is_symbol_nil(ctx->r)) {
3316 lbm_stack_drop(&ctx->K, 2);
3317 ctx->app_cont = true1; // A loop returns nil? Makes sense to me... but in general?
3318 return;
3319 }
3320 lbm_value *sptr = get_stack_ptr(ctx, 2);
3321 stack_reserve(ctx,1)[0] = LOOP(((41) << 2) | 0xF8000001u);
3322 ctx->curr_exp = sptr[0];
3323}
3324
3325static void cont_merge_rest(eval_context_t *ctx) {
3326 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3327
3328 // If comparator returns true (result is in ctx->r):
3329 // "a" should be moved to the last element position in merged list.
3330 // A new element from "a_rest" should be moved into comparator argument 1 pos.
3331 // else
3332 // "b" should be moved to last element position in merged list.
3333 // A new element from "b_rest" should be moved into comparator argument 2 pos.
3334 //
3335 // If a_rest or b_rest is NIL:
3336 // we are done, the remaining elements of
3337 // non_nil list should be appended to merged list.
3338 // else
3339 // Set up for a new comparator evaluation and recurse.
3340 lbm_value a = sptr[2];
3341 lbm_value b = lbm_cdr(a);
3342 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate 1 element list
3343
3344 if (ctx->r == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) { // Comparison false
3345
3346 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3347 sptr[0] = b;
3348 sptr[1] = b;
3349 } else {
3350 lbm_set_cdr(sptr[1], b);
3351 sptr[1] = b;
3352 }
3353 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3354 lbm_set_cdr(a, sptr[3]);
3355 lbm_set_cdr(sptr[1], a);
3356 ctx->r = sptr[0];
3357 lbm_stack_drop(&ctx->K, 9);
3358 ctx->app_cont = true1;
3359 return;
3360 } else {
3361 b = sptr[4];
3362 sptr[4] = lbm_cdr(sptr[4]);
3363 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3364 }
3365 } else {
3366 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3367 sptr[0] = a;
3368 sptr[1] = a;
3369 } else {
3370 lbm_set_cdr(sptr[1], a);
3371 sptr[1] = a;
3372 }
3373
3374 if (sptr[3] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3375 lbm_set_cdr(b, sptr[4]);
3376 lbm_set_cdr(sptr[1], b);
3377 ctx->r = sptr[0];
3378 lbm_stack_drop(&ctx->K, 9);
3379 ctx->app_cont = true1;
3380 return;
3381 } else {
3382 a = sptr[3];
3383 sptr[3] = lbm_cdr(sptr[3]);
3384 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3385 }
3386 }
3387 lbm_set_cdr(a, b);
3388 sptr[2] = a;
3389
3390 lbm_value par1 = sptr[7];
3391 lbm_value par2 = sptr[8];
3392 lbm_value cmp_body = sptr[5];
3393 lbm_value cmp_env = sptr[6];
3394 // Environment should be preallocated already at this point
3395 // and the operations below should never need GC.
3396 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3397 lbm_value new_env = lbm_env_set(new_env0, par2, lbm_car(b));
3398 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3399 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3400 }
3401 cmp_env = new_env;
3402
3403 stack_reserve(ctx,1)[0] = MERGE_REST(((43) << 2) | 0xF8000001u);
3404 ctx->curr_exp = cmp_body;
3405 ctx->curr_env = cmp_env;
3406}
3407
3408// merge_layer stack contents
3409// s[sp-9] = cmp
3410// s[sp-8] = cmp_env
3411// s[sp-7] = par1
3412// s[sp-6] = par2
3413// s[sp-5] = acc - first cell
3414// s[sp-4] = acc - last cell
3415// s[sp-3] = rest;
3416// s[sp-2] = layer
3417// s[sp-1] = length or original list
3418//
3419// ctx->r merged sublist
3420static void cont_merge_layer(eval_context_t *ctx) {
3421 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3422 lbm_int layer = lbm_dec_i(sptr[7]);
3423 lbm_int len = lbm_dec_i(sptr[8]);
3424
3425 lbm_value r_curr = ctx->r;
3426 while (lbm_is_cons(r_curr)) {
3427 lbm_value next = lbm_cdr(r_curr);
3428 if (next == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3429 break;
3430 }
3431 r_curr = next;
3432 }
3433
3434 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3435 sptr[4] = ctx->r;
3436 sptr[5] = r_curr;
3437 } else {
3438 lbm_set_cdr(sptr[5], ctx->r); // accumulate merged sublists.
3439 sptr[5] = r_curr;
3440 }
3441
3442 lbm_value layer_rest = sptr[6];
3443 // switch layer or done ?
3444 if (layer_rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3445 if (layer * 2 >= len) {
3446 ctx->r = sptr[4];
3447 ctx->app_cont = true1;
3448 lbm_stack_drop(&ctx->K, 9);
3449 return;
3450 } else {
3451 // Setup for merges of the next layer
3452 layer = layer * 2;
3453 sptr[7] = lbm_enc_i(layer);
3454 layer_rest = sptr[4]; // continue on the accumulation of all sublists.
3455 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3456 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3457 }
3458 }
3459 // merge another sublist based on current layer.
3460 lbm_value a_list = layer_rest;
3461 // build sublist a
3462 lbm_value curr = layer_rest;
3463 for (int i = 0; i < layer-1; i ++) {
3464 if (lbm_is_cons(curr)) {
3465 curr = lbm_cdr(curr);
3466 } else {
3467 break;
3468 }
3469 }
3470 layer_rest = lbm_cdr(curr);
3471 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3472
3473 lbm_value b_list = layer_rest;
3474 // build sublist b
3475 curr = layer_rest;
3476 for (int i = 0; i < layer-1; i ++) {
3477 if (lbm_is_cons(curr)) {
3478 curr = lbm_cdr(curr);
3479 } else {
3480 break;
3481 }
3482 }
3483 layer_rest = lbm_cdr(curr);
3484 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3485
3486 sptr[6] = layer_rest;
3487
3488 if (b_list == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3489 stack_reserve(ctx,1)[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3490 ctx->r = a_list;
3491 ctx->app_cont = true1;
3492 return;
3493 }
3494 // Set up for a merge of sublists.
3495
3496 lbm_value a_rest = lbm_cdr(a_list);
3497 lbm_value b_rest = lbm_cdr(b_list);
3498 lbm_value a = a_list;
3499 lbm_value b = b_list;
3500 lbm_set_cdr(a, b);
3501 // Terminating the b list would be incorrect here
3502 // if there was any chance that the environment update below
3503 // performs GC.
3504 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3505
3506 lbm_value cmp_body = sptr[0];
3507 lbm_value cmp_env = sptr[1];
3508 lbm_value par1 = sptr[2];
3509 lbm_value par2 = sptr[3];
3510 // Environment should be preallocated already at this point
3511 // and the operations below should never need GC.
3512 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3513 lbm_value new_env = lbm_env_set(cmp_env, par2, lbm_car(b));
3514 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3515 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3516 }
3517 cmp_env = new_env;
3518
3519 lbm_uint *merge_cont = stack_reserve(ctx, 11);
3520 merge_cont[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3521 merge_cont[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3522 merge_cont[2] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3523 merge_cont[3] = a;
3524 merge_cont[4] = a_rest;
3525 merge_cont[5] = b_rest;
3526 merge_cont[6] = cmp_body;
3527 merge_cont[7] = cmp_env;
3528 merge_cont[8] = par1;
3529 merge_cont[9] = par2;
3530 merge_cont[10] = MERGE_REST(((43) << 2) | 0xF8000001u);
3531 ctx->curr_exp = cmp_body;
3532 ctx->curr_env = cmp_env;
3533 return;
3534}
3535
3536/****************************************************/
3537/* READER */
3538
3539static void read_finish(lbm_char_channel_t *str, eval_context_t *ctx) {
3540
3541 /* Tokenizer reached "end of file"
3542 The parser could be in a state where it needs
3543 more tokens to correctly finish an expression.
3544
3545 Three cases
3546 1. The program / expression is malformed and the context should die.
3547 2. We are finished reading a program and should close off the
3548 internal representation with a closing parenthesis. Then
3549 apply continuation.
3550 3. We are finished reading an expression and should
3551 apply the continuation.
3552
3553 In case 3, we should find the READ_DONE at sp - 1.
3554 In case 2, we should find the READ_DONE at sp - 5.
3555
3556 */
3557
3558 if (lbm_is_symbol(ctx->r)) {
3559 lbm_uint sym_val = lbm_dec_sym(ctx->r);
3560 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
3561 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
3562 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3563 }
3564 }
3565
3566 if (ctx->K.data[ctx->K.sp-1] == READ_DONE(((20) << 2) | 0xF8000001u) &&
3567 lbm_dec_u(ctx->K.data[ctx->K.sp-3]) == 0) {
3568 /* successfully finished reading an expression (CASE 3) */
3569 ctx->app_cont = true1;
3570 } else if (ctx->K.sp > 4 && ctx->K.data[ctx->K.sp - 4] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3571 lbm_value env;
3572 lbm_value s;
3573 lbm_value sym;
3574 lbm_pop_3(&ctx->K, &sym, &env, &s);
3575 ctx->curr_env = env;
3576 ctx->app_cont = true1; // Program evaluated and result is in ctx->r.
3577 } else if (ctx->K.sp > 5 && ctx->K.data[ctx->K.sp - 5] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3578 /* successfully finished reading a program (CASE 2) */
3579 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3580 ctx->app_cont = true1;
3581 } else {
3582 /* Parsing failed */
3583 if (lbm_channel_row(str) == 1 &&
3584 lbm_channel_column(str) == 1 ){
3585 // eof at empty stream.
3586 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3587 ctx->app_cont = true1;
3588 } else {
3589 lbm_set_error_reason((char*)lbm_error_str_parse_eof);
3590 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3591 }
3592 lbm_channel_reader_close(str);
3593 }
3594}
3595
3596/* cont_read_next_token
3597 sp-2 : Stream
3598 sp-1 : Grab row
3599*/
3600static void cont_read_next_token(eval_context_t *ctx) {
3601 lbm_value *sptr = get_stack_ptr(ctx, 2);
3602 lbm_value stream = sptr[0];
3603 lbm_value grab_row0 = sptr[1];
3604
3605 lbm_char_channel_t *chan = lbm_dec_channel(stream);
3606 if (chan == NULL((void*)0) || chan->state == NULL((void*)0)) {
1
Assuming 'chan' is not equal to NULL
→
2
←
Assuming field 'state' is not equal to NULL
→
3
←
Taking false branch
→
3607 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3608 }
3609
3610 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
4
←
Assuming the condition is false
→
3611 lbm_stack_drop(&ctx->K, 2);
3612 read_finish(chan, ctx);
3613 return;
3614 }
3615 /* Eat whitespace and comments */
3616 if (!tok_clean_whitespace(chan)) {
5
←
Assuming the condition is false
→
6
←
Taking false branch
→
3617 sptr[0] = stream;
3618 sptr[1] = lbm_enc_u(0);
3619 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3620 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3621 return;
3622 }
3623 /* After eating whitespace we may be at end of file/stream */
3624 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
7
←
Assuming the condition is false
→
3625 lbm_stack_drop(&ctx->K, 2);
3626 read_finish(chan, ctx);
3627 return;
3628 }
3629
3630 if (lbm_dec_u(grab_row0)) {
8
←
Assuming the condition is false
→
9
←
Taking false branch
→
3631 ctx->row0 = (int32_t)lbm_channel_row(chan);
3632 }
3633
3634 /* Attempt to extract tokens from the character stream */
3635 int n = 0;
3636 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3637 unsigned int string_len = 0;
3638
3639 /*
3640 * SYNTAX
3641 */
3642 uint32_t match;
3643 n = tok_syntax(chan, &match);
3644 if (n > 0) {
10
←
Assuming 'n' is <= 0
→
11
←
Taking false branch
→
3645 if (!lbm_channel_drop(chan, (unsigned int)n)) {
3646 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3647 }
3648 ctx->app_cont = true1;
3649 lbm_uint do_next = 0;
3650 switch(match) {
3651 case TOKOPENPAR1u: {
3652 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3653 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3654 lbm_value *rptr = stack_reserve(ctx,5);
3655 rptr[0] = stream;
3656 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3657 rptr[2] = stream;
3658 rptr[3] = lbm_enc_u(0);
3659 rptr[4] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3660 ctx->r = ENC_SYM_OPENPAR(((0x70) << 4) | 0x00000000u);
3661 } return;
3662 case TOKCLOSEPAR2u: {
3663 lbm_stack_drop(&ctx->K, 2);
3664 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3665 } return;
3666 case TOKOPENBRACK3u: {
3667 sptr[0] = stream;
3668 sptr[1] = READ_START_ARRAY(((24) << 2) | 0xF8000001u);
3669 lbm_value *rptr = stack_reserve(ctx, 3);
3670 rptr[0] = stream;
3671 rptr[1] = lbm_enc_u(0);
3672 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3673 ctx->r = ENC_SYM_OPENBRACK(((0x80) << 4) | 0x00000000u);
3674 } return;
3675 case TOKCLOSEBRACK4u:
3676 lbm_stack_drop(&ctx->K, 2);
3677 ctx->r = ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u);
3678 return;
3679 case TOKDOT5u:
3680 lbm_stack_drop(&ctx->K, 2);
3681 ctx->r = ENC_SYM_DOT(((0x76) << 4) | 0x00000000u);
3682 return;
3683 case TOKDONTCARE6u:
3684 lbm_stack_drop(&ctx->K, 2);
3685 ctx->r = ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u);
3686 return;
3687 case TOKQUOTE7u:
3688 do_next = READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u);
3689 break;
3690 case TOKBACKQUOTE8u: {
3691 sptr[0] = QQ_EXPAND_START(((35) << 2) | 0xF8000001u);
3692 sptr[1] = stream;
3693 lbm_value *rptr = stack_reserve(ctx, 2);
3694 rptr[0] = lbm_enc_u(0);
3695 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3696 ctx->app_cont = true1;
3697 } return;
3698 case TOKCOMMAAT9u:
3699 do_next = READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u);
3700 break;
3701 case TOKCOMMA10u:
3702 do_next = READ_COMMA_RESULT(((23) << 2) | 0xF8000001u);
3703 break;
3704 case TOKMATCHANY11u:
3705 lbm_stack_drop(&ctx->K, 2);
3706 ctx->r = ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u);
3707 return;
3708 case TOKOPENCURL12u: {
3709 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3710 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3711 lbm_value *rptr = stack_reserve(ctx,2);
3712 rptr[0] = stream;
3713 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3714 ctx->r = ENC_SYM_PROGN(((0x102) << 4) | 0x00000000u);
3715 } return;
3716 case TOKCLOSECURL13u:
3717 lbm_stack_drop(&ctx->K, 2);
3718 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3719 return;
3720 case TOKCONSTSTART14u: /* fall through */
3721 case TOKCONSTEND15u:
3722 case TOKCONSTSYMSTR16u: {
3723 if (match == TOKCONSTSTART14u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3724 if (match == TOKCONSTEND15u) ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3725 if (match == TOKCONSTSYMSTR16u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04;
3726 sptr[0] = stream;
3727 sptr[1] = lbm_enc_u(0);
3728 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3729 ctx->app_cont = true1;
3730 } return;
3731 default:
3732 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3733 }
3734 sptr[0] = do_next;
3735 sptr[1] = stream;
3736 lbm_value *rptr = stack_reserve(ctx, 2);
3737 rptr[0] = lbm_enc_u(0);
3738 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3739 ctx->app_cont = true1;
3740 return;
3741 } else if (n < 0) goto retry_token;
12
←
Assuming 'n' is >= 0
→
13
←
Taking false branch
→
3742
3743 /*
3744 * STRING
3745 */
3746 n = tok_string(chan, &string_len);
3747 if (n >= 2) {
14
←
Assuming 'n' is >= 2
→
15
←
Taking true branch
→
3748 lbm_channel_drop(chan, (unsigned int)n);
3749 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
16
←
Value assigned to 'res'
→
17
←
Assuming the condition is false
→
18
←
Taking false branch
→
3750 gc();
3751 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3752 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3753 return; // dead return but static analysis does not know that.
3754 }
3755 }
3756 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(res);
19
←
Passing value via 1st parameter 'a'
→
20
←
Calling 'get_car'
→
29
←
Returning from 'get_car'
→
30
←
'arr' initialized to a null pointer value
→
3757 char *data = (char*)arr->data;
31
←
Access to field 'data' results in a dereference of a null pointer (loaded from variable 'arr')
3758 memset(data,0, string_len + 1);
3759 memcpy(data, tokpar_sym_str, string_len);
3760 lbm_stack_drop(&ctx->K, 2);
3761 ctx->r = res;
3762 ctx->app_cont = true1;
3763 return;
3764 } else if (n < 0) goto retry_token;
3765
3766 /*
3767 * FLOAT
3768 */
3769 token_float f_val;
3770 n = tok_double(chan, &f_val);
3771 if (n > 0) {
3772 lbm_channel_drop(chan, (unsigned int) n);
3773 switch(f_val.type) {
3774 case TOKTYPEF32107u:
3775 WITH_GC(res, lbm_enc_float((float)f_val.value))(res) = (lbm_enc_float((float)f_val.value)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (lbm_enc_float((float)f_val.value));
if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
3776 break;
3777 case TOKTYPEF64108u:
3778 res = lbm_enc_double(f_val.value);
3779 break;
3780 default:
3781 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3782 }
3783 lbm_stack_drop(&ctx->K, 2);
3784 ctx->r = res;
3785 ctx->app_cont = true1;
3786 return;
3787 } else if (n < 0) goto retry_token;
3788
3789 /*
3790 * INTEGER
3791 */
3792 token_int int_result;
3793 n = tok_integer(chan, &int_result);
3794 if (n > 0) {
3795 lbm_channel_drop(chan, (unsigned int)n);
3796 switch(int_result.type) {
3797 case TOKTYPEBYTE100u:
3798 res = lbm_enc_char((uint8_t)(int_result.negative ? -int_result.value : int_result.value));
3799 break;
3800 case TOKTYPEI101u:
3801 res = lbm_enc_i((lbm_int)(int_result.negative ? -int_result.value : int_result.value));
3802 break;
3803 case TOKTYPEU102u:
3804 res = lbm_enc_u((lbm_uint)(int_result.negative ? -int_result.value : int_result.value));
3805 break;
3806 case TOKTYPEI32103u:
3807 WITH_GC(res, lbm_enc_i32((int32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i32((int32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i32((int32_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3808 break;
3809 case TOKTYPEU32104u:
3810 WITH_GC(res,lbm_enc_u32((uint32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u32((uint32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u32((uint32_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3811 break;
3812 case TOKTYPEI64105u:
3813 WITH_GC(res,lbm_enc_i64((int64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i64((int64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i64((int64_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3814 break;
3815 case TOKTYPEU64106u:
3816 WITH_GC(res,lbm_enc_u64((uint64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u64((uint64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u64((uint64_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3817 break;
3818 default:
3819 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3820 }
3821 lbm_stack_drop(&ctx->K, 2);
3822 ctx->r = res;
3823 ctx->app_cont = true1;
3824 return;
3825 } else if (n < 0) goto retry_token;
3826
3827 /*
3828 * SYMBOL
3829 */
3830 n = tok_symbol(chan);
3831 if (n > 0) {
3832 lbm_channel_drop(chan, (unsigned int) n);
3833 lbm_uint symbol_id;
3834 if (lbm_get_symbol_by_name(tokpar_sym_str, &symbol_id)) {
3835 res = lbm_enc_sym(symbol_id);
3836 } else {
3837 int r = 0;
3838 if (n > 4 &&
3839 tokpar_sym_str[0] == 'e' &&
3840 tokpar_sym_str[1] == 'x' &&
3841 tokpar_sym_str[2] == 't' &&
3842 tokpar_sym_str[3] == '-') {
3843 lbm_uint ext_id;
3844 lbm_uint ext_name_len = (lbm_uint)n + 1;
3845 char *ext_name = lbm_malloc(ext_name_len);
3846 if (!ext_name) {
3847 gc();
3848 ext_name = lbm_malloc(ext_name_len);
3849 }
3850 if (ext_name) {
3851 memcpy(ext_name, tokpar_sym_str, ext_name_len);
3852 r = lbm_add_extension(ext_name, lbm_extensions_default);
3853 if (!lbm_lookup_extension_id(ext_name, &ext_id)) {
3854 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3855 }
3856 symbol_id = ext_id;
3857 } else {
3858 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3859 }
3860 } else {
3861 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04 &&
3862 ctx->flags & EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08) {
3863 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id, true1); //flash
3864 if (!r) {
3865 lbm_set_error_reason((char*)lbm_error_str_flash_error);
3866 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3867 }
3868 } else {
3869 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3870 if (!r) {
3871 gc();
3872 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3873 }
3874 }
3875 }
3876 if (r) {
3877 res = lbm_enc_sym(symbol_id);
3878 } else {
3879 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3880 }
3881 }
3882 lbm_stack_drop(&ctx->K, 2);
3883 ctx->r = res;
3884 ctx->app_cont = true1;
3885 return;
3886 } else if (n == TOKENIZER_NEED_MORE-1) {
3887 goto retry_token;
3888 } else if (n <= TOKENIZER_STRING_ERROR-2) {
3889 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3890 }
3891
3892 /*
3893 * CHAR
3894 */
3895 char c_val;
3896 n = tok_char(chan, &c_val);
3897 if(n > 0) {
3898 lbm_channel_drop(chan,(unsigned int) n);
3899 lbm_stack_drop(&ctx->K, 2);
3900 ctx->r = lbm_enc_char((uint8_t)c_val);
3901 ctx->app_cont = true1;
3902 return;
3903 }else if (n < 0) goto retry_token;
3904
3905 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3906
3907 retry_token:
3908 if (n == TOKENIZER_NEED_MORE-1) {
3909 sptr[0] = stream;
3910 sptr[1] = lbm_enc_u(0);
3911 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3912 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3913 return;
3914 }
3915 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3916}
3917
3918static void cont_read_start_array(eval_context_t *ctx) {
3919 lbm_value *sptr = get_stack_ptr(ctx, 1);
3920 lbm_value stream = sptr[0];
3921
3922 lbm_char_channel_t *str = lbm_dec_channel(stream);
3923 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
3924 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3925 }
3926
3927 lbm_uint num_free = lbm_memory_longest_free();
3928 lbm_uint initial_size = (lbm_uint)((float)num_free * 0.9);
3929 if (initial_size == 0) {
3930 gc();
3931 num_free = lbm_memory_longest_free();
3932 initial_size = (lbm_uint)((float)num_free * 0.9);
3933 if (initial_size == 0) {
3934 lbm_channel_reader_close(str);
3935 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3936 }
3937 }
3938
3939 if (lbm_is_number(ctx->r)) {
3940 lbm_value array;
3941 initial_size = sizeof(lbm_uint) * initial_size;
3942
3943 if (!lbm_heap_allocate_array(&array, initial_size)) {
3944 lbm_set_error_reason("Out of memory while reading.");
3945 lbm_channel_reader_close(str);
3946 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3947 // NOTE: If array is not created evaluation ends here.
3948 // Static analysis seems unaware.
3949 }
3950
3951 sptr[0] = array;
3952 lbm_value *rptr = stack_reserve(ctx, 4);
3953 rptr[0] = lbm_enc_u(initial_size);
3954 rptr[1] = lbm_enc_u(0);
3955 rptr[2] = stream;
3956 rptr[3] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3957 ctx->app_cont = true1;
3958 } else {
3959 lbm_channel_reader_close(str);
3960 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3961 }
3962}
3963
3964static void cont_read_append_array(eval_context_t *ctx) {
3965 lbm_uint *sptr = get_stack_ptr(ctx, 4);
3966
3967 lbm_value array = sptr[0];
3968 lbm_value size = lbm_dec_as_u32(sptr[1]);
3969 lbm_value ix = lbm_dec_as_u32(sptr[2]);
3970 lbm_value stream = sptr[3];
3971
3972 if (ix >= (size - 1)) {
3973 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3974 }
3975
3976 // get_car can return nil. Whose value is 0!
3977 // So static Analysis is right about this being a potential NULL pointer.
3978 // However, if the array was created correcly to begin with, it should be fine.
3979 lbm_value arr_car = get_car(array);
3980 lbm_array_header_t *arr = (lbm_array_header_t*)arr_car;
3981
3982 if (lbm_is_number(ctx->r)) {
3983 ((uint8_t*)arr->data)[ix] = (uint8_t)lbm_dec_as_u32(ctx->r);
3984
3985 sptr[2] = lbm_enc_u(ix + 1);
3986 lbm_value *rptr = stack_reserve(ctx, 4);
3987 rptr[0] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3988 rptr[1] = stream;
3989 rptr[2] = lbm_enc_u(0);
3990 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3991 ctx->app_cont = true1;
3992 } else if (lbm_is_symbol(ctx->r) && ctx->r == ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u)) {
3993 lbm_uint array_size = ix / sizeof(lbm_uint);
3994
3995 if (ix % sizeof(lbm_uint) != 0) {
3996 array_size = array_size + 1;
3997 }
3998 lbm_memory_shrink((lbm_uint*)arr->data, array_size);
3999 arr->size = ix;
4000 lbm_stack_drop(&ctx->K, 4);
4001 ctx->r = array;
4002 ctx->app_cont = true1;
4003 } else {
4004 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
4005 }
4006}
4007
4008static void cont_read_append_continue(eval_context_t *ctx) {
4009 lbm_value *sptr = get_stack_ptr(ctx, 3);
4010
4011 lbm_value first_cell = sptr[0];
4012 lbm_value last_cell = sptr[1];
4013 lbm_value stream = sptr[2];
4014
4015 lbm_char_channel_t *str = lbm_dec_channel(stream);
4016 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4017 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4018 }
4019
4020 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4021
4022 switch(ctx->r) {
4023 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4024 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4025 lbm_set_cdr(last_cell, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate the list
4026 ctx->r = first_cell;
4027 } else {
4028 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4029 }
4030 lbm_stack_drop(&ctx->K, 3);
4031 /* Skip reading another token and apply the continuation */
4032 ctx->app_cont = true1;
4033 return;
4034 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4035 lbm_value *rptr = stack_reserve(ctx, 4);
4036 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4037 rptr[1] = stream;
4038 rptr[2] = lbm_enc_u(0);
4039 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4040 ctx->app_cont = true1;
4041 } return;
4042 }
4043 }
4044 lbm_value new_cell = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4045 if (lbm_is_symbol_merror(new_cell)) {
4046 lbm_channel_reader_close(str);
4047 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4048 return;
4049 }
4050 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4051 lbm_set_cdr(last_cell, new_cell);
4052 last_cell = new_cell;
4053 } else {
4054 first_cell = last_cell = new_cell;
4055 }
4056 sptr[0] = first_cell;
4057 sptr[1] = last_cell;
4058 sptr[2] = stream; // unchanged.
4059 lbm_value *rptr = stack_reserve(ctx, 4);
4060 rptr[0] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
4061 rptr[1] = stream;
4062 rptr[2] = lbm_enc_u(0);
4063 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4064 ctx->app_cont = true1;
4065}
4066
4067static void cont_read_eval_continue(eval_context_t *ctx) {
4068 lbm_value env;
4069 lbm_value stream;
4070 lbm_pop_2(&ctx->K, &env, &stream);
4071
4072 lbm_char_channel_t *str = lbm_dec_channel(stream);
4073 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4074 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4075 }
4076
4077 ctx->row1 = (lbm_int)str->row(str);
4078
4079 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4080
4081 switch(ctx->r) {
4082 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4083 ctx->app_cont = true1;
4084 return;
4085 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4086 // This case is a bit mysterious.
4087 // A dot, may in reality be an error in this location.
4088 lbm_value *rptr = stack_reserve(ctx, 4);
4089 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4090 rptr[1] = stream;
4091 rptr[2] = lbm_enc_u(0);
4092 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4093 ctx->app_cont = true1;
4094 } return;
4095 }
4096 }
4097
4098 lbm_value *rptr = stack_reserve(ctx, 6);
4099 rptr[0] = stream;
4100 rptr[1] = env;
4101 rptr[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
4102 rptr[3] = stream;
4103 rptr[4] = lbm_enc_u(1);
4104 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4105 rptr[6] = lbm_enc_u(ctx->flags);
4106 rptr[7] = POP_READER_FLAGS(((47) << 2) | 0xF8000001u);
4107 ctx->curr_env = env;
4108 ctx->curr_exp = ctx->r;
4109}
4110
4111static void cont_read_expect_closepar(eval_context_t *ctx) {
4112 lbm_value res;
4113 lbm_value stream;
4114
4115 lbm_pop_2(&ctx->K, &res, &stream);
4116
4117 lbm_char_channel_t *str = lbm_dec_channel(stream);
4118 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4119 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4120 }
4121
4122 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4123 ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u)) {
4124 ctx->r = res;
4125 ctx->app_cont = true1;
4126 } else {
4127 lbm_channel_reader_close(str);
4128 lbm_set_error_reason((char*)lbm_error_str_parse_close);
4129 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4130 }
4131}
4132
4133static void cont_read_dot_terminate(eval_context_t *ctx) {
4134 lbm_value *sptr = get_stack_ptr(ctx, 3);
4135
4136 lbm_value first_cell = sptr[0];
4137 lbm_value last_cell = sptr[1];
4138 lbm_value stream = sptr[2];
4139
4140 lbm_char_channel_t *str = lbm_dec_channel(stream);
4141 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4142 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4143 }
4144
4145 lbm_stack_drop(&ctx->K ,3);
4146
4147 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4148 (ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u) ||
4149 ctx->r == ENC_SYM_DOT(((0x76) << 4) | 0x00000000u))) {
4150 lbm_channel_reader_close(str);
4151 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4152 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4153 } else {
4154 if (lbm_is_cons(last_cell)) {
4155 lbm_set_cdr(last_cell, ctx->r);
4156 ctx->r = first_cell;
4157 lbm_value *rptr = stack_reserve(ctx, 6);
4158 rptr[0] = stream;
4159 rptr[1] = ctx->r;
4160 rptr[2] = READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u);
4161 rptr[3] = stream;
4162 rptr[4] = lbm_enc_u(0);
4163 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4164 ctx->app_cont = true1;
4165 } else {
4166 lbm_channel_reader_close(str);
4167 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4168 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4169 }
4170 }
4171}
4172
4173static void cont_read_done(eval_context_t *ctx) {
4174 lbm_value stream;
4175 lbm_value f_val;
4176 lbm_pop_2(&ctx->K, &stream ,&f_val);
4177
4178 uint32_t flags = lbm_dec_as_u32(f_val);
4179 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4180 ctx->flags |= (flags & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4181
4182 lbm_char_channel_t *str = lbm_dec_channel(stream);
4183 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4184 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4185 }
4186
4187 lbm_channel_reader_close(str);
4188 if (lbm_is_symbol(ctx->r)) {
4189 lbm_uint sym_val = lbm_dec_sym(ctx->r);
4190 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
4191 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
4192 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4193 }
4194 }
4195
4196 ctx->row0 = -1;
4197 ctx->row1 = -1;
4198 ctx->app_cont = true1;
4199}
4200
4201static void cont_read_quote_result(eval_context_t *ctx) {
4202 lbm_value cell;
4203 WITH_GC(cell, lbm_heap_allocate_list_init(2,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4204 ENC_SYM_QUOTE,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4205 ctx->r))(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
};
4206 ctx->r = cell;
4207 ctx->app_cont = true1;
4208}
4209
4210static void cont_read_commaat_result(eval_context_t *ctx) {
4211 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4212 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4213 ctx->r = cell1;
4214 ctx->app_cont = true1;
4215}
4216
4217static void cont_read_comma_result(eval_context_t *ctx) {
4218 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u),ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4219 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4220 ctx->r = cell1;
4221 ctx->app_cont = true1;
4222}
4223
4224static void cont_application_start(eval_context_t *ctx) {
4225
4226 /* sptr[0] = env
4227 * sptr[1] = args
4228 * ctx->r = function
4229 */
4230
4231 if (lbm_is_symbol(ctx->r)) {
4232 stack_reserve(ctx,1)[0] = lbm_enc_u(0);
4233 cont_application_args(ctx);
4234 } else if (lbm_is_cons(ctx->r)) {
4235 lbm_uint *sptr = get_stack_ptr(ctx, 2);
4236 lbm_value args = (lbm_value)sptr[1];
4237 switch (get_car(ctx->r)) {
4238 case ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u): {
4239 lbm_value cl[3];
4240 extract_n(get_cdr(ctx->r), cl, 3);
4241 lbm_value arg_env = (lbm_value)sptr[0];
4242 lbm_value arg0, arg_rest;
4243 get_car_and_cdr(args, &arg0, &arg_rest);
4244 sptr[1] = cl[CLO_BODY1];
4245 bool_Bool a_nil = lbm_is_symbol_nil(args);
4246 bool_Bool p_nil = lbm_is_symbol_nil(cl[CLO_PARAMS0]);
4247 lbm_value *reserved = stack_reserve(ctx, 4);
4248
4249 if (!a_nil && !p_nil) {
4250 reserved[0] = cl[CLO_ENV2];
4251 reserved[1] = cl[CLO_PARAMS0];
4252 reserved[2] = arg_rest;
4253 reserved[3] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
4254 ctx->curr_exp = arg0;
4255 ctx->curr_env = arg_env;
4256 } else if (a_nil && p_nil) {
4257 // No params, No args
4258 lbm_stack_drop(&ctx->K, 6);
4259 ctx->curr_exp = cl[CLO_BODY1];
4260 ctx->curr_env = cl[CLO_ENV2];
4261 } else if (p_nil) {
4262 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), cl[CLO_ENV2]);
4263 reserved[0] = rest_binder;
4264 reserved[1] = get_cdr(args);
4265 reserved[2] = get_car(rest_binder);
4266 reserved[3] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
4267 ctx->curr_exp = get_car(args);
4268 ctx->curr_env = arg_env;
4269 } else {
4270 lbm_set_error_reason((char*)lbm_error_str_num_args);
4271 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->r);
4272 }
4273 } break;
4274 case ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u):{
4275 /* Continuation created using call-cc.
4276 * ((SYM_CONT . cont-array) arg0 )
4277 */
4278 lbm_value c = get_cdr(ctx->r); /* should be the continuation array*/
4279
4280 if (!lbm_is_lisp_array_r(c)) {
4281 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4282 }
4283
4284 lbm_uint arg_count = lbm_list_length(args);
4285 lbm_value arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4286 switch (arg_count) {
4287 case 0:
4288 arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4289 break;
4290 case 1:
4291 arg = get_car(args);
4292 break;
4293 default:
4294 lbm_set_error_reason((char*)lbm_error_str_num_args);
4295 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4296 }
4297 lbm_stack_clear(&ctx->K);
4298
4299 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(c);
4300
4301 ctx->K.sp = arr->size / sizeof(lbm_uint);
4302 memcpy(ctx->K.data, arr->data, arr->size);
4303
4304 ctx->curr_exp = arg;
4305 break;
4306 }
4307 case ENC_SYM_MACRO(((0x10D) << 4) | 0x00000000u):{
4308 /*
4309 * Perform macro expansion.
4310 * Macro expansion is really just evaluation in an
4311 * environment augmented with the unevaluated expressions passed
4312 * as arguments.
4313 */
4314 lbm_value env = (lbm_value)sptr[0];
4315
4316 lbm_value curr_param = get_cadr(ctx->r);
4317 lbm_value curr_arg = args;
4318 lbm_value expand_env = env;
4319 while (lbm_is_cons(curr_param) &&
4320 lbm_is_cons(curr_arg)) {
4321 lbm_value car_curr_param, cdr_curr_param;
4322 lbm_value car_curr_arg, cdr_curr_arg;
4323 get_car_and_cdr(curr_param, &car_curr_param, &cdr_curr_param);
4324 get_car_and_cdr(curr_arg, &car_curr_arg, &cdr_curr_arg);
4325
4326 lbm_value entry = cons_with_gc(car_curr_param, car_curr_arg, expand_env);
4327 lbm_value aug_env = cons_with_gc(entry, expand_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4328 expand_env = aug_env;
4329
4330 curr_param = cdr_curr_param;
4331 curr_arg = cdr_curr_arg;
4332 }
4333 /* Two rounds of evaluation is performed.
4334 * First to instantiate the arguments into the macro body.
4335 * Second to evaluate the resulting program.
4336 */
4337 sptr[1] = EVAL_R(((11) << 2) | 0xF8000001u);
4338 lbm_value exp = get_cadr(get_cdr(ctx->r));
4339 ctx->curr_exp = exp;
4340 ctx->curr_env = expand_env;
4341 } break;
4342 default:
4343 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4344 }
4345 } else {
4346 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4347 }
4348}
4349
4350static void cont_eval_r(eval_context_t* ctx) {
4351 lbm_value env;
4352 lbm_pop(&ctx->K, &env);
4353 ctx->curr_exp = ctx->r;
4354 ctx->curr_env = env;
4355}
4356
4357static void cont_progn_var(eval_context_t* ctx) {
4358
4359 lbm_value key;
4360 lbm_value env;
4361
4362 lbm_pop_2(&ctx->K, &key, &env);
4363
4364 if (fill_binding_location(key, ctx->r, env) < 0) {
4365 lbm_set_error_reason("Incorrect type of name/key in let-binding");
4366 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
4367 }
4368
4369 ctx->app_cont = true1;
4370}
4371
4372static void cont_setq(eval_context_t *ctx) {
4373 lbm_value sym;
4374 lbm_value env;
4375 lbm_pop_2(&ctx->K, &sym, &env);
4376 lbm_value res;
4377 WITH_GC(res, perform_setvar(sym, ctx->r, env))(res) = (perform_setvar(sym, ctx->r, env)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (perform_setvar(sym, ctx->r, env)
); if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
4378 ctx->r = res;
4379 ctx->app_cont = true1;
4380}
4381
4382lbm_flash_status request_flash_storage_cell(lbm_value val, lbm_value *res) {
4383
4384 lbm_value flash_cell;
4385 lbm_flash_status s = lbm_allocate_const_cell(&flash_cell);
4386 if (s != LBM_FLASH_WRITE_OK)
4387 return s;
4388 lbm_value new_val = val;
4389 new_val &= ~LBM_PTR_VAL_MASK0x03FFFFFCu; // clear the value part of the ptr
4390 new_val |= (flash_cell & LBM_PTR_VAL_MASK0x03FFFFFCu);
4391 new_val |= LBM_PTR_TO_CONSTANT_BIT0x04000000u;
4392 *res = new_val;
4393 return s;
4394}
4395
4396static void cont_move_to_flash(eval_context_t *ctx) {
4397
4398 lbm_value args;
4399 lbm_pop(&ctx->K, &args);
4400
4401 if (lbm_is_symbol_nil(args)) {
4402 // Done looping over arguments. return true.
4403 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
4404 ctx->app_cont = true1;
4405 return;
4406 }
4407
4408 lbm_value first_arg, rest;
4409 get_car_and_cdr(args, &first_arg, &rest);
4410
4411 lbm_value val;
4412 if (lbm_is_symbol(first_arg) && lbm_global_env_lookup(&val, first_arg)) {
4413 // Prepare to copy the rest of the arguments when done with first.
4414 lbm_value *rptr = stack_reserve(ctx, 2);
4415 rptr[0] = rest;
4416 rptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
4417 if (lbm_is_ptr(val) &&
4418 (!(val & LBM_PTR_TO_CONSTANT_BIT0x04000000u))) {
4419 lbm_value * rptr1 = stack_reserve(ctx, 3);
4420 rptr1[0] = first_arg;
4421 rptr1[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
4422 rptr1[2] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4423 ctx->r = val;
4424 }
4425 ctx->app_cont = true1;
4426 return;
4427 }
4428 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4429}
4430
4431static void cont_move_val_to_flash_dispatch(eval_context_t *ctx) {
4432
4433 lbm_value val = ctx->r;
4434
4435 if (lbm_is_cons(val)) {
4436 lbm_value *rptr = stack_reserve(ctx, 5);
4437 rptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // fst cell of list
4438 rptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last cell of list
4439 rptr[2] = get_cdr(val);
4440 rptr[3] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4441 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4442 ctx->r = get_car(val);
4443 ctx->app_cont = true1;
4444 return;
4445 }
4446
4447 if (lbm_is_ptr(val) && (val & LBM_PTR_TO_CONSTANT_BIT0x04000000u)) {
4448 ctx->r = val;
4449 ctx->app_cont = true1;
4450 return;
4451 }
4452
4453 if (lbm_is_ptr(val)) {
4454 lbm_cons_t *ref = lbm_ref_cell(val);
4455 if (lbm_type_of(ref->cdr) == LBM_TYPE_SYMBOL0x00000000u) {
4456 switch (ref->cdr) {
4457 case ENC_SYM_RAW_I_TYPE(((0x31) << 4) | 0x00000000u): /* fall through */
4458 case ENC_SYM_RAW_U_TYPE(((0x32) << 4) | 0x00000000u):
4459 case ENC_SYM_RAW_F_TYPE(((0x33) << 4) | 0x00000000u): {
4460 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4461 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4462 handle_flash_status(write_const_car(flash_cell, ref->car));
4463 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4464 ctx->r = flash_cell;
4465 } break;
4466 case ENC_SYM_IND_I_TYPE(((0x34) << 4) | 0x00000000u): /* fall through */
4467 case ENC_SYM_IND_U_TYPE(((0x35) << 4) | 0x00000000u):
4468 case ENC_SYM_IND_F_TYPE(((0x36) << 4) | 0x00000000u): {
4469#ifndef LBM64
4470 /* 64 bit values are in lbm mem on 32bit platforms. */
4471 lbm_uint *lbm_mem_ptr = (lbm_uint*)ref->car;
4472 lbm_uint flash_ptr;
4473
4474 handle_flash_status(lbm_write_const_raw(lbm_mem_ptr, 2, &flash_ptr));
4475 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4476 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4477 handle_flash_status(write_const_car(flash_cell, flash_ptr));
4478 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4479 ctx->r = flash_cell;
4480#else
4481 // There are no indirect types in LBM64
4482 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4483#endif
4484 } break;
4485 case ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u): {
4486 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4487 lbm_uint size = arr->size / sizeof(lbm_uint);
4488 lbm_uint flash_addr;
4489 lbm_value *arrdata = (lbm_value *)arr->data;
4490 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4491 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4492 handle_flash_status(lbm_allocate_const_raw(size, &flash_addr));
4493 lift_array_flash(flash_cell,
4494 false0,
4495 (char *)flash_addr,
4496 arr->size);
4497 // Move array contents to flash recursively
4498 lbm_value *rptr = stack_reserve(ctx, 5);
4499 rptr[0] = flash_cell;
4500 rptr[1] = lbm_enc_u(0);
4501 rptr[2] = val;
4502 rptr[3] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4503 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4504 ctx->r = arrdata[0];
4505 ctx->app_cont = true1;
4506 return;
4507 }
4508 case ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u): {
4509 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4510 // arbitrary address: flash_arr.
4511 lbm_uint flash_arr;
4512 handle_flash_status(lbm_write_const_array_padded((uint8_t*)arr->data, arr->size, &flash_arr));
4513 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4514 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4515 lift_array_flash(flash_cell,
4516 true1,
4517 (char *)flash_arr,
4518 arr->size);
4519 ctx->r = flash_cell;
4520 } break;
4521 case ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u): /* fall through */
4522 case ENC_SYM_CUSTOM_TYPE(((0x38) << 4) | 0x00000000u):
4523 lbm_set_error_reason((char *)lbm_error_str_flash_not_possible);
4524 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4525 }
4526 } else {
4527 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4528 }
4529 ctx->app_cont = true1;
4530 return;
4531 }
4532 ctx->r = val;
4533 ctx->app_cont = true1;
4534}
4535
4536static void cont_move_list_to_flash(eval_context_t *ctx) {
4537
4538 // ctx->r holds the value that should go in car
4539
4540 lbm_value *sptr = get_stack_ptr(ctx, 3);
4541
4542 lbm_value fst = sptr[0];
4543 lbm_value lst = sptr[1];
4544 lbm_value val = sptr[2];
4545
4546
4547 lbm_value new_lst = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4548 // Allocate element ptr storage after storing the element to flash.
4549 handle_flash_status(request_flash_storage_cell(lbm_enc_cons_ptr(LBM_PTR_NULL(0x03FFFFFCu >> 2)), &new_lst));
4550
4551 if (lbm_is_symbol_nil(fst)) {
4552 lst = new_lst;
4553 fst = new_lst;
4554 handle_flash_status(write_const_car(lst, ctx->r));
4555 } else {
4556 handle_flash_status(write_const_cdr(lst, new_lst)); // low before high
4557 handle_flash_status(write_const_car(new_lst, ctx->r));
4558 lst = new_lst;
4559 }
4560
4561 if (lbm_is_cons(val)) {
4562 sptr[0] = fst;
4563 sptr[1] = lst;//rest_cell;
4564 sptr[2] = get_cdr(val);
4565 lbm_value *rptr = stack_reserve(ctx, 2);
4566 rptr[0] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4567 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4568 ctx->r = get_car(val);
4569 } else {
4570 sptr[0] = fst;
4571 sptr[1] = lst;
4572 sptr[2] = CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u);
4573 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4574 ctx->r = val;
4575 }
4576 ctx->app_cont = true1;
4577}
4578
4579static void cont_close_list_in_flash(eval_context_t *ctx) {
4580 lbm_value fst;
4581 lbm_value lst;
4582 lbm_pop_2(&ctx->K, &lst, &fst);
4583 lbm_value val = ctx->r;
4584 handle_flash_status(write_const_cdr(lst, val));
4585 ctx->r = fst;
4586 ctx->app_cont = true1;
4587}
4588
4589static void cont_move_array_elts_to_flash(eval_context_t *ctx) {
4590 lbm_value *sptr = get_stack_ptr(ctx, 3);
4591 // sptr[2] = source array in RAM
4592 // sptr[1] = current index
4593 // sptr[0] = target array in flash
4594 lbm_array_header_t *src_arr = (lbm_array_header_t*)get_car(sptr[2]);
4595 lbm_uint size = src_arr->size / sizeof(lbm_uint);
4596 lbm_value *srcdata = (lbm_value *)src_arr->data;
4597
4598 lbm_array_header_t *tgt_arr = (lbm_array_header_t*)get_car(sptr[0]);
4599 lbm_uint *tgtdata = (lbm_value *)tgt_arr->data;
4600 lbm_uint ix = lbm_dec_as_u32(sptr[1]);
4601 handle_flash_status(lbm_const_write(&tgtdata[ix], ctx->r));
4602 if (ix >= size-1) {
4603 ctx->r = sptr[0];
4604 lbm_stack_drop(&ctx->K, 3);
4605 ctx->app_cont = true1;
4606 return;
4607 }
4608 sptr[1] = lbm_enc_u(ix + 1);
4609 lbm_value *rptr = stack_reserve(ctx, 2);
4610 rptr[0] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4611 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4612 ctx->r = srcdata[ix+1];
4613 ctx->app_cont = true1;
4614 return;
4615}
4616
4617static void cont_qq_expand_start(eval_context_t *ctx) {
4618 lbm_value *rptr = stack_reserve(ctx, 2);
4619 rptr[0] = ctx->r;
4620 rptr[1] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4621 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4622 ctx->app_cont = true1;
4623}
4624
4625lbm_value quote_it(lbm_value qquoted) {
4626 if (lbm_is_symbol(qquoted) &&
4627 lbm_is_special(qquoted)) return qquoted;
4628
4629 lbm_value val = cons_with_gc(qquoted, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4630 return cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4631}
4632
4633bool_Bool is_append(lbm_value a) {
4634 return (lbm_is_cons(a) &&
4635 lbm_is_symbol(get_car(a)) &&
4636 (get_car(a) == ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u)));
4637}
4638
4639lbm_value append(lbm_value front, lbm_value back) {
4640 if (lbm_is_symbol_nil(front)) return back;
4641 if (lbm_is_symbol_nil(back)) return front;
4642
4643 if (lbm_is_quoted_list(front) &&
4644 lbm_is_quoted_list(back)) {
4645 lbm_value f = get_cadr(front);
4646 lbm_value b = get_cadr(back);
4647 return quote_it(lbm_list_append(f, b));
4648 }
4649
4650 if (is_append(back) &&
4651 lbm_is_quoted_list(get_cadr(back)) &&
4652 lbm_is_quoted_list(front)) {
4653 lbm_value ql = get_cadr(back);
4654 lbm_value f = get_cadr(front);
4655 lbm_value b = get_cadr(ql);
4656
4657 lbm_value v = lbm_list_append(f, b);
4658 lbm_set_car(get_cdr(ql), v);
4659 return back;
4660 }
4661
4662 if (is_append(back)) {
4663 back = get_cdr(back);
4664 lbm_value new = cons_with_gc(front, back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4665 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), new, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4666 }
4667
4668 lbm_value t0, t1;
4669
4670 t0 = cons_with_gc(back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), front);
4671 t1 = cons_with_gc(front, t0, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4672 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), t1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4673}
4674
4675/* Bawden's qq-expand implementation
4676(define (qq-expand x)
4677 (cond ((tag-comma? x)
4678 (tag-data x))
4679 ((tag-comma-atsign? x)
4680 (error "Illegal"))
4681 ((tag-backquote? x)
4682 (qq-expand
4683 (qq-expand (tag-data x))))
4684 ((pair? x)
4685 `(append
4686 ,(qq-expand-list (car x))
4687 ,(qq-expand (cdr x))))
4688 (else `',x)))
4689 */
4690static void cont_qq_expand(eval_context_t *ctx) {
4691 lbm_value qquoted;
4692 lbm_pop(&ctx->K, &qquoted);
4693
4694 switch(lbm_type_of(qquoted)) {
4695 case LBM_TYPE_CONS0x10000000u: {
4696 lbm_value car_val = get_car(qquoted);
4697 lbm_value cdr_val = get_cdr(qquoted);
4698 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4699 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4700 ctx->r = append(ctx->r, get_car(cdr_val));
4701 ctx->app_cont = true1;
4702 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4703 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4704 error_ctx(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u));
4705 } else {
4706 lbm_value *rptr = stack_reserve(ctx, 6);
4707 rptr[0] = ctx->r;
4708 rptr[1] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4709 rptr[2] = cdr_val;
4710 rptr[3] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4711 rptr[4] = car_val;
4712 rptr[5] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4713 ctx->app_cont = true1;
4714 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4715 }
4716
4717 } break;
4718 default: {
4719 lbm_value res = quote_it(qquoted);
4720 ctx->r = append(ctx->r, res);
4721 ctx->app_cont = true1;
4722 }
4723 }
4724}
4725
4726static void cont_qq_append(eval_context_t *ctx) {
4727 lbm_value head;
4728 lbm_pop(&ctx->K, &head);
4729 ctx->r = append(head, ctx->r);
4730 ctx->app_cont = true1;
4731}
4732
4733/* Bawden's qq-expand-list implementation
4734(define (qq-expand-list x)
4735 (cond ((tag-comma? x)
4736 `(list ,(tag-data x)))
4737 ((tag-comma-atsign? x)
4738 (tag-data x))
4739 ((tag-backquote? x)
4740 (qq-expand-list
4741 (qq-expand (tag-data x))))
4742 ((pair? x)
4743 `(list
4744 (append
4745 ,(qq-expand-list (car x))
4746 ,(qq-expand (cdr x)))))
4747 (else `'(,x))))
4748*/
4749
4750static void cont_qq_expand_list(eval_context_t* ctx) {
4751 lbm_value l;
4752 lbm_pop(&ctx->K, &l);
4753
4754 ctx->app_cont = true1;
4755 switch(lbm_type_of(l)) {
4756 case LBM_TYPE_CONS0x10000000u: {
4757 lbm_value car_val = get_car(l);
4758 lbm_value cdr_val = get_cdr(l);
4759 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4760 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4761 lbm_value tl = cons_with_gc(get_car(cdr_val), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4762 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4763 ctx->r = append(ctx->r, tmp);
4764 return;
4765 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4766 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4767 ctx->r = get_car(cdr_val);
4768 return;
4769 } else {
4770 lbm_value *rptr = stack_reserve(ctx, 7);
4771 rptr[0] = QQ_LIST(((39) << 2) | 0xF8000001u);
4772 rptr[1] = ctx->r;
4773 rptr[2] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4774 rptr[3] = cdr_val;
4775 rptr[4] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4776 rptr[5] = car_val;
4777 rptr[6] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4778 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4779 }
4780
4781 } break;
4782 default: {
4783 lbm_value a_list = cons_with_gc(l, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4784 lbm_value tl = cons_with_gc(a_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4785 lbm_value tmp = cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4786 ctx->r = append(ctx->r, tmp);
4787 }
4788 }
4789}
4790
4791static void cont_qq_list(eval_context_t *ctx) {
4792 lbm_value val = ctx->r;
4793 lbm_value apnd_app = cons_with_gc(val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4794 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), apnd_app, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4795 ctx->r = tmp;
4796 ctx->app_cont = true1;
4797}
4798
4799static void cont_kill(eval_context_t *ctx) {
4800 (void) ctx;
4801 finish_ctx();
4802}
4803
4804static void cont_pop_reader_flags(eval_context_t *ctx) {
4805 lbm_value flags;
4806 lbm_pop(&ctx->K, &flags);
4807 ctx->flags = ctx->flags & ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4808 ctx->flags |= (lbm_dec_as_u32(flags) & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4809 // r is unchanged.
4810 ctx->app_cont = true1;
4811}
4812
4813static void cont_exception_handler(eval_context_t *ctx) {
4814 lbm_value *sptr = pop_stack_ptr(ctx, 2);
4815 lbm_value retval = sptr[0];
4816 lbm_value flags = sptr[1];
4817 lbm_set_car(get_cdr(retval), ctx->r);
4818 ctx->flags = flags;
4819 ctx->r = retval;
4820 ctx->app_cont = true1;
4821}
4822
4823/*********************************************************/
4824/* Continuations table */
4825typedef void (*cont_fun)(eval_context_t *);
4826
4827static const cont_fun continuations[NUM_CONTINUATIONS49] =
4828 { advance_ctx, // CONT_DONE
4829 cont_set_global_env,
4830 cont_bind_to_key_rest,
4831 cont_if,
4832 cont_progn_rest,
4833 cont_application_args,
4834 cont_and,
4835 cont_or,
4836 cont_wait,
4837 cont_match,
4838 cont_application_start,
4839 cont_eval_r,
4840 cont_resume,
4841 cont_closure_application_args,
4842 cont_exit_atomic,
4843 cont_read_next_token,
4844 cont_read_append_continue,
4845 cont_read_eval_continue,
4846 cont_read_expect_closepar,
4847 cont_read_dot_terminate,
4848 cont_read_done,
4849 cont_read_quote_result,
4850 cont_read_commaat_result,
4851 cont_read_comma_result,
4852 cont_read_start_array,
4853 cont_read_append_array,
4854 cont_map,
4855 cont_match_guard,
4856 cont_terminate,
4857 cont_progn_var,
4858 cont_setq,
4859 cont_move_to_flash,
4860 cont_move_val_to_flash_dispatch,
4861 cont_move_list_to_flash,
4862 cont_close_list_in_flash,
4863 cont_qq_expand_start,
4864 cont_qq_expand,
4865 cont_qq_append,
4866 cont_qq_expand_list,
4867 cont_qq_list,
4868 cont_kill,
4869 cont_loop,
4870 cont_loop_condition,
4871 cont_merge_rest,
4872 cont_merge_layer,
4873 cont_closure_args_rest,
4874 cont_move_array_elts_to_flash,
4875 cont_pop_reader_flags,
4876 cont_exception_handler
4877 };
4878
4879/*********************************************************/
4880/* Evaluators lookup table (special forms) */
4881typedef void (*evaluator_fun)(eval_context_t *);
4882
4883static const evaluator_fun evaluators[] =
4884 {
4885 eval_quote,
4886 eval_define,
4887 eval_progn,
4888 eval_lambda,
4889 eval_if,
4890 eval_let,
4891 eval_and,
4892 eval_or,
4893 eval_match,
4894 eval_receive,
4895 eval_receive_timeout,
4896 eval_callcc,
4897 eval_atomic,
4898 eval_selfevaluating, // macro
4899 eval_selfevaluating, // cont
4900 eval_selfevaluating, // closure
4901 eval_cond,
4902 eval_app_cont,
4903 eval_var,
4904 eval_setq,
4905 eval_move_to_flash,
4906 eval_loop,
4907 eval_trap
4908 };
4909
4910
4911/*********************************************************/
4912/* Evaluator step function */
4913
4914static void evaluation_step(void){
4915 eval_context_t *ctx = ctx_running;
4916#ifdef VISUALIZE_HEAP
4917 heap_vis_gen_image();
4918#endif
4919
4920 if (ctx->app_cont) {
4921 lbm_value k;
4922 lbm_pop(&ctx->K, &k);
4923 ctx->app_cont = false0;
4924
4925 lbm_uint decoded_k = DEC_CONTINUATION(k)(((k) & ~0xF8000001u) >> 2);
4926
4927 if (decoded_k < NUM_CONTINUATIONS49) {
4928 continuations[decoded_k](ctx);
4929 } else {
4930 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4931 }
4932 return;
4933 }
4934
4935 if (lbm_is_symbol(ctx->curr_exp)) {
4936 eval_symbol(ctx);
4937 return;
4938 }
4939 if (lbm_is_cons(ctx->curr_exp)) {
4940 lbm_cons_t *cell = lbm_ref_cell(ctx->curr_exp);
4941 lbm_value h = cell->car;
4942 if (lbm_is_symbol(h) && ((h & ENC_SPECIAL_FORMS_MASK0xFFFFF000) == ENC_SPECIAL_FORMS_BIT0x00001000)) {
4943 lbm_uint eval_index = lbm_dec_sym(h) & SPECIAL_FORMS_INDEX_MASK0x000000FF;
4944 evaluators[eval_index](ctx);
4945 return;
4946 }
4947 /*
4948 * At this point head can be anything. It should evaluate
4949 * into a form that can be applied (closure, symbol, ...) though.
4950 */
4951 lbm_value *reserved = stack_reserve(ctx, 3);
4952 reserved[0] = ctx->curr_env;
4953 reserved[1] = cell->cdr;
4954 reserved[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
4955 ctx->curr_exp = h; // evaluate the function
4956 return;
4957 }
4958
4959 eval_selfevaluating(ctx);
4960 return;
4961}
4962
4963void lbm_pause_eval(void ) {
4964 eval_cps_next_state_arg = 0;
4965 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4966 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4967}
4968
4969void lbm_pause_eval_with_gc(uint32_t num_free) {
4970 eval_cps_next_state_arg = num_free;
4971 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4972 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4973}
4974
4975void lbm_continue_eval(void) {
4976 eval_cps_next_state = EVAL_CPS_STATE_RUNNING2;
4977 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4978}
4979
4980void lbm_kill_eval(void) {
4981 eval_cps_next_state = EVAL_CPS_STATE_KILL4;
4982 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4983}
4984
4985uint32_t lbm_get_eval_state(void) {
4986 return eval_cps_run_state;
4987}
4988
4989// Will wake up thread that is sleeping as well.
4990// Not sure this is good behavior.
4991static void handle_event_unblock_ctx(lbm_cid cid, lbm_value v) {
4992 eval_context_t *found = NULL((void*)0);
4993 mutex_lock(&qmutex);
4994
4995 found = lookup_ctx_nm(&blocked, cid);
4996 if (found) {
4997 drop_ctx_nm(&blocked,found);
4998 if (lbm_is_error(v)) {
4999 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
5000 found->app_cont = true1;
5001 }
5002 found->r = v;
5003 enqueue_ctx_nm(&queue,found);
5004 }
5005 mutex_unlock(&qmutex);
5006}
5007
5008static void handle_event_define(lbm_value key, lbm_value val) {
5009 lbm_uint dec_key = lbm_dec_sym(key);
5010 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
5011 lbm_value *global_env = lbm_get_global_env();
5012 lbm_uint orig_env = global_env[ix_key];
5013 lbm_value new_env;
5014 // A key is a symbol and should not need to be remembered.
5015 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
5016
5017 global_env[ix_key] = new_env;
5018}
5019
5020static lbm_value get_event_value(lbm_event_t *e) {
5021 lbm_value v;
5022 if (e->buf_len > 0) {
5023 lbm_flat_value_t fv;
5024 fv.buf = (uint8_t*)e->buf_ptr;
5025 fv.buf_size = e->buf_len;
5026 fv.buf_pos = 0;
5027 if (!lbm_unflatten_value(&fv, &v)) {
5028 lbm_set_flags(LBM_FLAG_HANDLER_EVENT_DELIVERY_FAILED(1 << 1));
5029 v = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
5030 }
5031 // Free the flat value buffer. GC is unaware of its existence.
5032 lbm_free(fv.buf);
5033 } else {
5034 v = (lbm_value)e->buf_ptr;
5035 }
5036 return v;
5037}
5038
5039static void process_events(void) {
5040
5041 if (!lbm_events) return;
5042 lbm_event_t e;
5043
5044 while (lbm_event_pop(&e)) {
5045
5046 lbm_value event_val = get_event_value(&e);
5047 switch(e.type) {
5048 case LBM_EVENT_UNBLOCK_CTX:
5049 handle_event_unblock_ctx((lbm_cid)e.parameter, event_val);
5050 break;
5051 case LBM_EVENT_DEFINE:
5052 handle_event_define((lbm_value)e.parameter, event_val);
5053 break;
5054 case LBM_EVENT_FOR_HANDLER:
5055 if (lbm_event_handler_pid >= 0) {
5056 lbm_find_receiver_and_send(lbm_event_handler_pid, event_val);
5057 }
5058 break;
5059 }
5060 }
5061}
5062
5063/* eval_cps_run can be paused
5064 I think it would be better use a mailbox for
5065 communication between other threads and the run_eval
5066 but for now a set of variables will be used. */
5067void lbm_run_eval(void){
5068
5069 if (setjmp(critical_error_jmp_buf)_setjmp (critical_error_jmp_buf) > 0) {
5070 printf_callback("GC stack overflow!\n");
5071 critical_error_callback();
5072 // terminate evaluation thread.
5073 return;
5074 }
5075
5076 setjmp(error_jmp_buf)_setjmp (error_jmp_buf);
5077
5078 while (eval_running) {
5079 if (eval_cps_state_changed || eval_cps_run_state == EVAL_CPS_STATE_PAUSED1) {
5080 eval_cps_state_changed = false0;
5081 switch (eval_cps_next_state) {
5082 case EVAL_CPS_STATE_PAUSED1:
5083 if (eval_cps_run_state != EVAL_CPS_STATE_PAUSED1) {
5084 if (lbm_heap_num_free() < eval_cps_next_state_arg) {
5085 gc();
5086 }
5087 eval_cps_next_state_arg = 0;
5088 }
5089 eval_cps_run_state = EVAL_CPS_STATE_PAUSED1;
5090 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5091 continue; /* jump back to start of eval_running loop */
5092 case EVAL_CPS_STATE_KILL4:
5093 eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
5094 eval_running = false0;
5095 continue;
5096 default: // running state
5097 eval_cps_run_state = eval_cps_next_state;
5098 break;
5099 }
5100 }
5101 while (true1) {
5102 if (eval_steps_quota && ctx_running) {
5103 eval_steps_quota--;
5104 evaluation_step();
5105 } else {
5106 if (eval_cps_state_changed) break;
5107 eval_steps_quota = eval_steps_refill;
5108 if (is_atomic) {
5109 if (!ctx_running) {
5110 lbm_set_flags(LBM_FLAG_ATOMIC_MALFUNCTION(1 << 0));
5111 is_atomic = 0;
5112 }
5113 } else {
5114 if (gc_requested) {
5115 gc();
5116 }
5117 process_events();
5118 mutex_lock(&qmutex);
5119 if (ctx_running) {
5120 enqueue_ctx_nm(&queue, ctx_running);
5121 ctx_running = NULL((void*)0);
5122 }
5123 wake_up_ctxs_nm();
5124 ctx_running = dequeue_ctx_nm(&queue);
5125 mutex_unlock(&qmutex);
5126 if (!ctx_running) {
5127 lbm_system_sleeping = true1;
5128 //Fixed sleep interval to poll events regularly.
5129 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5130 lbm_system_sleeping = false0;
5131 }
5132 }
5133 }
5134 }
5135 }
5136}
5137
5138lbm_cid lbm_eval_program(lbm_value lisp) {
5139 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), 256, NULL((void*)0));
5140}
5141
5142lbm_cid lbm_eval_program_ext(lbm_value lisp, unsigned int stack_size) {
5143 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), stack_size, NULL((void*)0));
5144}
5145
5146int lbm_eval_init() {
5147 if (!qmutex_initialized) {
5148 mutex_init(&qmutex);
5149 qmutex_initialized = true1;
5150 }
5151 if (!lbm_events_mutex_initialized) {
5152 mutex_init(&lbm_events_mutex);
5153 lbm_events_mutex_initialized = true1;
5154 }
5155 if (!blocking_extension_mutex_initialized) {
5156 mutex_init(&blocking_extension_mutex);
5157 blocking_extension_mutex_initialized = true1;
5158 }
5159
5160 mutex_lock(&qmutex);
5161 mutex_lock(&lbm_events_mutex);
5162
5163 blocked.first = NULL((void*)0);
5164 blocked.last = NULL((void*)0);
5165 queue.first = NULL((void*)0);
5166 queue.last = NULL((void*)0);
5167 ctx_running = NULL((void*)0);
5168
5169 eval_cps_run_state = EVAL_CPS_STATE_RUNNING2;
5170
5171 mutex_unlock(&lbm_events_mutex);
5172 mutex_unlock(&qmutex);
5173
5174 if (!lbm_init_env()) return 0;
5175 eval_running = true1;
5176 return 1;
5177}
5178
5179bool_Bool lbm_eval_init_events(unsigned int num_events) {
5180
5181 mutex_lock(&lbm_events_mutex);
5182 lbm_events = (lbm_event_t*)lbm_malloc(num_events * sizeof(lbm_event_t));
5183 bool_Bool r = false0;
5184 if (lbm_events) {
5185 lbm_events_max = num_events;
5186 lbm_events_head = 0;
5187 lbm_events_tail = 0;
5188 lbm_events_full = false0;
5189 lbm_event_handler_pid = -1;
5190 r = true1;
5191 }
5192 mutex_unlock(&lbm_events_mutex);
5193 return r;
5194}
+
+
←

./include/heap.h

+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1
2/*
3 Copyright 2018, 2024 Joel Svensson svenssonjoel@yahoo.se
4
5 This program is free software: you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation, either version 3 of the License, or
8 (at your option) any later version.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
14
15 You should have received a copy of the GNU General Public License
16 along with this program. If not, see <http://www.gnu.org/licenses/>.
17*/
18/** \file heap.h */
19
20#ifndef HEAP_H_
21#define HEAP_H_
22
23#include <string.h>
24#include <stdarg.h>
25
26#include "lbm_types.h"
27#include "symrepr.h"
28#include "stack.h"
29#include "lbm_memory.h"
30#include "lbm_defines.h"
31#include "lbm_channel.h"
32
33#ifdef __cplusplus
34extern "C" {
35#endif
36
37/*
38Planning for a more space efficient heap representation.
39TODO: Need to find a good reference to read up on this.
40 - List based heap
41 - Easy to implement and somewhat efficient
42
430000 0000 Size Free bits
44003F FFFF 4MB 10
45007F FFFF 8MB 9
4600FF FFFF 16MB 8
4701FF FFFF 32MB 7
4803FF FFFF 64MB 6 * Kind of heap size I am looking for
4907FF FFFF 128MB 5
500FFF FFFF 256MB 4
511FFF FFFF 512MB 3
52
53
54--- May 9 2021 ---
55Actually now I am much more interested in way smaller memories ;)
56
570000 0000 Size Free bits
580000 0FFF 4KB 20 |
590000 1FFF 8KB 19 |
600000 3FFF 16KB 18 |
610000 7FFF 32KB 17 |
620000 FFFF 64KB 16 |
630001 FFFF 128KB 15 |
640003 FFFF 256KB 14 | - This range is very interesting.
650007 FFFF 512KB 13
66000F FFFF 1MB 12
67001F FFFF 2MB 11
68003F FFFF 4MB 10
69007F FFFF 8MB 9
7000FF FFFF 16MB 8
7101FF FFFF 32MB 7
7203FF FFFF 64MB 6
7307FF FFFF 128MB 5
740FFF FFFF 256MB 4
751FFF FFFF 512MB 3
76
77Those are the kind of platforms that are fun... so a bunch of
78wasted bits in heap pointers if we run on small MCUs.
79
80-----------------
81
82it is also the case that not all addresses will be used if all "cells" are
83of the same size, 8 bytes...
84
85value 0: 0000 0000
86value 1: 0000 0008
87value 3: 0000 0010
88value 4: 0000 0018
89
90Means bits 0,1,2 will always be empty in a valid address.
91
92Cons cells also need to be have room for 2 pointers. So each ted cell from
93memory should be 8bytes.
94
95Things that needs to be represented within these bits:
96
97 - GC MARK one per cell
98 - TYPE: type of CAR and type of cons
99
100Types I would want:
101 - Full 32bit integer. Does not leave room for identification of type
102 - Float values. Same problem
103
104
105Free bits in pointers 64MB heap:
10631 30 29 28 27 26 2 1 0
1070 0 0 0 0 0 XX XXXX XXXX XXXX XXXX XXXX X 0 0 0
108
109
110Information needed for each cell:
111 Meaning | bits total | bits per car | bits per cdr
112 GC mark | 2 | 1 | 1 - only one of them will be used (the other is wasted)
113 Type | 2x | x | x
114 Ptr/!ptr | 2 | 1 | 1
115
116
117Types (unboxed):
118 - Symbols
119 - 28bit integer ( will need signed shift right functionality )
120 - 28bit unsigned integer
121 - Character
122
123If four types is all that should be possible (unboxed). then 2 bits are needed to differentiate.
1242 + 1 + 1 = 4 => 28bits for data.
125
126bit 0: ptr/!ptr
127bit 1: gc
128bit 2-3: type (if not ptr)
129bit 3 - 24 ptr (if ptr)
130bit 4 - 31 value (if value)
131
132An unboxed value can occupy a car or cdr field in a cons cell.
133
134types (boxed) extra information in pointer to cell can contain information
135 - 32 bit integer
136 - 32 bit unsigned integer
137 - 32 bit float
138
139boxed representation:
140 [ptr| cdr]
141 |
142 [Value | Aux + GC_MARK]
143
144Kinds of pointers:
145 - Pointer to cons cell.
146 - Pointer to unboxed value (fixnums not in a list, I hope this is so rare that it can be removed )
147 - integer
148 - unsigned integer
149 - symbol
150 - float
151 - Pointer to boxed value.
152 - 32 bit integer
153 - 32 bit unsigned integer
154 - 32 bit float
155 - (Maybe something else ? Vectors/strings allocated in memory not occupied by heap?)
156 - vector of int
157 - vector of uint
158 - vector of float
159 - vector of double
160 - String
161
16213 pointer"types" -> needs 4 bits
163for 64MB heap there are 6 free bits. So with this scheme going to 128MB or 256MB heap
164is also possible
165
166 a pointer to some off heap vector/string could be represented by
167
168 [ptr | cdr]
169 |
170 [full pointer | Aux + GC_MARK]
171 |
172 [VECTOR]
173
174Aux bits could be used for storing vector size. Up to 30bits should be available there
175>> This is problematic. Now the information that something is a vector is split up
176>> between 2 cons cells. This means GC needs both of these intact to be able to make
177>> proper decision.
178>> Will try to resolve this by adding some special symbols. But these must be symbols
179>> that cannot occur normally in programs. Then an array could be:
180
181 [Full pointer | ARRAY_SYM + GC_MARK]
182 |
183 [VECTOR]
184
185>> Boxed values same treatment as above.
186>> TODO: Could this be simpler?
187
188[ VALUE | TYPE_SYM + GC_MARK]
189
190
1910000 00XX XXXX XXXX XXXX XXXX XXXX X000 : 0x03FF FFF8
1921111 AA00 0000 0000 0000 0000 0000 0000 : 0xFC00 0000 (AA bits left unused for now, future heap growth?)
193 */
194
195typedef enum {
196 LBM_FLASH_WRITE_OK,
197 LBM_FLASH_FULL,
198 LBM_FLASH_WRITE_ERROR
199} lbm_flash_status;
200
201/** Struct representing a heap cons-cell.
202 *
203 */
204typedef struct {
205 lbm_value car;
206 lbm_value cdr;
207} lbm_cons_t;
208
209/**
210 * Heap state
211 */
212typedef struct {
213 lbm_cons_t *heap;
214 lbm_value freelist; // list of free cons cells.
215 lbm_stack_t gc_stack;
216
217 lbm_uint heap_size; // In number of cells.
218 lbm_uint heap_bytes; // In bytes.
219
220 lbm_uint num_alloc; // Number of cells allocated.
221 lbm_uint num_alloc_arrays; // Number of arrays allocated.
222
223 lbm_uint gc_num; // Number of times gc has been performed.
224 lbm_uint gc_marked; // Number of cells marked by mark phase.
225 lbm_uint gc_recovered; // Number of cells recovered by sweep phase.
226 lbm_uint gc_recovered_arrays;// Number of arrays recovered by sweep.
227 lbm_uint gc_least_free; // The smallest length of the freelist.
228 lbm_uint gc_last_free; // Number of elements on the freelist
229 // after most recent GC.
230} lbm_heap_state_t;
231
232extern lbm_heap_state_t lbm_heap_state;
233
234typedef bool_Bool (*const_heap_write_fun)(lbm_uint ix, lbm_uint w);
235
236typedef struct {
237 lbm_uint *heap;
238 lbm_uint next; // next free index.
239 lbm_uint size; // in lbm_uint words. (cons-cells = words / 2)
240} lbm_const_heap_t;
241
242/**
243 * The header portion of an array stored in array and symbol memory.
244 * An array is always a byte array. use the array-extensions for
245 * storing and reading larger values from arrays.
246 */
247typedef struct {
248 lbm_uint size; /// Number of elements
249 lbm_uint *data; /// pointer to lbm_memory array or C array.
250} lbm_array_header_t;
251
252typedef struct {
253 lbm_uint size;
254 lbm_uint *data;
255 uint32_t index; // Limits arrays to max 2^32-1 elements.
256} lbm_array_header_extended_t;
257
258/** Lock GC mutex
259 * Locks a mutex during GC marking when using the pointer reversal algorithm.
260 * Does nothing when using stack based GC mark.
261 */
262void lbm_gc_lock(void);
263/* Unlock GC mutex
264 */
265void lbm_gc_unlock(void);
266
267/** Initialize heap storage.
268 * \param addr Pointer to an array of lbm_cons_t elements. This array must at least be aligned 4.
269 * \param num_cells Number of lbm_cons_t elements in the array.
270 * \param gc_stack_size Size of the gc_stack in number of words.
271 * \return 1 on success or 0 for failure.
272 */
273int lbm_heap_init(lbm_cons_t *addr, lbm_uint num_cells,
274 lbm_uint gc_stack_size);
275
276/** Add GC time statistics to heap_stats
277 *
278 * \param dur Duration as reported by the timestamp callback.
279 */
280void lbm_heap_new_gc_time(lbm_uint dur);
281/** Add a new free_list length to the heap_stats.
282 * Calculates a new freelist length and updates
283 * the GC statistics.
284 */
285void lbm_heap_new_freelist_length(void);
286/** Check how many lbm_cons_t cells are on the free-list
287 *
288 * \return Number of free lbm_cons_t cells.
289 */
290lbm_uint lbm_heap_num_free(void);
291/** Check how many lbm_cons_t cells are allocated.
292 *
293 * \return Number of lbm_cons_t cells that are currently allocated.
294 */
295lbm_uint lbm_heap_num_allocated(void);
296/** Size of the heap in number of lbm_cons_t cells.
297 *
298 * \return Size of the heap in number of lbm_cons_t cells.
299 */
300lbm_uint lbm_heap_size(void);
301/** Size of the heap in bytes.
302 *
303 * \return Size of heap in bytes.
304 */
305lbm_uint lbm_heap_size_bytes(void);
306/** Allocate an lbm_cons_t cell from the heap.
307 *
308 * \param type A type that can be encoded onto the cell (most often LBM_PTR_TYPE_CONS).
309 * \param car Value to write into car position of allocated cell.
310 * \param cdr Value to write into cdr position of allocated cell.
311 * \return An lbm_value referring to a cons_cell or enc_sym(SYM_MERROR) in case the heap is full.
312 */
313lbm_value lbm_heap_allocate_cell(lbm_type type, lbm_value car, lbm_value cdr);
314/** Allocate a list of n heap-cells.
315 * \param n The number of heap-cells to allocate.
316 * \return A list of heap-cells of Memory error if unable to allocate.
317 */
318lbm_value lbm_heap_allocate_list(lbm_uint n);
319/** Allocate a list of n heap-cells and initialize the values.
320 * \pram ls The result list is passed through this ptr.
321 * \param n The length of list to allocate.
322 * \param valist The values in a va_list to initialize the list with.
323 * \return True of False depending on success of allocation.
324 */
325lbm_value lbm_heap_allocate_list_init_va(unsigned int n, va_list valist);
326/** Allocate a list of n heap-cells and initialize the values.
327 * \param n The length of list to allocate.
328 * \param ... The values to initialize the list with.
329 * \return allocated list or error symbol.
330 */
331lbm_value lbm_heap_allocate_list_init(unsigned int n, ...);
332/** Decode an lbm_value representing a string into a C string
333 *
334 * \param val Value
335 * \return allocated list or error symbol
336 */
337char *lbm_dec_str(lbm_value val);
338/** Decode an lbm_value representing a char channel into an lbm_char_channel_t pointer.
339 *
340 * \param val Value
341 * \return A pointer to an lbm_char_channel_t or NULL if the value does not encode a channel.
342 */
343lbm_char_channel_t *lbm_dec_channel(lbm_value val);
344/** Decode an lbm_value representing a custom type into a lbm_uint value.
345 *
346 * \param val Value.
347 * \return The custom type payload.
348 */
349lbm_uint lbm_dec_custom(lbm_value val);
350/** Decode a numerical value as if it is char
351 *
352 * \param val Value to decode
353 * \return The value encoded in val casted to a char. Returns 0 if val does not encode a number.
354 */
355uint8_t lbm_dec_as_char(lbm_value a);
356/** Decode a numerical value as if it is unsigned
357 *
358 * \param val Value to decode
359 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
360 */
361uint32_t lbm_dec_as_u32(lbm_value val);
362/** Decode a numerical value as a signed integer.
363 *
364 * \param val Value to decode
365 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
366 */
367int32_t lbm_dec_as_i32(lbm_value val);
368/** Decode a numerical value as a float.
369 *
370 * \param val Value to decode.
371 * \return The value encoded in val casted to a float. Returns 0 if val does not encode a number.
372 */
373float lbm_dec_as_float(lbm_value val);
374/** Decode a numerical value as if it is a 64bit unsigned
375 *
376 * \param val Value to decode
377 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
378 */
379uint64_t lbm_dec_as_u64(lbm_value val);
380/** Decode a numerical value as a 64bit signed integer.
381 *
382 * \param val Value to decode
383 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
384 */
385int64_t lbm_dec_as_i64(lbm_value val);
386/** Decode a numerical value as a float.
387 *
388 * \param val Value to decode.
389 * \return The value encoded in val casted to a float. Returns 0 if val does not encode a number.
390 */
391double lbm_dec_as_double(lbm_value val);
392
393/** Decode a numerical value into the architecture defined unsigned integer type.
394 *
395 * \param val Value to decode
396 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
397 */
398lbm_uint lbm_dec_as_uint(lbm_value val);
399
400/** Decode a numerical value into the architecture defined signed integer type.
401 *
402 * \param val Value to decode
403 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
404 */
405lbm_int lbm_dec_as_int(lbm_value val);
406
407lbm_uint lbm_dec_raw(lbm_value v);
408/** Allocates an lbm_cons_t cell from the heap and populates it.
409 *
410 * \param car The value to put in the car field of the allocated lbm_cons_t.
411 * \param cdr The value to put in the cdr field of the allocated lbm_cons_t.
412 * \return A value referencing the lbm_cons_t or enc_sym(SYM_MERROR) if heap is full.
413 */
414lbm_value lbm_cons(lbm_value car, lbm_value cdr);
415
416/** Accesses the car field of an lbm_cons_t.
417 *
418 * \param cons Value
419 * \return The car field of the lbm_cons_t if cons is a reference to a heap cell.
420 * If cons is nil, the return value is nil. If the value
421 * is not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
422 */
423lbm_value lbm_car(lbm_value cons);
424/** Accesses the car field the car field of an lbm_cons_t.
425 *
426 * \param cons Value
427 * \return The car of car field or nil.
428 */
429lbm_value lbm_caar(lbm_value c);
430/** Accesses the car of the cdr of an cons cell
431 *
432 * \param c Value
433 * \return the cdr field or type error.
434 */
435lbm_value lbm_cadr(lbm_value c);
436/** Accesses the cdr field of an lbm_cons_t.
437 *
438 * \param cons Value
439 * \return The cdr field of the lbm_cons_t if cons is a reference to a heap cell.
440 * If cons is nil, the return value is nil. If the value
441 * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
442 */
443lbm_value lbm_cdr(lbm_value cons);
444/** Accesses the cdr of an cdr field of an lbm_cons_t.
445 *
446 * \param cons Value
447 * \return The cdr of the cdr field of the lbm_cons_t if cons is a reference to a heap cell.
448 * If cons is nil, the return value is nil. If the value
449 * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
450 */
451lbm_value lbm_cddr(lbm_value c);
452/** Update the value stored in the car field of a heap cell.
453 *
454 * \param c Value referring to a heap cell.
455 * \param v Value to replace the car field with.
456 * \return 1 on success and 0 if the c value does not refer to a heap cell.
457 */
458int lbm_set_car(lbm_value c, lbm_value v);
459/** Update the value stored in the cdr field of a heap cell.
460 *
461 * \param c Value referring to a heap cell.
462 * \param v Value to replace the cdr field with.
463 * \return 1 on success and 0 if the c value does not refer to a heap cell.
464 */
465int lbm_set_cdr(lbm_value c, lbm_value v);
466/** Update the value stored in the car and cdr fields of a heap cell.
467 *
468 * \param c Value referring to a heap cell.
469 * \param car_val Value to replace the car field with.
470 * \param cdr_val Value to replace the cdr field with.
471 * \return 1 on success and 0 if the c value does not refer to a heap cell.
472 */
473int lbm_set_car_and_cdr(lbm_value c, lbm_value car_val, lbm_value cdr_val);
474// List functions
475/** Calculate the length of a proper list
476 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
477 * may lead to the function not terminating.
478 *
479 * \param c A list
480 * \return The length of the list. Unless the value is a cyclic structure on the heap, this function will terminate.
481 */
482lbm_uint lbm_list_length(lbm_value c);
483
484/** Calculate the length of a proper list and evaluate a predicate for each element.
485 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
486 * may lead to the function not terminating.
487 *
488 * \param c A list
489 * \param pres Boolean result of predicate, false if predicate is false for any of the elements in the list, otherwise true.
490 * \param pred Predicate to evaluate for each element of the list.
491 */
492unsigned int lbm_list_length_pred(lbm_value c, bool_Bool *pres, bool_Bool (*pred)(lbm_value));
493/** Reverse a proper list
494 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
495 * may lead to the function not terminating.
496 *
497 * \param list A list
498 * \return The list reversed or enc_sym(SYM_MERROR) if heap is full.
499 */
500lbm_value lbm_list_reverse(lbm_value list);
501/** Reverse a proper list destroying the original.
502 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
503 * may lead to the function not terminating.
504 *
505 * \param list A list
506 * \return The list reversed
507 */
508lbm_value lbm_list_destructive_reverse(lbm_value list);
509/** Copy a list
510 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
511 * may lead to the function not terminating.
512 *
513 * \param m Number of elements to copy or -1 for all. If 1, m will be updated with the length of the list
514 * \param list A list.
515 * \return Reversed list or enc_sym(SYM_MERROR) if heap is full.
516 */
517lbm_value lbm_list_copy(int *m, lbm_value list);
518
519/** A destructive append of two lists
520 *
521 * \param list1 A list
522 * \param list2 A list
523 * \return list1 with list2 appended at the end.
524 */
525lbm_value lbm_list_append(lbm_value list1, lbm_value list2);
526
527/** Drop values from the head of a list.
528 * \param n Number of values to drop.
529 * \param ls List to drop values from.
530 * \return The list with the n first elements removed.
531 */
532lbm_value lbm_list_drop(unsigned int n, lbm_value ls);
533/** Index into a list.
534 * \param l List to index into.
535 * \param n Position to read out of the list.
536 * \return Value at position n of l or nil if out of bounds.
537 */
538lbm_value lbm_index_list(lbm_value l, int32_t n);
539
540// State and statistics
541/** Get a copy of the heap statistics structure.
542 *
543 * \param A pointer to an lbm_heap_state_t to populate
544 * with the current statistics.
545 */
546void lbm_get_heap_state(lbm_heap_state_t *);
547/** Get the maximum stack level of the GC stack
548 * \return maximum value the gc stack sp reached so far.
549 */
550lbm_uint lbm_get_gc_stack_max(void);
551/** Get the size of the GC stack.
552 * \return the size of the gc stack.
553 */
554lbm_uint lbm_get_gc_stack_size(void);
555// Garbage collection
556/** Increment the counter that is counting the number of times GC ran
557 *
558 */
559void lbm_gc_state_inc(void);
560/** Set the freelist to NIL. Means that no memory will be available
561 * until after a garbage collection.
562 */
563void lbm_nil_freelist(void);
564/** Mark all heap cells reachable from an environment.
565 * \param environment.
566 */
567void lbm_gc_mark_env(lbm_value);
568/** Mark heap cells reachable from the lbm_value v.
569 * \param root
570 */
571void lbm_gc_mark_phase(lbm_value root);
572/** Performs lbm_gc_mark_phase on all the values of an array.
573 * This function is similar to lbm_gc_mark_roots but performs
574 * extra checks to not traverse into non-standard values.
575 * TODO: Check if this function is really needed.
576 * \param data Array of roots to traverse from.
577 * \param n Number of elements in roots-array.
578 */
579void lbm_gc_mark_aux(lbm_uint *data, lbm_uint n);
580/** Performs lbm_gc_mark_phase on all the values in the roots array.
581 * \param roots pointer to array of roots.
582 * \param num_roots size of array of roots.
583 */
584void lbm_gc_mark_roots(lbm_uint *roots, lbm_uint num_roots);
585/** Sweep up all non marked heap cells and place them on the free list.
586 *
587 * \return 1
588 */
589int lbm_gc_sweep_phase(void);
590
591// Array functionality
592/** Allocate an bytearray in symbols and arrays memory (lispbm_memory.h)
593 * and create a heap cell that refers to this bytearray.
594 * \param res The resulting lbm_value is returned through this argument.
595 * \param size Array size in number of 32 bit words.
596 * \return 1 for success of 0 for failure.
597 */
598int lbm_heap_allocate_array(lbm_value *res, lbm_uint size);
599/** Allocate an array in symbols and arrays memory (lispbm_memory.h)
600 * and create a heap cell that refers to this array.
601 * \param res The resulting lbm_value is returned through this argument.
602 * \param size Array size in number of 32 bit words.
603 * \return 1 for success of 0 for failure.
604 */
605int lbm_heap_allocate_lisp_array(lbm_value *res, lbm_uint size);
606/** Convert a C array into an lbm array. If the C array is allocated in LBM MEMORY
607 * the lifetime of the array will be managed by GC.
608 * \param res lbm_value result pointer for storage of the result array.
609 * \param data C array.
610 * \param type The type tag to assign to the resulting LBM array.
611 * \param num_elt Number of elements in the array.
612 * \return 1 for success and 0 for failure.
613 */
614int lbm_lift_array(lbm_value *value, char *data, lbm_uint num_elt);
615/** Get the size of an array value.
616 * \param arr lbm_value array to get size of.
617 * \return -1 for failure or length of array.
618 */
619lbm_int lbm_heap_array_get_size(lbm_value arr);
620/** Get a pointer to the data of an array for read only purposes.
621 * \param arr lbm_value array to get pointer from.
622 * \return NULL or valid pointer.
623 */
624const uint8_t *lbm_heap_array_get_data_ro(lbm_value arr);
625/** Get a pointer to the data of an array for read/write purposes.
626 * \param arr lbm_value array to get pointer from.
627 * \return NULL or valid pointer.
628 */
629uint8_t *lbm_heap_array_get_data_rw(lbm_value arr);
630/** Explicitly free an array.
631 * This function needs to be used with care and knowledge.
632 * \param arr Array value.
633 */
634int lbm_heap_explicit_free_array(lbm_value arr);
635/** Query the size in bytes of an lbm_type.
636 * \param t Type
637 * \return Size in bytes of type or 0 if the type represents a composite.
638 */
639lbm_uint lbm_size_of(lbm_type t);
640
641int lbm_const_heap_init(const_heap_write_fun w_fun,
642 lbm_const_heap_t *heap,
643 lbm_uint *addr,
644 lbm_uint num_words);
645
646lbm_flash_status lbm_allocate_const_cell(lbm_value *res);
647lbm_flash_status lbm_write_const_raw(lbm_uint *data, lbm_uint n, lbm_uint *res);
648lbm_flash_status lbm_allocate_const_raw(lbm_uint nwords, lbm_uint *res);
649lbm_flash_status write_const_cdr(lbm_value cell, lbm_value val);
650lbm_flash_status write_const_car(lbm_value cell, lbm_value val);
651lbm_flash_status lbm_const_write(lbm_uint *tgt, lbm_uint val);
652lbm_uint lbm_flash_memory_usage(void);
653
654/** Query the type information of a value.
655 *
656 * \param x Value to check the type of.
657 * \return The type information.
658 */
659static inline lbm_type lbm_type_of(lbm_value x) {
660 return (x & LBM_PTR_BIT0x00000001u) ? (x & LBM_PTR_TYPE_MASK0xFC000000u) : (x & LBM_VAL_TYPE_MASK0x0000000Cu);
661}
662
663// type-of check that is safe in functional code
664static inline lbm_type lbm_type_of_functional(lbm_value x) {
665 return (x & LBM_PTR_BIT0x00000001u) ?
666 (x & (LBM_PTR_TO_CONSTANT_MASK~0x04000000u & LBM_PTR_TYPE_MASK0xFC000000u)) :
667 (x & LBM_VAL_TYPE_MASK0x0000000Cu);
668}
669
670static inline lbm_value lbm_enc_cons_ptr(lbm_uint x) {
671 return ((x << LBM_ADDRESS_SHIFT2) | LBM_TYPE_CONS0x10000000u | LBM_PTR_BIT0x00000001u);
672}
673
674static inline lbm_uint lbm_dec_ptr(lbm_value p) {
675 return ((LBM_PTR_VAL_MASK0x03FFFFFCu & p) >> LBM_ADDRESS_SHIFT2);
676}
677
678extern lbm_cons_t *lbm_heaps[2];
679
680static inline lbm_uint lbm_dec_cons_cell_ptr(lbm_value p) {
681 lbm_uint h = (p & LBM_PTR_TO_CONSTANT_BIT0x04000000u) >> LBM_PTR_TO_CONSTANT_SHIFT26;
682 return lbm_dec_ptr(p) >> h;
683}
684
685static inline lbm_cons_t *lbm_dec_heap(lbm_value p) {
686 lbm_uint h = (p & LBM_PTR_TO_CONSTANT_BIT0x04000000u) >> LBM_PTR_TO_CONSTANT_SHIFT26;
687 return lbm_heaps[h];
688}
689
690static inline lbm_value lbm_set_ptr_type(lbm_value p, lbm_type t) {
691 return ((LBM_PTR_VAL_MASK0x03FFFFFCu & p) | t | LBM_PTR_BIT0x00000001u);
692}
693
694static inline lbm_value lbm_enc_sym(lbm_uint s) {
695 return (s << LBM_VAL_SHIFT4) | LBM_TYPE_SYMBOL0x00000000u;
696}
697
698static inline lbm_value lbm_enc_i(lbm_int x) {
699 return ((lbm_uint)x << LBM_VAL_SHIFT4) | LBM_TYPE_I0x00000008u;
700}
701
702static inline lbm_value lbm_enc_u(lbm_uint x) {
703 return (x << LBM_VAL_SHIFT4) | LBM_TYPE_U0x0000000Cu;
704}
705
706/** Encode 32 bit integer into an lbm_value.
707 * \param x Value to encode.
708 * \return result encoded value.
709 */
710extern lbm_value lbm_enc_i32(int32_t x);
711
712/** Encode 32 bit unsigned integer into an lbm_value.
713 * \param x Value to encode.
714 * \return result encoded value.
715 */
716extern lbm_value lbm_enc_u32(uint32_t x);
717
718/** Encode a float into an lbm_value.
719 * \param x float value to encode.
720 * \return result encoded value.
721 */
722extern lbm_value lbm_enc_float(float x);
723
724/** Encode a 64 bit integer into an lbm_value.
725 * \param x 64 bit integer to encode.
726 * \return result encoded value.
727 */
728extern lbm_value lbm_enc_i64(int64_t x);
729
730/** Encode a 64 bit unsigned integer into an lbm_value.
731 * \param x 64 bit unsigned integer to encode.
732 * \return result encoded value.
733 */
734extern lbm_value lbm_enc_u64(uint64_t x);
735
736/** Encode a double into an lbm_value.
737 * \param x double to encode.
738 * \return result encoded value.
739 */
740extern lbm_value lbm_enc_double(double x);
741
742static inline lbm_value lbm_enc_char(uint8_t x) {
743 return ((lbm_uint)x << LBM_VAL_SHIFT4) | LBM_TYPE_CHAR0x00000004u;
744}
745
746static inline lbm_int lbm_dec_i(lbm_value x) {
747 return (lbm_int)x >> LBM_VAL_SHIFT4;
748}
749
750static inline lbm_uint lbm_dec_u(lbm_value x) {
751 return x >> LBM_VAL_SHIFT4;
752}
753
754static inline uint8_t lbm_dec_char(lbm_value x) {
755 return (uint8_t)(x >> LBM_VAL_SHIFT4);
756}
757
758static inline lbm_uint lbm_dec_sym(lbm_value x) {
759 return x >> LBM_VAL_SHIFT4;
760}
761
762/** Decode an lbm_value representing a float.
763 * \param x Value to decode.
764 * \return decoded float.
765 */
766extern float lbm_dec_float(lbm_value x);
767
768/** Decode an lbm_value representing a double.
769 * \param x Value to decode.
770 * \return decoded float.
771 */
772extern double lbm_dec_double(lbm_value x);
773
774
775static inline uint32_t lbm_dec_u32(lbm_value x) {
776#ifndef LBM64
777 return (uint32_t)lbm_car(x);
778#else
779 return (uint32_t)(x >> LBM_VAL_SHIFT4);
780#endif
781}
782
783/** Decode an lbm_value representing a 64 bit unsigned integer.
784 * \param x Value to decode.
785 * \return decoded uint64_t.
786 */
787extern uint64_t lbm_dec_u64(lbm_value x);
788
789static inline int32_t lbm_dec_i32(lbm_value x) {
790#ifndef LBM64
791 return (int32_t)lbm_car(x);
792#else
793 return (int32_t)(x >> LBM_VAL_SHIFT4);
794#endif
795}
796
797/** Decode an lbm_value representing a 64 bit integer.
798 * \param x Value to decode.
799 * \return decoded int64_t.
800 */
801extern int64_t lbm_dec_i64(lbm_value x);
802
803/**
804 * Check if a value is a heap pointer
805 * \param x Value to check
806 * \return true if x is a pointer to a heap cell, false otherwise.
807 */
808static inline bool_Bool lbm_is_ptr(lbm_value x) {
809 return (x & LBM_PTR_BIT0x00000001u);
810}
811
812/**
813 * Check if a value is a Read/Writeable cons cell
814 * \param x Value to check
815 * \return true if x is a Read/Writeable cons cell, false otherwise.
816 */
817static inline bool_Bool lbm_is_cons_rw(lbm_value x) {
818 return (lbm_type_of(x) == LBM_TYPE_CONS0x10000000u);
819}
820
821/**
822 * Check if a value is a Readable cons cell
823 * \param x Value to check
824 * \return true if x is a readable cons cell, false otherwise.
825 */
826static inline bool_Bool lbm_is_cons(lbm_value x) {
827 return lbm_is_ptr(x) && ((x & LBM_CONS_TYPE_MASK0xF0000000u) == LBM_TYPE_CONS0x10000000u);
828}
829
830/** Check if a value represents a number
831 * \param x Value to check.
832 * \return true is x represents a number and false otherwise.
833 */
834static inline bool_Bool lbm_is_number(lbm_value x) {
835 return
836 (x & LBM_PTR_BIT0x00000001u) ?
837 ((x & LBM_NUMBER_MASK0x08000000u) == LBM_NUMBER_MASK0x08000000u) :
838 (x & LBM_VAL_TYPE_MASK0x0000000Cu);
839}
840
841/** Check if value is an array that can be READ
842 * \param x Value to check.
843 * \return true if x represents a readable array and false otherwise.
844 */
845static inline bool_Bool lbm_is_array_r(lbm_value x) {
846 lbm_type t = lbm_type_of(x);
847 return ((t & LBM_PTR_TO_CONSTANT_MASK~0x04000000u) == LBM_TYPE_ARRAY0x80000000u);
848}
849
850static inline bool_Bool lbm_is_array_rw(lbm_value x) {
851 return( (lbm_type_of(x) == LBM_TYPE_ARRAY0x80000000u) && !(x & LBM_PTR_TO_CONSTANT_BIT0x04000000u));
852}
853
854static inline bool_Bool lbm_is_lisp_array_r(lbm_value x) {
855 lbm_type t = lbm_type_of(x);
856 return ((t & LBM_PTR_TO_CONSTANT_MASK~0x04000000u) == LBM_TYPE_LISPARRAY0xB0000000u);
857}
858
859static inline bool_Bool lbm_is_lisp_array_rw(lbm_value x) {
860 return( (lbm_type_of(x) == LBM_TYPE_LISPARRAY0xB0000000u) && !(x & LBM_PTR_TO_CONSTANT_BIT0x04000000u));
861}
862
863
864static inline bool_Bool lbm_is_channel(lbm_value x) {
865 return (lbm_type_of(x) == LBM_TYPE_CHANNEL0x90000000u &&
866 lbm_type_of(lbm_cdr(x)) == LBM_TYPE_SYMBOL0x00000000u &&
867 lbm_cdr(x) == ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
868}
869static inline bool_Bool lbm_is_char(lbm_value x) {
870 return (lbm_type_of(x) == LBM_TYPE_CHAR0x00000004u);
871}
872
873static inline bool_Bool lbm_is_special(lbm_value symrep) {
874 return ((lbm_type_of(symrep) == LBM_TYPE_SYMBOL0x00000000u) &&
875 (lbm_dec_sym(symrep) < SPECIAL_SYMBOLS_END0xFFFF));
876}
877
878static inline bool_Bool lbm_is_closure(lbm_value exp) {
879 return ((lbm_is_cons(exp)) &&
880 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
881 (lbm_car(exp) == ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u)));
882}
883
884static inline bool_Bool lbm_is_continuation(lbm_value exp) {
885 return ((lbm_type_of(exp) == LBM_TYPE_CONS0x10000000u) &&
886 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
887 (lbm_car(exp) == ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u)));
888}
889
890static inline bool_Bool lbm_is_macro(lbm_value exp) {
891 return ((lbm_type_of(exp) == LBM_TYPE_CONS0x10000000u) &&
892 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
893 (lbm_car(exp) == ENC_SYM_MACRO(((0x10D) << 4) | 0x00000000u)));
894}
895
896static inline bool_Bool lbm_is_match_binder(lbm_value exp) {
897 return (lbm_is_cons(exp) &&
898 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
899 (lbm_car(exp) == ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u)));
900}
901
902static inline bool_Bool lbm_is_comma_qualified_symbol(lbm_value exp) {
903 return (lbm_is_cons(exp) &&
904 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
905 (lbm_car(exp) == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) &&
906 (lbm_type_of(lbm_cadr(exp)) == LBM_TYPE_SYMBOL0x00000000u));
907}
908
909static inline bool_Bool lbm_is_symbol(lbm_value exp) {
910 return !(exp & LBM_LOW_RESERVED_BITS0x0000000Fu);
911}
912
913static inline bool_Bool lbm_is_symbol_nil(lbm_value exp) {
914 return !exp;
24
←
Assuming 'exp' is 0
→
25
←
Returning the value 1, which participates in a condition later
→
915}
916
917static inline bool_Bool lbm_is_symbol_true(lbm_value exp) {
918 return (lbm_is_symbol(exp) && exp == ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u));
919}
920
921static inline bool_Bool lbm_is_symbol_eval(lbm_value exp) {
922 return (lbm_is_symbol(exp) && exp == ENC_SYM_EVAL(((0x30008) << 4) | 0x00000000u));
923}
924
925static inline bool_Bool lbm_is_symbol_merror(lbm_value exp) {
926 return lbm_is_symbol(exp) && (exp == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
927}
928
929static inline bool_Bool lbm_is_list(lbm_value x) {
930 return (lbm_is_cons(x) || lbm_is_symbol_nil(x));
931}
932
933static inline bool_Bool lbm_is_list_rw(lbm_value x) {
934 return (lbm_is_cons_rw(x) || lbm_is_symbol_nil(x));
935}
936
937static inline bool_Bool lbm_is_quoted_list(lbm_value x) {
938 return (lbm_is_cons(x) &&
939 lbm_is_symbol(lbm_car(x)) &&
940 (lbm_car(x) == ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u)) &&
941 lbm_is_cons(lbm_cdr(x)) &&
942 lbm_is_cons(lbm_cadr(x)));
943}
944
945#ifndef LBM64
946#define ERROR_SYMBOL_MASK0xFFFFFFF0 0xFFFFFFF0
947#else
948#define ERROR_SYMBOL_MASK0xFFFFFFF0 0xFFFFFFFFFFFFFFF0
949#endif
950
951/* all error signaling symbols are in the range 0x20 - 0x2F */
952static inline bool_Bool lbm_is_error(lbm_value v){
953 return (lbm_is_symbol(v) &&
954 ((lbm_dec_sym(v) & ERROR_SYMBOL_MASK0xFFFFFFF0) == 0x20));
955}
956
957// ref_cell: returns a reference to the cell addressed by bits 3 - 26
958// Assumes user has checked that is_ptr was set
959static inline lbm_cons_t* lbm_ref_cell(lbm_value addr) {
960 return &lbm_dec_heap(addr)[lbm_dec_cons_cell_ptr(addr)];
961 //return &lbm_heap_state.heap[lbm_dec_ptr(addr)];
962}
963
964
965// lbm_uint a = lbm_heaps[0];
966// lbm_uint b = lbm_heaps[1];
967// lbm_uint i = (addr & LBM_PTR_TO_CONSTANT_BIT) >> LBM_PTR_TO_CONSTANT_SHIFT) - 1;
968// lbm_uint h = (a & i) | (b & ~i);
969
970#ifdef __cplusplus
971}
972#endif
973#endif
diff --git a/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-47103f.html b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-47103f.html new file mode 100644 index 00000000..854e8f93 --- /dev/null +++ b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-47103f.html @@ -0,0 +1,6553 @@ + + + +src/eval_cps.c + + + + + + + + + + + + + + + + + + + + + + + + + + +

Bug Summary

+ + + + +
File:eval_cps.c
Warning:line 3998, column 34
Access to field 'data' results in a dereference of a null pointer (loaded from variable 'arr')
+ +

Annotated Source Code

+

Press '?' + to see keyboard shortcuts

+ + +
clang -cc1 -triple i386-pc-linux-gnu -analyze -disable-free -disable-llvm-verifier -discard-value-names -main-file-name eval_cps.c -analyzer-store=region -analyzer-opt-analyze-nested-blocks -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -mrelocation-model static -mthread-model posix -mframe-pointer=none -fmath-errno -fno-rounding-math -masm-verbose -mconstructor-aliases -target-cpu i686 -dwarf-column-info -fno-split-dwarf-inlining -debugger-tuning=gdb -resource-dir /usr/lib/llvm-10/lib/clang/10.0.0 -I ./include -I ./include/extensions -I platform/linux/include -D _PRELUDE -internal-isystem /usr/local/include -internal-isystem /usr/lib/llvm-10/lib/clang/10.0.0/include -internal-externc-isystem /usr/include/i386-linux-gnu -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -std=c99 -fdebug-compilation-dir /home/joels/Current/lispbm -ferror-limit 19 -fmessage-length 0 -fgnuc-version=4.2.1 -fobjc-runtime=gcc -fdiagnostics-show-option -vectorize-loops -vectorize-slp -analyzer-output=html -faddrsig -o /home/joels/Current/lispbm/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1 -x c src/eval_cps.c +
+ + + +
+ + +
+ + + + +
+

src/eval_cps.c

+
→
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1/*
2 Copyright 2018, 2020 - 2024 Joel Svensson svenssonjoel@yahoo.se
3
4 This program is free software: you can redistribute it and/or modify
5 it under the terms of the GNU General Public License as published by
6 the Free Software Foundation, either version 3 of the License, or
7 (at your option) any later version.
8
9 This program is distributed in the hope that it will be useful,
10 but WITHOUT ANY WARRANTY; without even the implied warranty of
11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 GNU General Public License for more details.
13
14 You should have received a copy of the GNU General Public License
15 along with this program. If not, see <http://www.gnu.org/licenses/>.
16*/
17
18#include <lbm_memory.h>
19#include <lbm_types.h>
20#include "symrepr.h"
21#include "heap.h"
22#include "env.h"
23#include "eval_cps.h"
24#include "stack.h"
25#include "fundamental.h"
26#include "extensions.h"
27#include "tokpar.h"
28#include "lbm_channel.h"
29#include "print.h"
30#include "platform_mutex.h"
31#include "lbm_flat_value.h"
32#include "lbm_flags.h"
33
34#ifdef VISUALIZE_HEAP
35#include "heap_vis.h"
36#endif
37
38#include <setjmp.h>
39#include <stdarg.h>
40
41static jmp_buf error_jmp_buf;
42static jmp_buf critical_error_jmp_buf;
43
44#define S_TO_US(X)(lbm_uint)((X) * 1000000) (lbm_uint)((X) * 1000000)
45
46#define DEC_CONTINUATION(x)(((x) & ~0xF8000001u) >> 2) (((x) & ~LBM_CONTINUATION_INTERNAL0xF8000001u) >> LBM_ADDRESS_SHIFT2)
47#define IS_CONTINUATION(x)(((x) & 0xF8000001u) == 0xF8000001u) (((x) & LBM_CONTINUATION_INTERNAL0xF8000001u) == LBM_CONTINUATION_INTERNAL0xF8000001u)
48#define CONTINUATION(x)(((x) << 2) | 0xF8000001u) (((x) << LBM_ADDRESS_SHIFT2) | LBM_CONTINUATION_INTERNAL0xF8000001u)
49
50#define DONE(((0) << 2) | 0xF8000001u) CONTINUATION(0)(((0) << 2) | 0xF8000001u)
51#define SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u) CONTINUATION(1)(((1) << 2) | 0xF8000001u)
52#define BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u) CONTINUATION(2)(((2) << 2) | 0xF8000001u)
53#define IF(((3) << 2) | 0xF8000001u) CONTINUATION(3)(((3) << 2) | 0xF8000001u)
54#define PROGN_REST(((4) << 2) | 0xF8000001u) CONTINUATION(4)(((4) << 2) | 0xF8000001u)
55#define APPLICATION_ARGS(((5) << 2) | 0xF8000001u) CONTINUATION(5)(((5) << 2) | 0xF8000001u)
56#define AND(((6) << 2) | 0xF8000001u) CONTINUATION(6)(((6) << 2) | 0xF8000001u)
57#define OR(((7) << 2) | 0xF8000001u) CONTINUATION(7)(((7) << 2) | 0xF8000001u)
58#define WAIT(((8) << 2) | 0xF8000001u) CONTINUATION(8)(((8) << 2) | 0xF8000001u)
59#define MATCH(((9) << 2) | 0xF8000001u) CONTINUATION(9)(((9) << 2) | 0xF8000001u)
60#define APPLICATION_START(((10) << 2) | 0xF8000001u) CONTINUATION(10)(((10) << 2) | 0xF8000001u)
61#define EVAL_R(((11) << 2) | 0xF8000001u) CONTINUATION(11)(((11) << 2) | 0xF8000001u)
62#define RESUME(((12) << 2) | 0xF8000001u) CONTINUATION(12)(((12) << 2) | 0xF8000001u)
63#define CLOSURE_ARGS(((13) << 2) | 0xF8000001u) CONTINUATION(13)(((13) << 2) | 0xF8000001u)
64#define EXIT_ATOMIC(((14) << 2) | 0xF8000001u) CONTINUATION(14)(((14) << 2) | 0xF8000001u)
65#define READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u) CONTINUATION(15)(((15) << 2) | 0xF8000001u)
66#define READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u) CONTINUATION(16)(((16) << 2) | 0xF8000001u)
67#define READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u) CONTINUATION(17)(((17) << 2) | 0xF8000001u)
68#define READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u) CONTINUATION(18)(((18) << 2) | 0xF8000001u)
69#define READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u) CONTINUATION(19)(((19) << 2) | 0xF8000001u)
70#define READ_DONE(((20) << 2) | 0xF8000001u) CONTINUATION(20)(((20) << 2) | 0xF8000001u)
71#define READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u) CONTINUATION(21)(((21) << 2) | 0xF8000001u)
72#define READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u) CONTINUATION(22)(((22) << 2) | 0xF8000001u)
73#define READ_COMMA_RESULT(((23) << 2) | 0xF8000001u) CONTINUATION(23)(((23) << 2) | 0xF8000001u)
74#define READ_START_ARRAY(((24) << 2) | 0xF8000001u) CONTINUATION(24)(((24) << 2) | 0xF8000001u)
75#define READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u) CONTINUATION(25)(((25) << 2) | 0xF8000001u)
76#define MAP(((26) << 2) | 0xF8000001u) CONTINUATION(26)(((26) << 2) | 0xF8000001u)
77#define MATCH_GUARD(((27) << 2) | 0xF8000001u) CONTINUATION(27)(((27) << 2) | 0xF8000001u)
78#define TERMINATE(((28) << 2) | 0xF8000001u) CONTINUATION(28)(((28) << 2) | 0xF8000001u)
79#define PROGN_VAR(((29) << 2) | 0xF8000001u) CONTINUATION(29)(((29) << 2) | 0xF8000001u)
80#define SETQ(((30) << 2) | 0xF8000001u) CONTINUATION(30)(((30) << 2) | 0xF8000001u)
81#define MOVE_TO_FLASH(((31) << 2) | 0xF8000001u) CONTINUATION(31)(((31) << 2) | 0xF8000001u)
82#define MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u) CONTINUATION(32)(((32) << 2) | 0xF8000001u)
83#define MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u) CONTINUATION(33)(((33) << 2) | 0xF8000001u)
84#define CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u) CONTINUATION(34)(((34) << 2) | 0xF8000001u)
85#define QQ_EXPAND_START(((35) << 2) | 0xF8000001u) CONTINUATION(35)(((35) << 2) | 0xF8000001u)
86#define QQ_EXPAND(((36) << 2) | 0xF8000001u) CONTINUATION(36)(((36) << 2) | 0xF8000001u)
87#define QQ_APPEND(((37) << 2) | 0xF8000001u) CONTINUATION(37)(((37) << 2) | 0xF8000001u)
88#define QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u) CONTINUATION(38)(((38) << 2) | 0xF8000001u)
89#define QQ_LIST(((39) << 2) | 0xF8000001u) CONTINUATION(39)(((39) << 2) | 0xF8000001u)
90#define KILL(((40) << 2) | 0xF8000001u) CONTINUATION(40)(((40) << 2) | 0xF8000001u)
91#define LOOP(((41) << 2) | 0xF8000001u) CONTINUATION(41)(((41) << 2) | 0xF8000001u)
92#define LOOP_CONDITION(((42) << 2) | 0xF8000001u) CONTINUATION(42)(((42) << 2) | 0xF8000001u)
93#define MERGE_REST(((43) << 2) | 0xF8000001u) CONTINUATION(43)(((43) << 2) | 0xF8000001u)
94#define MERGE_LAYER(((44) << 2) | 0xF8000001u) CONTINUATION(44)(((44) << 2) | 0xF8000001u)
95#define CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u) CONTINUATION(45)(((45) << 2) | 0xF8000001u)
96#define MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u) CONTINUATION(46)(((46) << 2) | 0xF8000001u)
97#define POP_READER_FLAGS(((47) << 2) | 0xF8000001u) CONTINUATION(47)(((47) << 2) | 0xF8000001u)
98#define EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u) CONTINUATION(48)(((48) << 2) | 0xF8000001u)
99#define NUM_CONTINUATIONS49 49
100
101#define FM_NEED_GC-1 -1
102#define FM_NO_MATCH-2 -2
103#define FM_PATTERN_ERROR-3 -3
104
105typedef enum {
106 BL_OK = 0,
107 BL_NO_MEMORY,
108 BL_INCORRECT_KEY
109} binding_location_status;
110
111#define FB_OK0 0
112#define FB_TYPE_ERROR-1 -1
113
114const char* lbm_error_str_parse_eof = "End of parse stream.";
115const char* lbm_error_str_parse_dot = "Incorrect usage of '.'.";
116const char* lbm_error_str_parse_close = "Expected closing parenthesis.";
117const char* lbm_error_str_num_args = "Incorrect number of arguments.";
118const char* lbm_error_str_forbidden_in_atomic = "Operation is forbidden in an atomic block.";
119const char* lbm_error_str_no_number = "Argument(s) must be a number.";
120const char* lbm_error_str_not_a_boolean = "Argument must be t or nil (true or false).";
121const char* lbm_error_str_incorrect_arg = "Incorrect argument.";
122const char* lbm_error_str_var_outside_progn = "Usage of var outside of progn.";
123const char* lbm_error_str_flash_not_possible = "Value cannot be written to flash.";
124const char* lbm_error_str_flash_error = "Error writing to flash.";
125const char* lbm_error_str_flash_full = "Flash memory is full.";
126const char* lbm_error_str_variable_not_bound = "Variable not bound.";
127
128static lbm_value lbm_error_suspect;
129static bool_Bool lbm_error_has_suspect = false0;
130#ifdef LBM_ALWAYS_GC
131
132#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
133 gc(); \
134 (y) = (x); \
135 if (lbm_is_symbol_merror((y))) { \
136 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
137 }
138
139#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
140 lbm_gc_mark_phase(r); \
141 gc(); \
142 (y) = (x); \
143 if (lbm_is_symbol_merror((y))) { \
144 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
145 }
146
147#else
148
149#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
150 (y) = (x); \
151 if (lbm_is_symbol_merror((y))) { \
152 gc(); \
153 (y) = (x); \
154 if (lbm_is_symbol_merror((y))) { \
155 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
156 } \
157 /* continue executing statements below */ \
158 }
159#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
160 (y) = (x); \
161 if (lbm_is_symbol_merror((y))) { \
162 lbm_gc_mark_phase(r); \
163 gc(); \
164 (y) = (x); \
165 if (lbm_is_symbol_merror((y))) { \
166 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
167 } \
168 /* continue executing statements below */ \
169 }
170
171#endif
172
173typedef struct {
174 eval_context_t *first;
175 eval_context_t *last;
176} eval_context_queue_t;
177
178#ifdef CLEAN_UP_CLOSURES
179static lbm_value clean_cl_env_symbol = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
180#endif
181
182static int gc(void);
183static void error_ctx(lbm_value);
184static void error_at_ctx(lbm_value err_val, lbm_value at);
185static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx);
186static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail);
187
188// The currently executing context.
189eval_context_t *ctx_running = NULL((void*)0);
190volatile bool_Bool lbm_system_sleeping = false0;
191
192static volatile bool_Bool gc_requested = false0;
193void lbm_request_gc(void) {
194 gc_requested = true1;
195}
196
197/*
198 On ChibiOs the CH_CFG_ST_FREQUENCY setting in chconf.h sets the
199 resolution of the timer used for sleep operations. If this is set
200 to 10KHz the resolution is 100us.
201
202 The CH_CFG_ST_TIMEDELTA specifies the minimum number of ticks that
203 can be safely specified in a timeout directive (wonder if that
204 means sleep-period). The timedelta is set to 2.
205
206 If I have understood these correctly it means that the minimum
207 sleep duration possible is 2 * 100us = 200us.
208*/
209
210#define EVAL_CPS_DEFAULT_STACK_SIZE256 256
211#define EVAL_CPS_MIN_SLEEP200 200
212#define EVAL_STEPS_QUOTA10 10
213
214static volatile uint32_t eval_steps_refill = EVAL_STEPS_QUOTA10;
215static uint32_t eval_steps_quota = EVAL_STEPS_QUOTA10;
216
217void lbm_set_eval_step_quota(uint32_t quota) {
218 eval_steps_refill = quota;
219}
220
221static uint32_t eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
222static volatile uint32_t eval_cps_next_state = EVAL_CPS_STATE_NONE0;
223static volatile uint32_t eval_cps_next_state_arg = 0;
224static volatile bool_Bool eval_cps_state_changed = false0;
225
226static void usleep_nonsense(uint32_t us) {
227 (void) us;
228}
229
230static bool_Bool dynamic_load_nonsense(const char *sym, const char **code) {
231 (void) sym;
232 (void) code;
233 return false0;
234}
235
236static uint32_t timestamp_nonsense(void) {
237 return 0;
238}
239
240static int printf_nonsense(const char *fmt, ...) {
241 (void) fmt;
242 return 0;
243}
244
245static void ctx_done_nonsense(eval_context_t *ctx) {
246 (void) ctx;
247}
248
249static void critical_nonsense(void) {
250 return;
251}
252
253static void (*critical_error_callback)(void) = critical_nonsense;
254static void (*usleep_callback)(uint32_t) = usleep_nonsense;
255static uint32_t (*timestamp_us_callback)(void) = timestamp_nonsense;
256static void (*ctx_done_callback)(eval_context_t *) = ctx_done_nonsense;
257static int (*printf_callback)(const char *, ...) = printf_nonsense;
258static bool_Bool (*dynamic_load_callback)(const char *, const char **) = dynamic_load_nonsense;
259
260void lbm_set_critical_error_callback(void (*fptr)(void)) {
261 if (fptr == NULL((void*)0)) critical_error_callback = critical_nonsense;
262 else critical_error_callback = fptr;
263}
264
265void lbm_set_usleep_callback(void (*fptr)(uint32_t)) {
266 if (fptr == NULL((void*)0)) usleep_callback = usleep_nonsense;
267 else usleep_callback = fptr;
268}
269
270void lbm_set_timestamp_us_callback(uint32_t (*fptr)(void)) {
271 if (fptr == NULL((void*)0)) timestamp_us_callback = timestamp_nonsense;
272 else timestamp_us_callback = fptr;
273}
274
275void lbm_set_ctx_done_callback(void (*fptr)(eval_context_t *)) {
276 if (fptr == NULL((void*)0)) ctx_done_callback = ctx_done_nonsense;
277 else ctx_done_callback = fptr;
278}
279
280void lbm_set_printf_callback(int (*fptr)(const char*, ...)){
281 if (fptr == NULL((void*)0)) printf_callback = printf_nonsense;
282 else printf_callback = fptr;
283}
284
285void lbm_set_dynamic_load_callback(bool_Bool (*fptr)(const char *, const char **)) {
286 if (fptr == NULL((void*)0)) dynamic_load_callback = dynamic_load_nonsense;
287 else dynamic_load_callback = fptr;
288}
289
290static volatile lbm_event_t *lbm_events = NULL((void*)0);
291static unsigned int lbm_events_head = 0;
292static unsigned int lbm_events_tail = 0;
293static unsigned int lbm_events_max = 0;
294static bool_Bool lbm_events_full = false0;
295static mutex_t lbm_events_mutex;
296static bool_Bool lbm_events_mutex_initialized = false0;
297static volatile lbm_cid lbm_event_handler_pid = -1;
298
299lbm_cid lbm_get_event_handler_pid(void) {
300 return lbm_event_handler_pid;
301}
302
303void lbm_set_event_handler_pid(lbm_cid pid) {
304 lbm_event_handler_pid = pid;
305}
306
307bool_Bool lbm_event_handler_exists(void) {
308 return(lbm_event_handler_pid > 0);
309}
310
311
312static bool_Bool event_internal(lbm_event_type_t event_type, lbm_uint parameter, lbm_uint buf_ptr, lbm_uint buf_len) {
313 bool_Bool r = false0;
314 if (lbm_events) {
315 mutex_lock(&lbm_events_mutex);
316 if (!lbm_events_full) {
317 lbm_event_t event;
318 event.type = event_type;
319 event.parameter = parameter;
320 event.buf_ptr = buf_ptr;
321 event.buf_len = buf_len;
322 lbm_events[lbm_events_head] = event;
323 lbm_events_head = (lbm_events_head + 1) % lbm_events_max;
324 lbm_events_full = lbm_events_head == lbm_events_tail;
325 r = true1;
326 }
327 mutex_unlock(&lbm_events_mutex);
328 }
329 return r;
330}
331
332bool_Bool lbm_event_define(lbm_value key, lbm_flat_value_t *fv) {
333 return event_internal(LBM_EVENT_DEFINE, key, (lbm_uint)fv->buf, fv->buf_size);
334}
335
336bool_Bool lbm_event_unboxed(lbm_value unboxed) {
337 lbm_uint t = lbm_type_of(unboxed);
338 if (t == LBM_TYPE_SYMBOL0x00000000u ||
339 t == LBM_TYPE_I0x00000008u ||
340 t == LBM_TYPE_U0x0000000Cu ||
341 t == LBM_TYPE_CHAR0x00000004u) {
342 if (lbm_event_handler_pid > 0) {
343 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)unboxed, 0);
344 }
345 }
346 return false0;
347}
348
349bool_Bool lbm_event(lbm_flat_value_t *fv) {
350 if (lbm_event_handler_pid > 0) {
351 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)fv->buf, fv->buf_size);
352 }
353 return false0;
354}
355
356static bool_Bool lbm_event_pop(lbm_event_t *event) {
357 mutex_lock(&lbm_events_mutex);
358 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
359 mutex_unlock(&lbm_events_mutex);
360 return false0;
361 }
362 *event = lbm_events[lbm_events_tail];
363 lbm_events_tail = (lbm_events_tail + 1) % lbm_events_max;
364 lbm_events_full = false0;
365 mutex_unlock(&lbm_events_mutex);
366 return true1;
367}
368
369bool_Bool lbm_event_queue_is_empty(void) {
370 mutex_lock(&lbm_events_mutex);
371 bool_Bool empty = false0;
372 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
373 empty = true1;
374 }
375 mutex_unlock(&lbm_events_mutex);
376 return empty;
377}
378
379static bool_Bool eval_running = false0;
380static volatile bool_Bool blocking_extension = false0;
381static mutex_t blocking_extension_mutex;
382static bool_Bool blocking_extension_mutex_initialized = false0;
383static lbm_uint blocking_extension_timeout_us = 0;
384static bool_Bool blocking_extension_timeout = false0;
385
386static uint32_t is_atomic = 0;
387
388/* Process queues */
389static eval_context_queue_t blocked = {NULL((void*)0), NULL((void*)0)};
390static eval_context_queue_t queue = {NULL((void*)0), NULL((void*)0)};
391
392/* one mutex for all queue operations */
393mutex_t qmutex;
394bool_Bool qmutex_initialized = false0;
395
396
397// MODES
398static volatile bool_Bool lbm_verbose = false0;
399
400void lbm_toggle_verbose(void) {
401 lbm_verbose = !lbm_verbose;
402}
403
404void lbm_set_verbose(bool_Bool verbose) {
405 lbm_verbose = verbose;
406}
407
408lbm_cid lbm_get_current_cid(void) {
409 if (ctx_running)
410 return ctx_running->id;
411 else
412 return -1;
413}
414
415eval_context_t *lbm_get_current_context(void) {
416 return ctx_running;
417}
418
419/****************************************************/
420/* Utilities used locally in this file */
421
422static lbm_value cons_with_gc(lbm_value head, lbm_value tail, lbm_value remember) {
423#ifdef LBM_ALWAYS_GC
424 lbm_value roots[3] = {head, tail, remember};
425 lbm_gc_mark_roots(roots, 3);
426 gc();
427 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
428 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
429 if (lbm_is_symbol_merror(res)) {
430 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
431 }
432 return res;
433#else
434 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
435 if (lbm_is_symbol_merror(res)) {
436 lbm_value roots[3] = {head, tail, remember};
437 lbm_gc_mark_roots(roots,3);
438 gc();
439 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
440 if (lbm_is_symbol_merror(res)) {
441 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
442 }
443 }
444 return res;
445#endif
446}
447
448static lbm_uint *get_stack_ptr(eval_context_t *ctx, unsigned int n) {
449 if (n <= ctx->K.sp) {
450 lbm_uint index = ctx->K.sp - n;
451 return &ctx->K.data[index];
452 }
453 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
454 return 0; // dead code cannot be reached, but C compiler doesn't realise.
455}
456
457// pop_stack_ptr is safe when no GC is performed and
458// the values of the stack will be dropped.
459static lbm_uint *pop_stack_ptr(eval_context_t *ctx, unsigned int n) {
460 if (n <= ctx->K.sp) {
461 ctx->K.sp -= n;
462 return &ctx->K.data[ctx->K.sp];
463 }
464 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
465 return 0; // dead code cannot be reached, but C compiler doesn't realise.
466}
467
468static inline lbm_uint *stack_reserve(eval_context_t *ctx, unsigned int n) {
469 if (ctx->K.sp + n < ctx->K.size) {
470 lbm_uint *ptr = &ctx->K.data[ctx->K.sp];
471 ctx->K.sp += n;
472 return ptr;
473 }
474 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
475 return 0; // dead code cannot be reached, but C compiler doesn't realise.
476}
477
478static void handle_flash_status(lbm_flash_status s) {
479 if ( s == LBM_FLASH_FULL) {
480 lbm_set_error_reason((char*)lbm_error_str_flash_full);
481 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
482 }
483 if (s == LBM_FLASH_WRITE_ERROR) {
484 lbm_set_error_reason((char*)lbm_error_str_flash_error);
485 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
486 }
487}
488
489static void lift_array_flash(lbm_value flash_cell, bool_Bool bytearray, char *data, lbm_uint num_elt) {
490
491 lbm_array_header_t flash_array_header;
492 flash_array_header.size = num_elt;
493 flash_array_header.data = (lbm_uint*)data;
494 lbm_uint flash_array_header_ptr;
495 handle_flash_status(lbm_write_const_raw((lbm_uint*)&flash_array_header,
496 sizeof(lbm_array_header_t) / sizeof(lbm_uint),
497 &flash_array_header_ptr));
498 handle_flash_status(write_const_car(flash_cell, flash_array_header_ptr));
499 lbm_uint t = bytearray ? ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u) : ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u);
500 handle_flash_status(write_const_cdr(flash_cell, t));
501}
502
503static void get_car_and_cdr(lbm_value a, lbm_value *a_car, lbm_value *a_cdr) {
504 if (lbm_is_ptr(a)) {
505 lbm_cons_t *cell = lbm_ref_cell(a);
506 *a_car = cell->car;
507 *a_cdr = cell->cdr;
508 } else if (lbm_is_symbol_nil(a)) {
509 *a_car = *a_cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
510 } else {
511 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
512 }
513}
514
515/* car cdr caar cadr replacements that are evaluator safe. */
516static lbm_value get_car(lbm_value a) {
517 if (lbm_is_ptr(a)) {
6
←
Assuming the condition is false
→
7
←
Taking false branch
→
518 lbm_cons_t *cell = lbm_ref_cell(a);
519 return cell->car;
520 } else if (lbm_is_symbol_nil(a)) {
8
←
Calling 'lbm_is_symbol_nil'
→
11
←
Returning from 'lbm_is_symbol_nil'
→
12
←
Taking true branch
→
521 return a;
13
←
Returning zero (loaded from 'a')
→
522 }
523 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
524 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
525}
526
527static lbm_value get_cdr(lbm_value a) {
528 if (lbm_is_ptr(a)) {
529 lbm_cons_t *cell = lbm_ref_cell(a);
530 return cell->cdr;
531 } else if (lbm_is_symbol_nil(a)) {
532 return a;
533 }
534 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
535 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
536}
537
538static lbm_value get_cadr(lbm_value a) {
539 if (lbm_is_ptr(a)) {
540 lbm_cons_t *cell = lbm_ref_cell(a);
541 lbm_value tmp = cell->cdr;
542 if (lbm_is_ptr(tmp)) {
543 return lbm_ref_cell(tmp)->car;
544 } else if (lbm_is_symbol_nil(tmp)) {
545 return tmp;
546 }
547 } else if (lbm_is_symbol_nil(a)) {
548 return a;
549 }
550 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
551 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
552}
553
554static lbm_value allocate_closure(lbm_value params, lbm_value body, lbm_value env) {
555
556#ifdef LBM_ALWAYS_GC
557 gc();
558 if (lbm_heap_num_free() < 4) {
559 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
560 }
561#else
562 if (lbm_heap_num_free() < 4) {
563 gc();
564 if (lbm_heap_num_free() < 4) {
565 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
566 }
567 }
568#endif
569 // The freelist will always contain just plain heap-cells.
570 // So dec_ptr is sufficient.
571 lbm_value res = lbm_heap_state.freelist;
572 if (lbm_type_of(res) == LBM_TYPE_CONS0x10000000u) {
573 lbm_cons_t *heap = lbm_heap_state.heap;
574 lbm_uint ix = lbm_dec_ptr(res);
575 heap[ix].car = ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u);
576 ix = lbm_dec_ptr(heap[ix].cdr);
577 heap[ix].car = params;
578 ix = lbm_dec_ptr(heap[ix].cdr);
579 heap[ix].car = body;
580 ix = lbm_dec_ptr(heap[ix].cdr);
581 heap[ix].car = env;
582 lbm_heap_state.freelist = heap[ix].cdr;
583 heap[ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
584 lbm_heap_state.num_alloc+=4;
585 } else {
586 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
587 }
588 return res;
589}
590
591// Allocate a binding and attach it to a list (if so desired)
592static lbm_value allocate_binding(lbm_value key, lbm_value val, lbm_value the_cdr) {
593 if (lbm_heap_num_free() < 2) {
594 gc();
595 if (lbm_heap_num_free() < 2) {
596 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
597 }
598 }
599 lbm_cons_t* heap = lbm_heap_state.heap;
600 lbm_value binding_cell = lbm_heap_state.freelist;
601 lbm_uint binding_cell_ix = lbm_dec_ptr(binding_cell);
602 lbm_value list_cell = heap[binding_cell_ix].cdr;
603 lbm_uint list_cell_ix = lbm_dec_ptr(list_cell);
604 lbm_heap_state.freelist = heap[list_cell_ix].cdr;
605 lbm_heap_state.num_alloc += 2;
606 heap[binding_cell_ix].car = key;
607 heap[binding_cell_ix].cdr = val;
608 heap[list_cell_ix].car = binding_cell;
609 heap[list_cell_ix].cdr = the_cdr;
610 return list_cell;
611}
612
613#define CLO_PARAMS0 0
614#define CLO_BODY1 1
615#define CLO_ENV2 2
616#define LOOP_BINDS0 0
617#define LOOP_COND1 1
618#define LOOP_BODY2 2
619
620// (a b c) -> [a b c]
621static lbm_value extract_n(lbm_value curr, lbm_value *res, unsigned int n) {
622 for (unsigned int i = 0; i < n; i ++) {
623 if (lbm_is_ptr(curr)) {
624 lbm_cons_t *cell = lbm_ref_cell(curr);
625 res[i] = cell->car;
626 curr = cell->cdr;
627 } else {
628 res[i] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
629 }
630 }
631 return curr; // Rest of list is returned here.
632}
633
634static void call_fundamental(lbm_uint fundamental, lbm_value *args, lbm_uint arg_count, eval_context_t *ctx) {
635 lbm_value res;
636 res = fundamental_table[fundamental](args, arg_count, ctx);
637 if (lbm_is_error(res)) {
638 if (lbm_is_symbol_merror(res)) {
639 gc();
640 res = fundamental_table[fundamental](args, arg_count, ctx);
641 }
642 if (lbm_is_error(res)) {
643 error_at_ctx(res, lbm_enc_sym(FUNDAMENTAL_SYMBOLS_START0x20000 | fundamental));
644 }
645 }
646 lbm_stack_drop(&ctx->K, arg_count+1);
647 ctx->app_cont = true1;
648 ctx->r = res;
649}
650
651// block_current_ctx blocks a context until it is
652// woken up externally or a timeout period of time passes.
653static void block_current_ctx(uint32_t state, lbm_uint sleep_us, bool_Bool do_cont) {
654 ctx_running->timestamp = timestamp_us_callback();
655 ctx_running->sleep_us = sleep_us;
656 ctx_running->state = state;
657 ctx_running->app_cont = do_cont;
658 enqueue_ctx(&blocked, ctx_running);
659 ctx_running = NULL((void*)0);
660}
661
662lbm_flash_status lbm_write_const_array_padded(uint8_t *data, lbm_uint n, lbm_uint *res) {
663 lbm_uint full_words = n / sizeof(lbm_uint);
664 lbm_uint n_mod = n % sizeof(lbm_uint);
665
666 if (n_mod == 0) { // perfect fit.
667 return lbm_write_const_raw((lbm_uint*)data, full_words, res);
668 } else {
669 lbm_uint last_word = 0;
670 memcpy(&last_word, &data[full_words * sizeof(lbm_uint)], n_mod);
671 if (full_words >= 1) {
672 lbm_flash_status s = lbm_write_const_raw((lbm_uint*)data, full_words, res);
673 if ( s == LBM_FLASH_WRITE_OK) {
674 lbm_uint dummy;
675 s = lbm_write_const_raw(&last_word, 1, &dummy);
676 }
677 return s;
678 } else {
679 return lbm_write_const_raw(&last_word, 1, res);
680 }
681 }
682}
683
684/****************************************************/
685/* Error message creation */
686
687#define ERROR_MESSAGE_BUFFER_SIZE_BYTES256 256
688
689void print_environments(char *buf, unsigned int size) {
690
691 lbm_value curr_l = ctx_running->curr_env;
692 printf_callback("\tCurrent local environment:\n");
693 while (lbm_type_of(curr_l) == LBM_TYPE_CONS0x10000000u) {
694 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_l));
695 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_l)));
696 printf_callback("\t%s = %s\n", buf, buf+(size/2));
697 curr_l = lbm_cdr(curr_l);
698 }
699 printf_callback("\n\n");
700 printf_callback("\tCurrent global environment:\n");
701 lbm_value *glob_env = lbm_get_global_env();
702
703 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
704 lbm_value curr_g = glob_env[i];;
705 while (lbm_type_of(curr_g) == LBM_TYPE_CONS0x10000000u) {
706
707 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_g));
708 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_g)));
709 printf_callback("\t%s = %s\n", buf, buf+(size/2));
710 curr_g = lbm_cdr(curr_g);
711 }
712 }
713}
714
715void print_error_message(lbm_value error, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int col, lbm_int row0, lbm_int row1) {
716 if (!printf_callback) return;
717
718 /* try to allocate a lbm_print_value buffer on the lbm_memory */
719 char *buf = lbm_malloc_reserve(ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
720 if (!buf) {
721 printf_callback("Error: Not enough free memory to create a human readable error message\n");
722 return;
723 }
724
725 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, error);
726 printf_callback( "*** Error: %s\n", buf);
727 if (has_at) {
728 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, at);
729 printf_callback("*** In: %s\n",buf);
730 if (lbm_error_has_suspect) {
731 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, lbm_error_suspect);
732 lbm_error_has_suspect = false0;
733 printf_callback("*** At: %s\n", buf);
734 } else {
735 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
736 printf_callback("*** After: %s\n",buf);
737 }
738 } else {
739 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
740 printf_callback("*** Near: %s\n",buf);
741 }
742
743 printf_callback("\n");
744
745 if (lbm_is_symbol(error) &&
746 error == ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u)) {
747 printf_callback("*** Line: %u\n", row);
748 printf_callback("*** Column: %u\n", col);
749 } else if (row0 != -1 || row1 != -1 ) {
750 printf_callback("*** Between rows: (-1 unknown) \n");
751 printf_callback("*** Start: %d\n", (int32_t)row0);
752 printf_callback("*** End: %d\n", (int32_t)row1);
753 }
754
755 printf_callback("\n");
756
757 if (ctx_running->error_reason) {
758 printf_callback("Reason:\n %s\n\n", ctx_running->error_reason);
759 }
760 if (lbm_verbose) {
761 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
762 printf_callback(" In context: %d\n", ctx_running->id);
763 printf_callback(" Current intermediate result: %s\n\n", buf);
764
765 print_environments(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
766 printf_callback("\n\n");
767
768 printf_callback(" Stack:\n");
769 for (unsigned int i = 0; i < ctx_running->K.sp; i ++) {
770 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->K.data[i]);
771 printf_callback(" %s\n", buf);
772 }
773 }
774 lbm_free(buf);
775}
776
777/****************************************************/
778/* Tokenizing and parsing */
779
780bool_Bool create_string_channel(char *str, lbm_value *res) {
781
782 lbm_char_channel_t *chan = NULL((void*)0);
783 lbm_string_channel_state_t *st = NULL((void*)0);
784
785 st = (lbm_string_channel_state_t*)lbm_memory_allocate(sizeof(lbm_string_channel_state_t) / sizeof(lbm_uint) +1);
786 if (st == NULL((void*)0)) {
787 return false0;
788 }
789 chan = (lbm_char_channel_t*)lbm_memory_allocate(sizeof(lbm_char_channel_t) / sizeof(lbm_uint) + 1);
790 if (chan == NULL((void*)0)) {
791 lbm_memory_free((lbm_uint*)st);
792 return false0;
793 }
794
795 lbm_create_string_char_channel(st, chan, str);
796 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
797 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
798 lbm_memory_free((lbm_uint*)st);
799 lbm_memory_free((lbm_uint*)chan);
800 return false0;
801 }
802
803 *res = cell;
804 return true1;
805}
806
807bool_Bool lift_char_channel(lbm_char_channel_t *chan , lbm_value *res) {
808 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
809 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
810 return false0;
811 }
812 *res = cell;
813 return true1;
814}
815
816
817/****************************************************/
818/* Queue functions */
819
820static void queue_iterator_nm(eval_context_queue_t *q, ctx_fun f, void *arg1, void *arg2) {
821 eval_context_t *curr;
822 curr = q->first;
823
824 while (curr != NULL((void*)0)) {
825 f(curr, arg1, arg2);
826 curr = curr->next;
827 }
828}
829
830void lbm_running_iterator(ctx_fun f, void *arg1, void *arg2){
831 mutex_lock(&qmutex);
832 queue_iterator_nm(&queue, f, arg1, arg2);
833 mutex_unlock(&qmutex);
834}
835
836void lbm_blocked_iterator(ctx_fun f, void *arg1, void *arg2){
837 mutex_lock(&qmutex);
838 queue_iterator_nm(&blocked, f, arg1, arg2);
839 mutex_unlock(&qmutex);
840}
841
842static void enqueue_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
843 if (q->last == NULL((void*)0)) {
844 ctx->prev = NULL((void*)0);
845 ctx->next = NULL((void*)0);
846 q->first = ctx;
847 q->last = ctx;
848 } else {
849 ctx->prev = q->last;
850 ctx->next = NULL((void*)0);
851 q->last->next = ctx;
852 q->last = ctx;
853 }
854}
855
856static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx) {
857 mutex_lock(&qmutex);
858 enqueue_ctx_nm(q,ctx);
859 mutex_unlock(&qmutex);
860}
861
862static eval_context_t *lookup_ctx_nm(eval_context_queue_t *q, lbm_cid cid) {
863 eval_context_t *curr;
864 curr = q->first;
865 while (curr != NULL((void*)0)) {
866 if (curr->id == cid) {
867 return curr;
868 }
869 curr = curr->next;
870 }
871 return NULL((void*)0);
872}
873
874static bool_Bool drop_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
875
876 bool_Bool res = false0;
877 if (q->first == NULL((void*)0) || q->last == NULL((void*)0)) {
878 if (!(q->last == NULL((void*)0) && q->first == NULL((void*)0))) {
879 /* error state that should not happen */
880 return res;
881 }
882 /* Queue is empty */
883 return res;
884 }
885
886 eval_context_t *curr = q->first;
887 while (curr) {
888 if (curr->id == ctx->id) {
889 res = true1;
890 eval_context_t *tmp = curr->next;
891 if (curr->prev == NULL((void*)0)) {
892 if (curr->next == NULL((void*)0)) {
893 q->last = NULL((void*)0);
894 q->first = NULL((void*)0);
895 } else {
896 q->first = tmp;
897 tmp->prev = NULL((void*)0);
898 }
899 } else { /* curr->prev != NULL */
900 if (curr->next == NULL((void*)0)) {
901 q->last = curr->prev;
902 q->last->next = NULL((void*)0);
903 } else {
904 curr->prev->next = tmp;
905 tmp->prev = curr->prev;
906 }
907 }
908 break;
909 }
910 curr = curr->next;
911 }
912 return res;
913}
914
915/* End execution of the running context. */
916static void finish_ctx(void) {
917
918 if (!ctx_running) {
919 return;
920 }
921 /* Drop the continuation stack immediately to free up lbm_memory */
922 lbm_stack_free(&ctx_running->K);
923 ctx_done_callback(ctx_running);
924 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->name)) {
925 lbm_free(ctx_running->name);
926 }
927 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->error_reason)) {
928 lbm_memory_free((lbm_uint*)ctx_running->error_reason);
929 }
930 lbm_memory_free((lbm_uint*)ctx_running->mailbox);
931 lbm_memory_free((lbm_uint*)ctx_running);
932 ctx_running = NULL((void*)0);
933}
934
935static void context_exists(eval_context_t *ctx, void *cid, void *b) {
936 if (ctx->id == *(lbm_cid*)cid) {
937 *(bool_Bool*)b = true1;
938 }
939}
940
941bool_Bool lbm_wait_ctx(lbm_cid cid, lbm_uint timeout_ms) {
942
943 bool_Bool exists;
944 uint32_t i = 0;
945
946 do {
947 exists = false0;
948 lbm_blocked_iterator(context_exists, &cid, &exists);
949 lbm_running_iterator(context_exists, &cid, &exists);
950
951 if (ctx_running &&
952 ctx_running->id == cid) {
953 exists = true1;
954 }
955
956 if (exists) {
957 if (usleep_callback) {
958 usleep_callback(1000);
959 }
960 if (timeout_ms > 0) i ++;
961 }
962 } while (exists && i < timeout_ms);
963
964 if (exists) return false0;
965 return true1;
966}
967
968void lbm_set_error_suspect(lbm_value suspect) {
969 lbm_error_suspect = suspect;
970 lbm_error_has_suspect = true1;
971}
972
973void lbm_set_error_reason(char *error_str) {
974 if (ctx_running != NULL((void*)0)) {
975 ctx_running->error_reason = error_str;
976 }
977}
978
979// Not possible to CONS_WITH_GC in error_ctx_base (potential loop)
980static void error_ctx_base(lbm_value err_val, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int column) {
981
982 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
983 if (lbm_heap_num_free() < 3) {
984 gc();
985 }
986
987 if (lbm_heap_num_free() >= 3) {
988 lbm_value msg = lbm_cons(err_val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
989 msg = lbm_cons(lbm_enc_i(ctx_running->id), msg);
990 msg = lbm_cons(ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u), msg);
991 if (!lbm_is_symbol_merror(msg)) {
992 lbm_find_receiver_and_send(ctx_running->parent, msg);
993 goto error_ctx_base_done;
994 }
995 }
996 }
997 if ((ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10) &&
998 (err_val != ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u))) {
999 lbm_uint v;
1000 while (ctx_running->K.sp > 0) {
1001 lbm_pop(&ctx_running->K, &v);
1002 if (v == EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u)) {
1003 lbm_value *sptr = get_stack_ptr(ctx_running, 2);
1004 lbm_set_car(sptr[0], ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
1005 stack_reserve(ctx_running, 1)[0] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1006 ctx_running->app_cont = true1;
1007 ctx_running->r = err_val;
1008 longjmp(error_jmp_buf, 1);
1009 }
1010 }
1011 err_val = ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u);
1012 }
1013 print_error_message(err_val,
1014 has_at,
1015 at,
1016 row,
1017 column,
1018 ctx_running->row0,
1019 ctx_running->row1);
1020 error_ctx_base_done:
1021 ctx_running->r = err_val;
1022 finish_ctx();
1023 longjmp(error_jmp_buf, 1);
1024}
1025
1026static void error_at_ctx(lbm_value err_val, lbm_value at) {
1027 error_ctx_base(err_val, true1, at, 0, 0);
1028}
1029
1030static void error_ctx(lbm_value err_val) {
1031 error_ctx_base(err_val, false0, 0, 0, 0);
1032}
1033
1034static void read_error_ctx(unsigned int row, unsigned int column) {
1035 error_ctx_base(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u), false0, 0, row, column);
1036}
1037
1038void lbm_critical_error(void) {
1039 longjmp(critical_error_jmp_buf, 1);
1040}
1041
1042// successfully finish a context
1043static void ok_ctx(void) {
1044 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
1045 lbm_value msg;
1046 WITH_GC(msg, lbm_heap_allocate_list_init(3,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1047 ENC_SYM_EXIT_OK,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1048 lbm_enc_i(ctx_running->id),(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1049 ctx_running->r))(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
1050 lbm_find_receiver_and_send(ctx_running->parent, msg);
1051 }
1052 finish_ctx();
1053}
1054
1055static eval_context_t *dequeue_ctx_nm(eval_context_queue_t *q) {
1056 if (q->last == NULL((void*)0)) {
1057 return NULL((void*)0);
1058 }
1059 // q->first should only be NULL if q->last is.
1060 eval_context_t *res = q->first;
1061
1062 if (q->first == q->last) { // One thing in queue
1063 q->first = NULL((void*)0);
1064 q->last = NULL((void*)0);
1065 } else {
1066 q->first = q->first->next;
1067 q->first->prev = NULL((void*)0);
1068 }
1069 res->prev = NULL((void*)0);
1070 res->next = NULL((void*)0);
1071 return res;
1072}
1073
1074static void wake_up_ctxs_nm(void) {
1075 lbm_uint t_now;
1076
1077 if (timestamp_us_callback) {
1078 t_now = timestamp_us_callback();
1079 } else {
1080 t_now = 0;
1081 }
1082
1083 eval_context_queue_t *q = &blocked;
1084 eval_context_t *curr = q->first;
1085
1086 while (curr != NULL((void*)0)) {
1087 lbm_uint t_diff;
1088 eval_context_t *next = curr->next;
1089 if (curr->state != LBM_THREAD_STATE_BLOCKED(uint32_t)1) {
1090 if ( curr->timestamp > t_now) {
1091 /* There was an overflow on the counter */
1092#ifndef LBM64
1093 t_diff = (0xFFFFFFFF - curr->timestamp) + t_now;
1094#else
1095 t_diff = (0xFFFFFFFFFFFFFFFF - curr->timestamp) + t_now;
1096#endif
1097 } else {
1098 t_diff = t_now - curr->timestamp;
1099 }
1100
1101 if (t_diff >= curr->sleep_us) {
1102 eval_context_t *wake_ctx = curr;
1103 if (curr == q->last) {
1104 if (curr->prev) {
1105 q->last = curr->prev;
1106 q->last->next = NULL((void*)0);
1107 } else {
1108 q->first = NULL((void*)0);
1109 q->last = NULL((void*)0);
1110 }
1111 } else if (curr->prev == NULL((void*)0)) {
1112 q->first = curr->next;
1113 q->first->prev = NULL((void*)0);
1114 } else {
1115 curr->prev->next = curr->next;
1116 if (curr->next) {
1117 curr->next->prev = curr->prev;
1118 }
1119 }
1120 wake_ctx->next = NULL((void*)0);
1121 wake_ctx->prev = NULL((void*)0);
1122 if (curr->state == LBM_THREAD_STATE_TIMEOUT(uint32_t)2) {
1123 mailbox_add_mail(wake_ctx, ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u));
1124 wake_ctx->r = ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u);
1125 }
1126 wake_ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1127 enqueue_ctx_nm(&queue, wake_ctx);
1128 }
1129 }
1130 curr = next;
1131 }
1132}
1133
1134static void yield_ctx(lbm_uint sleep_us) {
1135 if (timestamp_us_callback) {
1136 ctx_running->timestamp = timestamp_us_callback();
1137 ctx_running->sleep_us = sleep_us;
1138 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1139 } else {
1140 ctx_running->timestamp = 0;
1141 ctx_running->sleep_us = 0;
1142 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1143 }
1144 ctx_running->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1145 ctx_running->app_cont = true1;
1146 enqueue_ctx(&blocked,ctx_running);
1147 ctx_running = NULL((void*)0);
1148}
1149
1150static lbm_cid lbm_create_ctx_parent(lbm_value program, lbm_value env, lbm_uint stack_size, lbm_cid parent, uint32_t context_flags, char *name) {
1151
1152 if (!lbm_is_cons(program)) return -1;
1153
1154 eval_context_t *ctx = NULL((void*)0);
1155
1156 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1157 if (ctx == NULL((void*)0)) {
1158 lbm_uint roots[2] = {program, env};
1159 lbm_gc_mark_roots(roots, 2);
1160 gc();
1161 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1162 }
1163 if (ctx == NULL((void*)0)) return -1;
1164
1165 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1166 lbm_uint roots[2] = {program, env};
1167 lbm_gc_mark_roots(roots, 2);
1168 gc();
1169 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1170 lbm_memory_free((lbm_uint*)ctx);
1171 return -1;
1172 }
1173 }
1174
1175 lbm_value *mailbox = NULL((void*)0);
1176 mailbox = (lbm_value*)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1177 if (mailbox == NULL((void*)0)) {
1178 lbm_value roots[2] = {program, env};
1179 lbm_gc_mark_roots(roots,2);
1180 gc();
1181 mailbox = (lbm_value *)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1182 }
1183 if (mailbox == NULL((void*)0)) {
1184 lbm_stack_free(&ctx->K);
1185 lbm_memory_free((lbm_uint*)ctx);
1186 return -1;
1187 }
1188
1189 // TODO: Limit names to 19 chars + 1 char for 0? (or something similar).
1190 if (name) {
1191 lbm_uint name_len = strlen(name) + 1;
1192 ctx->name = lbm_malloc(strlen(name) + 1);
1193 if (ctx->name == NULL((void*)0)) {
1194 lbm_value roots[2] = {program, env};
1195 lbm_gc_mark_roots(roots, 2);
1196 gc();
1197 ctx->name = lbm_malloc(strlen(name) + 1);
1198 }
1199 if (ctx->name == NULL((void*)0)) {
1200 lbm_stack_free(&ctx->K);
1201 lbm_memory_free((lbm_uint*)mailbox);
1202 lbm_memory_free((lbm_uint*)ctx);
1203 return -1;
1204 }
1205 memcpy(ctx->name, name, name_len+1);
1206 } else {
1207 ctx->name = NULL((void*)0);
1208 }
1209
1210 lbm_int cid = lbm_memory_address_to_ix((lbm_uint*)ctx);
1211
1212 ctx->program = lbm_cdr(program);
1213 ctx->curr_exp = lbm_car(program);
1214 ctx->curr_env = env;
1215 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1216 ctx->error_reason = NULL((void*)0);
1217 ctx->mailbox = mailbox;
1218 ctx->mailbox_size = EVAL_CPS_DEFAULT_MAILBOX_SIZE10;
1219 ctx->flags = context_flags;
1220 ctx->num_mail = 0;
1221 ctx->app_cont = false0;
1222 ctx->timestamp = 0;
1223 ctx->sleep_us = 0;
1224 ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1225 ctx->prev = NULL((void*)0);
1226 ctx->next = NULL((void*)0);
1227
1228 ctx->row0 = -1;
1229 ctx->row1 = -1;
1230
1231 ctx->id = cid;
1232 ctx->parent = parent;
1233
1234 if (!lbm_push(&ctx->K, DONE(((0) << 2) | 0xF8000001u))) {
1235 lbm_memory_free((lbm_uint*)ctx->mailbox);
1236 lbm_stack_free(&ctx->K);
1237 lbm_memory_free((lbm_uint*)ctx);
1238 return -1;
1239 }
1240
1241 enqueue_ctx(&queue,ctx);
1242
1243 return ctx->id;
1244}
1245
1246lbm_cid lbm_create_ctx(lbm_value program, lbm_value env, lbm_uint stack_size, char *name) {
1247 // Creates a parentless context.
1248 return lbm_create_ctx_parent(program,
1249 env,
1250 stack_size,
1251 -1,
1252 EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00,
1253 name);
1254}
1255
1256bool_Bool lbm_mailbox_change_size(eval_context_t *ctx, lbm_uint new_size) {
1257
1258 lbm_value *mailbox = NULL((void*)0);
1259 mailbox = (lbm_value*)lbm_memory_allocate(new_size);
1260 if (mailbox == NULL((void*)0)) {
1261 gc();
1262 mailbox = (lbm_value *)lbm_memory_allocate(new_size);
1263 }
1264 if (mailbox == NULL((void*)0)) {
1265 return false0;
1266 }
1267
1268 for (lbm_uint i = 0; i < ctx->num_mail; i ++ ) {
1269 mailbox[i] = ctx->mailbox[i];
1270 }
1271 lbm_memory_free(ctx->mailbox);
1272 ctx->mailbox = mailbox;
1273 ctx->mailbox_size = (uint32_t)new_size;
1274 return true1;
1275}
1276
1277static void mailbox_remove_mail(eval_context_t *ctx, lbm_uint ix) {
1278
1279 for (lbm_uint i = ix; i < ctx->num_mail-1; i ++) {
1280 ctx->mailbox[i] = ctx->mailbox[i+1];
1281 }
1282 ctx->num_mail --;
1283}
1284
1285static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail) {
1286
1287 if (ctx->num_mail >= ctx->mailbox_size) {
1288 mailbox_remove_mail(ctx, 0);
1289 }
1290
1291 ctx->mailbox[ctx->num_mail] = mail;
1292 ctx->num_mail ++;
1293 return true1;
1294}
1295
1296/* Advance execution to the next expression in the program */
1297static void advance_ctx(eval_context_t *ctx) {
1298 if (lbm_is_cons(ctx->program)) {
1299 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);;
1300 get_car_and_cdr(ctx->program, &ctx->curr_exp, &ctx->program);
1301 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1302 } else {
1303 if (ctx_running == ctx) { // This should always be the case because of odd historical reasons.
1304 ok_ctx();
1305 }
1306 }
1307}
1308
1309bool_Bool lbm_unblock_ctx(lbm_cid cid, lbm_flat_value_t *fv) {
1310 return event_internal(LBM_EVENT_UNBLOCK_CTX, (lbm_uint)cid, (lbm_uint)fv->buf, fv->buf_size);
1311}
1312
1313bool_Bool lbm_unblock_ctx_r(lbm_cid cid) {
1314 mutex_lock(&blocking_extension_mutex);
1315 bool_Bool r = false0;
1316 eval_context_t *found = NULL((void*)0);
1317 mutex_lock(&qmutex);
1318 found = lookup_ctx_nm(&blocked, cid);
1319 if (found) {
1320 drop_ctx_nm(&blocked,found);
1321 enqueue_ctx_nm(&queue,found);
1322 r = true1;
1323 }
1324 mutex_unlock(&qmutex);
1325 mutex_unlock(&blocking_extension_mutex);
1326 return r;
1327}
1328
1329// unblock unboxed is also safe for rmbr:ed things.
1330bool_Bool lbm_unblock_ctx_unboxed(lbm_cid cid, lbm_value unboxed) {
1331 mutex_lock(&blocking_extension_mutex);
1332 bool_Bool r = false0;
1333 eval_context_t *found = NULL((void*)0);
1334 mutex_lock(&qmutex);
1335 found = lookup_ctx_nm(&blocked, cid);
1336 if (found) {
1337 drop_ctx_nm(&blocked,found);
1338 found->r = unboxed;
1339 if (lbm_is_error(unboxed)) {
1340 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
1341 found->app_cont = true1;
1342 }
1343 enqueue_ctx_nm(&queue,found);
1344 r = true1;
1345 }
1346 mutex_unlock(&qmutex);
1347 mutex_unlock(&blocking_extension_mutex);
1348 return r;
1349}
1350
1351static bool_Bool lbm_block_ctx_base(bool_Bool timeout, float t_s) {
1352 mutex_lock(&blocking_extension_mutex);
1353 blocking_extension = true1;
1354 if (timeout) {
1355 blocking_extension_timeout_us = S_TO_US(t_s)(lbm_uint)((t_s) * 1000000);
1356 blocking_extension_timeout = true1;
1357 } else {
1358 blocking_extension_timeout = false0;
1359 }
1360 return true1;
1361}
1362
1363void lbm_block_ctx_from_extension_timeout(float s) {
1364 lbm_block_ctx_base(true1, s);
1365}
1366
1367void lbm_block_ctx_from_extension(void) {
1368 lbm_block_ctx_base(false0, 0);
1369}
1370
1371// todo: May need to pop rmbrs from stack, if present.
1372// Suspect that the letting the discard cont run is really not a problem.
1373// Either way will be quite confusing what happens to allocated things when undoing block.
1374void lbm_undo_block_ctx_from_extension(void) {
1375 blocking_extension = false0;
1376 blocking_extension_timeout_us = 0;
1377 blocking_extension_timeout = false0;
1378 mutex_unlock(&blocking_extension_mutex);
1379}
1380
1381lbm_value lbm_find_receiver_and_send(lbm_cid cid, lbm_value msg) {
1382 mutex_lock(&qmutex);
1383 eval_context_t *found = NULL((void*)0);
1384 bool_Bool found_blocked = false0;
1385
1386 found = lookup_ctx_nm(&blocked, cid);
1387 if (found) found_blocked = true1;
1388
1389 if (found == NULL((void*)0)) {
1390 found = lookup_ctx_nm(&queue, cid);
1391 }
1392
1393 if (found) {
1394 if (!mailbox_add_mail(found, msg)) {
1395 mutex_unlock(&qmutex);
1396 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1397 }
1398
1399 if (found_blocked){
1400 drop_ctx_nm(&blocked,found);
1401 enqueue_ctx_nm(&queue,found);
1402 }
1403 mutex_unlock(&qmutex);
1404 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1405 }
1406
1407 /* check the current context */
1408 if (ctx_running && ctx_running->id == cid) {
1409 if (!mailbox_add_mail(ctx_running, msg)) {
1410 mutex_unlock(&qmutex);
1411 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1412 }
1413 mutex_unlock(&qmutex);
1414 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1415 }
1416 mutex_unlock(&qmutex);
1417 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1418}
1419
1420/* Pattern matching is currently implemented as a recursive
1421 function and make use of stack relative to the size of
1422 expressions that are being matched. */
1423static bool_Bool match(lbm_value p, lbm_value e, lbm_value *env, bool_Bool *gc) {
1424
1425 lbm_value binding;
1426
1427 if (lbm_is_match_binder(p)) {
1428 lbm_value var = get_cadr(p);
1429 lbm_value bindertype = get_car(p);
1430
1431 if (!lbm_is_symbol(var)) return false0;
1432
1433 switch (bindertype) {
1434 case ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u):
1435 if ( var == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) {
1436 return true1;
1437 }
1438 break;
1439 default: /* this should be an error case */
1440 return false0;
1441 }
1442 binding = lbm_cons(var, e);
1443 if ( lbm_type_of(binding) == LBM_TYPE_SYMBOL0x00000000u ) {
1444 *gc = true1;
1445 return false0;
1446 }
1447 *env = lbm_cons(binding, *env);
1448 if ( lbm_type_of(*env) == LBM_TYPE_SYMBOL0x00000000u ) {
1449 *gc = true1;
1450 return false0;
1451 }
1452 return true1;
1453 }
1454
1455 if (lbm_is_symbol(p)) {
1456 if (p == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return true1;
1457 return (p == e);
1458 }
1459 if (lbm_is_cons(p) &&
1460 lbm_is_cons(e) ) {
1461
1462 lbm_value headp, tailp;
1463 lbm_value heade, taile;
1464 get_car_and_cdr(p, &headp, &tailp);
1465 get_car_and_cdr(e, &heade, &taile); // Static analysis warns, but execution does not
1466 // past this point unless head and tail get initialized.
1467 if (!match(headp, heade, env, gc)) {
1468 return false0;
1469 }
1470 return match (tailp, taile, env, gc);
1471 }
1472 return struct_eq(p, e);
1473}
1474
1475// Find match is not very picky about syntax.
1476// A completely malformed recv form is most likely to
1477// just return no_match.
1478static int find_match(lbm_value plist, lbm_value *earr, lbm_uint num, lbm_value *e, lbm_value *env) {
1479
1480 // A pattern list is a list of pattern, expression lists.
1481 // ( (p1 e1) (p2 e2) ... (pn en))
1482 lbm_value curr_p = plist;
1483 int n = 0;
1484 bool_Bool gc = false0;
1485 for (int i = 0; i < (int)num; i ++ ) {
1486 lbm_value curr_e = earr[i];
1487 while (!lbm_is_symbol_nil(curr_p)) {
1488 lbm_value me = get_car(curr_p);
1489 if (match(get_car(me), curr_e, env, &gc)) {
1490 if (gc) return FM_NEED_GC-1;
1491 *e = get_cadr(me);
1492
1493 if (!lbm_is_symbol_nil(get_cadr(get_cdr(me)))) {
1494 return FM_PATTERN_ERROR-3;
1495 }
1496 return n;
1497 }
1498 curr_p = get_cdr(curr_p);
1499 }
1500 curr_p = plist; /* search all patterns against next exp */
1501 n ++;
1502 }
1503
1504 return FM_NO_MATCH-2;
1505}
1506
1507/****************************************************/
1508/* Garbage collection */
1509
1510static void mark_context(eval_context_t *ctx, void *arg1, void *arg2) {
1511 (void) arg1;
1512 (void) arg2;
1513 lbm_value roots[3] = {ctx->curr_exp, ctx->program, ctx->r };
1514 lbm_gc_mark_env(ctx->curr_env);
1515 lbm_gc_mark_roots(roots, 3);
1516 lbm_gc_mark_roots(ctx->mailbox, ctx->num_mail);
1517 lbm_gc_mark_aux(ctx->K.data, ctx->K.sp);
1518}
1519
1520static int gc(void) {
1521 if (ctx_running) {
1522 ctx_running->state = ctx_running->state | LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1523 }
1524
1525 gc_requested = false0;
1526 lbm_gc_state_inc();
1527
1528 // The freelist should generally be NIL when GC runs.
1529 lbm_nil_freelist();
1530 lbm_value *env = lbm_get_global_env();
1531 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
1532 lbm_gc_mark_env(env[i]);
1533 }
1534
1535 mutex_lock(&qmutex); // Lock the queues.
1536 // Any concurrent messing with the queues
1537 // while doing GC cannot possibly be good.
1538 queue_iterator_nm(&queue, mark_context, NULL((void*)0), NULL((void*)0));
1539 queue_iterator_nm(&blocked, mark_context, NULL((void*)0), NULL((void*)0));
1540
1541 if (ctx_running) {
1542 mark_context(ctx_running, NULL((void*)0), NULL((void*)0));
1543 }
1544 mutex_unlock(&qmutex);
1545
1546#ifdef VISUALIZE_HEAP
1547 heap_vis_gen_image();
1548#endif
1549
1550 int r = lbm_gc_sweep_phase();
1551 lbm_heap_new_freelist_length();
1552
1553 if (ctx_running) {
1554 ctx_running->state = ctx_running->state & ~LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1555 }
1556 return r;
1557}
1558
1559int lbm_perform_gc(void) {
1560 return gc();
1561}
1562
1563/****************************************************/
1564/* Evaluation functions */
1565
1566
1567static void eval_symbol(eval_context_t *ctx) {
1568 lbm_uint s = lbm_dec_sym(ctx->curr_exp);
1569 if (s >= RUNTIME_SYMBOLS_START0x40000) {
1570 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1571 if (lbm_env_lookup_b(&res, ctx->curr_exp, ctx->curr_env) ||
1572 lbm_global_env_lookup(&res, ctx->curr_exp)) {
1573 ctx->r = res;
1574 ctx->app_cont = true1;
1575 return;
1576 }
1577 // Dynamic load attempt
1578 // Only symbols of kind RUNTIME can be dynamically loaded.
1579 const char *sym_str = lbm_get_name_by_symbol(s);
1580 const char *code_str = NULL((void*)0);
1581 if (!dynamic_load_callback(sym_str, &code_str)) {
1582 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), ctx->curr_exp);
1583 }
1584 lbm_value *sptr = stack_reserve(ctx, 3);
1585 sptr[0] = ctx->curr_exp;
1586 sptr[1] = ctx->curr_env;
1587 sptr[2] = RESUME(((12) << 2) | 0xF8000001u);
1588
1589 lbm_value chan;
1590 if (!create_string_channel((char *)code_str, &chan)) {
1591 gc();
1592 if (!create_string_channel((char *)code_str, &chan)) {
1593 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1594 }
1595 }
1596
1597 lbm_value loader;
1598 WITH_GC_RMBR_1(loader, lbm_heap_allocate_list_init(2,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1599 ENC_SYM_READ,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1600 chan), chan)(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} };
1601 lbm_value evaluator;
1602 WITH_GC_RMBR_1(evaluator, lbm_heap_allocate_list_init(2,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1603 ENC_SYM_EVAL,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1604 loader), loader)(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } };
1605 ctx->curr_exp = evaluator;
1606 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // dynamics should be evaluable in empty local env
1607 } else {
1608 //special symbols and extensions can be handled the same way.
1609 ctx->r = ctx->curr_exp;
1610 ctx->app_cont = true1;
1611 }
1612}
1613
1614static void eval_quote(eval_context_t *ctx) {
1615 ctx->r = get_cadr(ctx->curr_exp);
1616 ctx->app_cont = true1;
1617}
1618
1619static void eval_selfevaluating(eval_context_t *ctx) {
1620 ctx->r = ctx->curr_exp;
1621 ctx->app_cont = true1;
1622}
1623
1624static void eval_progn(eval_context_t *ctx) {
1625 lbm_value exps = get_cdr(ctx->curr_exp);
1626
1627 if (lbm_is_cons(exps)) {
1628 lbm_uint *sptr = stack_reserve(ctx, 4);
1629 sptr[0] = ctx->curr_env; // env to restore between expressions in progn
1630 sptr[1] = lbm_enc_u(0); // Has env been copied (needed for progn local bindings)
1631 sptr[3] = PROGN_REST(((4) << 2) | 0xF8000001u);
1632 get_car_and_cdr(exps, &ctx->curr_exp, &sptr[2]);
1633 if (lbm_is_symbol(sptr[2])) /* The only symbol it can be is nil */
1634 lbm_stack_drop(&ctx->K, 4);
1635 } else if (lbm_is_symbol_nil(exps)) {
1636 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1637 ctx->app_cont = true1;
1638 } else {
1639 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1640 }
1641}
1642
1643static void eval_atomic(eval_context_t *ctx) {
1644 if (is_atomic) {
1645 lbm_set_error_reason("Atomic blocks cannot be nested!");
1646 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1647 }
1648 stack_reserve(ctx, 1)[0] = EXIT_ATOMIC(((14) << 2) | 0xF8000001u);
1649 is_atomic ++;
1650 eval_progn(ctx);
1651}
1652
1653/* (call-cc (lambda (k) .... )) */
1654static void eval_callcc(eval_context_t *ctx) {
1655 lbm_value cont_array;
1656 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1657 gc();
1658 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1659 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1660 return; // dead return but static analysis doesn't know :)
1661 }
1662 }
1663 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(cont_array);
1664 memcpy(arr->data, ctx->K.data, ctx->K.sp * sizeof(lbm_uint));
1665
1666 lbm_value acont = cons_with_gc(ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u), cont_array, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1667 lbm_value arg_list = cons_with_gc(acont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1668 // Go directly into application evaluation without passing go
1669 lbm_uint *sptr = stack_reserve(ctx, 3);
1670 sptr[0] = ctx->curr_env;
1671 sptr[1] = arg_list;
1672 sptr[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
1673 ctx->curr_exp = get_cadr(ctx->curr_exp);
1674}
1675
1676// (define sym exp)
1677#define KEY1 1
1678#define VAL2 2
1679static void eval_define(eval_context_t *ctx) {
1680 lbm_value parts[3];
1681 lbm_value rest = extract_n(ctx->curr_exp, parts, 3);
1682 lbm_uint *sptr = stack_reserve(ctx, 2);
1683 if (lbm_is_symbol(parts[KEY1]) && lbm_is_symbol_nil(rest)) {
1684 lbm_uint sym_val = lbm_dec_sym(parts[KEY1]);
1685 sptr[0] = parts[KEY1];
1686 if (sym_val >= RUNTIME_SYMBOLS_START0x40000) {
1687 sptr[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
1688 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02) {
1689 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
1690 }
1691 ctx->curr_exp = parts[VAL2];
1692 return;
1693 }
1694 }
1695 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
1696}
1697
1698
1699/* Eval lambda is cheating, a lot! It does this
1700 for performance reasons. The cheats are that
1701 1. When closure is created, a reference to the local env
1702 in which the lambda was evaluated is added to the closure.
1703 Ideally it should have created a list of free variables in the function
1704 and then looked up the values of these creating a new environment.
1705 2. The global env is considered global constant. As there is no copying
1706 of environment bindings into the closure, undefine may break closures.
1707
1708 Correct closure creation is a lot more expensive than what happens here.
1709 However, one can try to write programs in such a way that closures are created
1710 seldomly. If one does that the space-usage benefits of "correct" closures
1711 may outweigh the performance gain of "incorrect" ones.
1712
1713 some obscure programs such as test_setq_local_closure.lisp does not
1714 work properly due to this cheating.
1715 */
1716// (lambda param-list body-exp) -> (closure param-list body-exp env)
1717static void eval_lambda(eval_context_t *ctx) {
1718 lbm_value vals[3];
1719 extract_n(ctx->curr_exp, vals, 3);
1720 ctx->r = allocate_closure(vals[1],vals[2], ctx->curr_env);
1721#ifdef CLEAN_UP_CLOSURES
1722 lbm_uint sym_id = 0;
1723 if (clean_cl_env_symbol) {
1724 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1725 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1726 ctx->curr_exp = app;
1727 } else if (lbm_get_symbol_by_name("clean-cl-env", &sym_id)) {
1728 clean_cl_env_symbol = lbm_enc_sym(sym_id);
1729 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1730 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1731 ctx->curr_exp = app;
1732 } else {
1733 ctx->app_cont = true1;
1734 }
1735#else
1736 ctx->app_cont = true1;
1737#endif
1738}
1739
1740// (if cond-expr then-expr else-expr)
1741static void eval_if(eval_context_t *ctx) {
1742 lbm_value cdr = get_cdr(ctx->curr_exp);
1743 lbm_value *sptr = stack_reserve(ctx, 3);
1744 sptr[0] = get_cdr(cdr);
1745 sptr[1] = ctx->curr_env;
1746 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1747 ctx->curr_exp = get_car(cdr);
1748}
1749
1750// (cond (cond-expr-1 expr-1)
1751// ...
1752// (cond-expr-N expr-N))
1753static void eval_cond(eval_context_t *ctx) {
1754 lbm_value cond1[2];
1755 lbm_value rest_conds = extract_n(ctx->curr_exp, cond1, 2);
1756
1757 // end recursion at (cond )
1758 if (lbm_is_symbol_nil(cond1[1])) {
1759 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1760 ctx->app_cont = true1;
1761 } else {
1762 // Cond is one of the few places where a bit of syntax checking takes place at runtime..
1763 // Maybe dont bother?
1764 lbm_uint len = lbm_list_length(cond1[1]);
1765 if (len != 2) {
1766 lbm_set_error_reason("Incorrect syntax in cond");
1767 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1768 }
1769 lbm_value cond_expr[2];
1770 extract_n(cond1[1], cond_expr, 2);
1771 lbm_value rest;
1772 WITH_GC(rest, lbm_heap_allocate_list_init(2,(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1773 cond_expr[1], // Then branch(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1774 cons_with_gc(ENC_SYM_COND, rest_conds , ENC_SYM_NIL)))(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
1775 lbm_value *sptr = stack_reserve(ctx, 3);
1776 sptr[0] = rest;
1777 sptr[1] = ctx->curr_env;
1778 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1779 ctx->curr_exp = cond_expr[0]; //condition;
1780 }
1781}
1782
1783static void eval_app_cont(eval_context_t *ctx) {
1784 lbm_stack_drop(&ctx->K, 1);
1785 ctx->app_cont = true1;
1786}
1787
1788// Create a named location in an environment to later receive a value.
1789static binding_location_status create_binding_location_internal(lbm_value key, lbm_value *env) {
1790
1791 if (lbm_is_symbol(key) &&
1792 (key == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u) ||
1793 key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)))
1794 return BL_OK;
1795
1796 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) { // default case
1797 lbm_value binding;
1798 lbm_value new_env_tmp;
1799 binding = lbm_cons(key, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1800 new_env_tmp = lbm_cons(binding, *env);
1801 if (lbm_is_symbol(binding) || lbm_is_symbol(new_env_tmp)) {
1802 return BL_NO_MEMORY;
1803 }
1804 *env = new_env_tmp;
1805 } else if (lbm_is_cons(key)) { // deconstruct case
1806 int r = create_binding_location_internal(get_car(key), env);
1807 if (r == BL_OK) {
1808 r = create_binding_location_internal(get_cdr(key), env);
1809 }
1810 return r;
1811 }
1812 return BL_OK;
1813}
1814
1815static void create_binding_location(lbm_value key, lbm_value *env) {
1816
1817 lbm_value env_tmp = *env;
1818 binding_location_status r = create_binding_location_internal(key, &env_tmp);
1819 if (r != BL_OK) {
1820 if (r == BL_NO_MEMORY) {
1821 env_tmp = *env;
1822 lbm_gc_mark_phase(env_tmp);
1823 gc();
1824 r = create_binding_location_internal(key, &env_tmp);
1825 }
1826 switch(r) {
1827 case BL_OK:
1828 break;
1829 case BL_NO_MEMORY:
1830 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1831 break;
1832 case BL_INCORRECT_KEY:
1833 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
1834 break;
1835 }
1836 }
1837 *env = env_tmp;
1838}
1839
1840static void let_bind_values_eval(lbm_value binds, lbm_value exp, lbm_value env, eval_context_t *ctx) {
1841
1842 if (!lbm_is_cons(binds)) {
1843 // binds better be nil or there is a programmer error.
1844 ctx->curr_exp = exp;
1845 return;
1846 }
1847
1848 // Preallocate binding locations.
1849 lbm_value curr = binds;
1850 while (lbm_is_cons(curr)) {
1851 lbm_value new_env_tmp = env;
1852 lbm_value car_curr, cdr_curr;
1853 get_car_and_cdr(curr, &car_curr, &cdr_curr);
1854 lbm_value key = get_car(car_curr);
1855 create_binding_location(key, &new_env_tmp);
1856 env = new_env_tmp;
1857 curr = cdr_curr;
1858 }
1859
1860 lbm_value car_binds;
1861 lbm_value cdr_binds;
1862 get_car_and_cdr(binds, &car_binds, &cdr_binds);
1863 lbm_value key_val[2];
1864 extract_n(car_binds, key_val, 2);
1865
1866 lbm_uint *sptr = stack_reserve(ctx, 5);
1867 sptr[0] = exp;
1868 sptr[1] = cdr_binds;
1869 sptr[2] = env;
1870 sptr[3] = key_val[0];
1871 sptr[4] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
1872 ctx->curr_exp = key_val[1];
1873 ctx->curr_env = env;
1874}
1875
1876// (var x (...)) - local binding inside of an progn
1877// var has to take, place root-level nesting within progn.
1878// (progn ... (var a 10) ...) OK!
1879// (progn ... (something (var a 10)) ... ) NOT OK!
1880/* progn stack
1881 sp-4 : env
1882 sp-3 : 0
1883 sp-2 : rest
1884 sp-1 : PROGN_REST
1885*/
1886static void eval_var(eval_context_t *ctx) {
1887
1888 if (ctx->K.sp >= 4) { // Possibly in progn
1889 lbm_value sv = ctx->K.data[ctx->K.sp - 1];
1890 if (IS_CONTINUATION(sv)(((sv) & 0xF8000001u) == 0xF8000001u) && (sv == PROGN_REST(((4) << 2) | 0xF8000001u))) {
1891 lbm_uint sp = ctx->K.sp;
1892 uint32_t is_copied = lbm_dec_as_u32(ctx->K.data[sp-3]);
1893 if (is_copied == 0) {
1894 lbm_value env;
1895 WITH_GC(env, lbm_env_copy_spine(ctx->K.data[sp-4]))(env) = (lbm_env_copy_spine(ctx->K.data[sp-4])); if (lbm_is_symbol_merror
((env))) { gc(); (env) = (lbm_env_copy_spine(ctx->K.data[sp
-4])); if (lbm_is_symbol_merror((env))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1896 ctx->K.data[sp-3] = lbm_enc_u(1);
1897 ctx->K.data[sp-4] = env;
1898 }
1899 lbm_value new_env = ctx->K.data[sp-4];
1900 lbm_value args = get_cdr(ctx->curr_exp);
1901 lbm_value key = get_car(args);
1902 create_binding_location(key, &new_env);
1903 ctx->K.data[sp-4] = new_env;
1904
1905 lbm_value v_exp = get_cadr(args);
1906 lbm_value *sptr = stack_reserve(ctx, 3);
1907 sptr[0] = new_env;
1908 sptr[1] = key;
1909 sptr[2] = PROGN_VAR(((29) << 2) | 0xF8000001u);
1910 // Activating the new environment before the evaluation of the value to be bound,
1911 // means that other variables with same name will be shadowed already in the value
1912 // body.
1913 // The way closures work, the var-variable needs to be in scope during val evaluation
1914 // for a recursive closure to be possible.
1915 ctx->curr_env = new_env;
1916 ctx->curr_exp = v_exp;
1917 return;
1918 }
1919 }
1920 lbm_set_error_reason((char*)lbm_error_str_var_outside_progn);
1921 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1922}
1923
1924// (setq x (...)) - same as (set 'x (...)) or (setvar 'x (...))
1925static void eval_setq(eval_context_t *ctx) {
1926 lbm_value parts[3];
1927 extract_n(ctx->curr_exp, parts, 3);
1928 lbm_value *sptr = stack_reserve(ctx, 3);
1929 sptr[0] = ctx->curr_env;
1930 sptr[1] = parts[1];
1931 sptr[2] = SETQ(((30) << 2) | 0xF8000001u);
1932 ctx->curr_exp = parts[2];
1933}
1934
1935static void eval_move_to_flash(eval_context_t *ctx) {
1936 lbm_value args = get_cdr(ctx->curr_exp);
1937 lbm_value *sptr = stack_reserve(ctx,2);
1938 sptr[0] = args;
1939 sptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
1940 ctx->app_cont = true1;
1941}
1942
1943// (loop list-of-local-bindings
1944// condition-exp
1945// body-exp)
1946static void eval_loop(eval_context_t *ctx) {
1947 lbm_value env = ctx->curr_env;
1948 lbm_value parts[3];
1949 extract_n(get_cdr(ctx->curr_exp), parts, 3);
1950 lbm_value *sptr = stack_reserve(ctx, 3);
1951 sptr[0] = parts[LOOP_BODY2];
1952 sptr[1] = parts[LOOP_COND1];
1953 sptr[2] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
1954 let_bind_values_eval(parts[LOOP_BINDS0], parts[LOOP_COND1], env, ctx);
1955}
1956
1957/* (trap expression)
1958 *
1959 * suggested use:
1960 * (match (trap expression)
1961 * ((exit-error (? err)) (error-handler err))
1962 * ((exit-ok (? v)) (value-handler v)))
1963 */
1964static void eval_trap(eval_context_t *ctx) {
1965
1966 lbm_value expr = get_cadr(ctx->curr_exp);
1967 lbm_value retval;
1968 WITH_GC(retval, lbm_heap_allocate_list(2))(retval) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((retval))) { gc(); (retval) = (lbm_heap_allocate_list(2)); if
(lbm_is_symbol_merror((retval))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1969 lbm_set_car(retval, ENC_SYM_EXIT_OK(((0x3000B) << 4) | 0x00000000u)); // Assume things will go well.
1970 lbm_uint *sptr = stack_reserve(ctx,3);
1971 sptr[0] = retval;
1972 sptr[1] = ctx->flags;
1973 sptr[2] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1974 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10;
1975 ctx->curr_exp = expr;
1976}
1977
1978// (let list-of-binding s
1979// body-exp)
1980static void eval_let(eval_context_t *ctx) {
1981 lbm_value env = ctx->curr_env;
1982 lbm_value parts[3];
1983 extract_n(ctx->curr_exp, parts, 3);
1984 let_bind_values_eval(parts[1], parts[2], env, ctx);
1985}
1986
1987// (and exp0 ... expN)
1988static void eval_and(eval_context_t *ctx) {
1989 lbm_value rest = get_cdr(ctx->curr_exp);
1990 if (lbm_is_symbol_nil(rest)) {
1991 ctx->app_cont = true1;
1992 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1993 } else {
1994 lbm_value *sptr = stack_reserve(ctx, 3);
1995 sptr[0] = ctx->curr_env;
1996 sptr[1] = get_cdr(rest);
1997 sptr[2] = AND(((6) << 2) | 0xF8000001u);
1998 ctx->curr_exp = get_car(rest);
1999 }
2000}
2001
2002// (or exp0 ... expN)
2003static void eval_or(eval_context_t *ctx) {
2004 lbm_value rest = get_cdr(ctx->curr_exp);
2005 if (lbm_is_symbol_nil(rest)) {
2006 ctx->app_cont = true1;
2007 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2008 } else {
2009 lbm_value *sptr = stack_reserve(ctx, 3);
2010 sptr[0] = ctx->curr_env;
2011 sptr[1] = get_cdr(rest);
2012 sptr[2] = OR(((7) << 2) | 0xF8000001u);
2013 ctx->curr_exp = get_car(rest);
2014 }
2015}
2016
2017// Pattern matching
2018// format:
2019// (match e (pattern body)
2020// (pattern body)
2021// ... )
2022//
2023// There can be an optional pattern guard:
2024// (match e (pattern guard body)
2025// ... )
2026// a guard is a boolean expression.
2027// Guards make match, pattern matching more complicated
2028// than the recv pattern matching and requires staged execution
2029// via the continuation system rather than a while loop over a list.
2030static void eval_match(eval_context_t *ctx) {
2031
2032 lbm_value rest = get_cdr(ctx->curr_exp);
2033 if (lbm_type_of(rest) == LBM_TYPE_SYMBOL0x00000000u &&
2034 rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
2035 // Someone wrote the program (match)
2036 ctx->app_cont = true1;
2037 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2038 } else {
2039 lbm_value cdr_rest;
2040 get_car_and_cdr(rest, &ctx->curr_exp, &cdr_rest);
2041 lbm_value *sptr = stack_reserve(ctx, 3);
2042 sptr[0] = cdr_rest;
2043 sptr[1] = ctx->curr_env;
2044 sptr[2] = MATCH(((9) << 2) | 0xF8000001u);
2045 }
2046}
2047
2048static void receive_base(eval_context_t *ctx, lbm_value pats, float timeout_time, bool_Bool timeout) {
2049 if (ctx->num_mail == 0) {
2050 if (timeout) {
2051 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000), false0);
2052 } else {
2053 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1,0,false0);
2054 }
2055 } else {
2056 lbm_value *msgs = ctx->mailbox;
2057 lbm_uint num = ctx->num_mail;
2058
2059 if (lbm_is_symbol_nil(pats)) {
2060 /* A receive statement without any patterns */
2061 ctx->app_cont = true1;
2062 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2063 } else {
2064 /* The common case */
2065 lbm_value e;
2066 lbm_value new_env = ctx->curr_env;
2067 int n = find_match(pats, msgs, num, &e, &new_env);
2068 if (n == FM_NEED_GC-1) {
2069 gc();
2070 new_env = ctx->curr_env;
2071 n = find_match(pats, msgs, num, &e, &new_env);
2072 if (n == FM_NEED_GC-1) {
2073 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2074 }
2075 }
2076 if (n == FM_PATTERN_ERROR-3) {
2077 lbm_set_error_reason("Incorrect pattern format for recv");
2078 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),pats);
2079 } else if (n >= 0 ) { /* Match */
2080 mailbox_remove_mail(ctx, (lbm_uint)n);
2081 ctx->curr_env = new_env;
2082 ctx->curr_exp = e;
2083 } else { /* No match go back to sleep */
2084 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
2085 if (timeout) {
2086 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2,S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000),false0);
2087 } else {
2088 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,false0);
2089 }
2090 }
2091 }
2092 }
2093 return;
2094}
2095
2096static void eval_receive_timeout(eval_context_t *ctx) {
2097 if (is_atomic) {
2098 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2099 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2100 }
2101 lbm_value timeout_val = get_cadr(ctx->curr_exp);
2102 if (!lbm_is_number(timeout_val)) {
2103 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2104 }
2105 float timeout_time = lbm_dec_as_float(timeout_val);
2106 lbm_value pats = get_cdr(get_cdr(ctx->curr_exp));
2107 receive_base(ctx, pats, timeout_time, true1);
2108}
2109
2110// Receive
2111// (recv (pattern expr)
2112// (pattern expr))
2113static void eval_receive(eval_context_t *ctx) {
2114
2115 if (is_atomic) {
2116 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2117 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
2118 }
2119 lbm_value pats = get_cdr(ctx->curr_exp);
2120 receive_base(ctx, pats, 0, false0);
2121}
2122
2123/*********************************************************/
2124/* Continuation functions */
2125
2126/* cont_set_global_env
2127 sp-1 : Key-symbol
2128 */
2129static void cont_set_global_env(eval_context_t *ctx){
2130
2131 lbm_value key;
2132 lbm_value val = ctx->r;
2133
2134 lbm_pop(&ctx->K, &key);
2135 lbm_uint dec_key = lbm_dec_sym(key);
2136 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
2137 lbm_value *global_env = lbm_get_global_env();
2138 lbm_uint orig_env = global_env[ix_key];
2139 lbm_value new_env;
2140 // A key is a symbol and should not need to be remembered.
2141 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2142
2143 global_env[ix_key] = new_env;
2144 ctx->r = val;
2145
2146 ctx->app_cont = true1;
2147
2148 return;
2149}
2150
2151static void cont_resume(eval_context_t *ctx) {
2152 lbm_pop_2(&ctx->K, &ctx->curr_env, &ctx->curr_exp);
2153}
2154
2155static void cont_progn_rest(eval_context_t *ctx) {
2156 lbm_value *sptr = get_stack_ptr(ctx, 3);
2157
2158 lbm_value rest = sptr[2];
2159 lbm_value env = sptr[0];
2160
2161 lbm_value rest_car, rest_cdr;
2162 get_car_and_cdr(rest, &rest_car, &rest_cdr);
2163 ctx->curr_exp = rest_car;
2164 ctx->curr_env = env;
2165 if (lbm_is_symbol_nil(rest_cdr)) {
2166 // allow for tail recursion
2167 lbm_stack_drop(&ctx->K, 3);
2168 } else {
2169 sptr[2] = rest_cdr;
2170 stack_reserve(ctx, 1)[0] = PROGN_REST(((4) << 2) | 0xF8000001u);
2171 }
2172}
2173
2174static void cont_wait(eval_context_t *ctx) {
2175
2176 lbm_value cid_val;
2177 lbm_pop(&ctx->K, &cid_val);
2178 lbm_cid cid = (lbm_cid)lbm_dec_i(cid_val);
2179
2180 bool_Bool exists = false0;
2181
2182 lbm_blocked_iterator(context_exists, &cid, &exists);
2183 lbm_running_iterator(context_exists, &cid, &exists);
2184
2185 if (ctx_running->id == cid) {
2186 exists = true1;
2187 }
2188
2189 if (exists) {
2190 lbm_value *sptr = stack_reserve(ctx, 2);
2191 sptr[0] = lbm_enc_i(cid);
2192 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2193 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2194 ctx->app_cont = true1;
2195 yield_ctx(50000);
2196 } else {
2197 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2198 ctx->app_cont = true1;
2199 }
2200}
2201
2202static lbm_value perform_setvar(lbm_value key, lbm_value val, lbm_value env) {
2203
2204 lbm_uint s = lbm_dec_sym(key);
2205 if (s >= RUNTIME_SYMBOLS_START0x40000) {
2206 lbm_value new_env = lbm_env_modify_binding(env, key, val);
2207 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2208 lbm_uint ix_key = lbm_dec_sym(key) & GLOBAL_ENV_MASK0x1F;
2209 lbm_value *glob_env = lbm_get_global_env();
2210 new_env = lbm_env_modify_binding(glob_env[ix_key], key, val);
2211 glob_env[ix_key] = new_env;
2212 }
2213 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2214 lbm_set_error_reason((char*)lbm_error_str_variable_not_bound);
2215 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), key);
2216 }
2217 return val;
2218 }
2219 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2220 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // unreachable
2221}
2222
2223static void apply_setvar(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2224 if (nargs == 2 && lbm_is_symbol(args[0])) {
2225 lbm_value res;
2226 WITH_GC(res, perform_setvar(args[0], args[1], ctx->curr_env))(res) = (perform_setvar(args[0], args[1], ctx->curr_env));
if (lbm_is_symbol_merror((res))) { gc(); (res) = (perform_setvar
(args[0], args[1], ctx->curr_env)); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2227 ctx->r = args[1];
2228 lbm_stack_drop(&ctx->K, nargs+1);
2229 ctx->app_cont = true1;
2230 } else {
2231 if (nargs == 2) lbm_set_error_reason((char*)lbm_error_str_incorrect_arg);
2232 else lbm_set_error_reason((char*)lbm_error_str_num_args);
2233 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2234 }
2235}
2236
2237static void apply_read_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, bool_Bool program, bool_Bool incremental) {
2238 if (nargs == 1) {
2239 lbm_value chan = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2240 if (lbm_type_of_functional(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2241 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2242 gc();
2243 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2244 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2245 }
2246 }
2247 } else if (lbm_type_of(args[0]) == LBM_TYPE_CHANNEL0x90000000u) {
2248 chan = args[0];
2249 } else {
2250 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2251 }
2252 lbm_value *sptr = get_stack_ptr(ctx, 2);
2253
2254 // If we are inside a reader, its settings are stored.
2255 sptr[0] = lbm_enc_u(ctx->flags); // flags stored.
2256 sptr[1] = chan;
2257 lbm_value *rptr = stack_reserve(ctx,1);
2258 rptr[0] = READ_DONE(((20) << 2) | 0xF8000001u);
2259
2260 // Each reader starts in a fresh situation
2261 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
2262
2263 if (program) {
2264 if (incremental) {
2265 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2266 lbm_value *rptr1 = stack_reserve(ctx,3);
2267 rptr1[0] = chan;
2268 rptr1[1] = ctx->curr_env;
2269 rptr1[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
2270 } else {
2271 ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2272 lbm_value *rptr1 = stack_reserve(ctx,4);
2273 rptr1[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2274 rptr1[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2275 rptr1[2] = chan;
2276 rptr1[3] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
2277 }
2278 }
2279 rptr = stack_reserve(ctx,3); // reuse of variable rptr
2280 rptr[0] = chan;
2281 rptr[1] = lbm_enc_u(1);
2282 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
2283 ctx->app_cont = true1;
2284 } else {
2285 lbm_set_error_reason((char*)lbm_error_str_num_args);
2286 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2287 }
2288}
2289
2290static void apply_read_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2291 apply_read_base(args,nargs,ctx,true1,false0);
2292}
2293
2294static void apply_read_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2295 apply_read_base(args,nargs,ctx,true1,true1);
2296}
2297
2298static void apply_read(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2299 apply_read_base(args,nargs,ctx,false0,false0);
2300}
2301
2302static void apply_spawn_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, uint32_t context_flags) {
2303
2304 lbm_uint stack_size = EVAL_CPS_DEFAULT_STACK_SIZE256;
2305 lbm_uint closure_pos = 0;
2306 char *name = NULL((void*)0);
2307
2308 if (nargs >= 1 &&
2309 lbm_is_closure(args[0])) {
2310 closure_pos = 0;
2311 } else if (nargs >= 2 &&
2312 lbm_is_number(args[0]) &&
2313 lbm_is_closure(args[1])) {
2314 stack_size = lbm_dec_as_u32(args[0]);
2315 closure_pos = 1;
2316 } else if (nargs >= 2 &&
2317 lbm_is_array_r(args[0]) &&
2318 lbm_is_closure(args[1])) {
2319 name = lbm_dec_str(args[0]);
2320 closure_pos = 1;
2321 }else if (nargs >= 3 &&
2322 lbm_is_array_r(args[0]) &&
2323 lbm_is_number(args[1]) &&
2324 lbm_is_closure(args[2])) {
2325 stack_size = lbm_dec_as_u32(args[1]);
2326 closure_pos = 2;
2327 name = lbm_dec_str(args[0]);
2328 } else {
2329 if (context_flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01)
2330 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN_TRAP(((0x30005) << 4) | 0x00000000u));
2331 else
2332 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN(((0x30004) << 4) | 0x00000000u));
2333 }
2334
2335 lbm_value cl[3];
2336 extract_n(get_cdr(args[closure_pos]), cl, 3);
2337 lbm_value curr_param = cl[CLO_PARAMS0];
2338 lbm_value clo_env = cl[CLO_ENV2];
2339 lbm_uint i = closure_pos + 1;
2340 while (lbm_is_cons(curr_param) && i <= nargs) {
2341 lbm_value entry = cons_with_gc(get_car(curr_param), args[i], clo_env);
2342 lbm_value aug_env = cons_with_gc(entry, clo_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2343 clo_env = aug_env;
2344 curr_param = get_cdr(curr_param);
2345 i ++;
2346 }
2347
2348 lbm_stack_drop(&ctx->K, nargs+1);
2349
2350 lbm_value program = cons_with_gc(cl[CLO_BODY1], ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), clo_env);
2351
2352 lbm_cid cid = lbm_create_ctx_parent(program,
2353 clo_env,
2354 stack_size,
2355 lbm_get_current_cid(),
2356 context_flags,
2357 name);
2358 ctx->r = lbm_enc_i(cid);
2359 ctx->app_cont = true1;
2360}
2361
2362static void apply_spawn(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2363 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00);
2364}
2365
2366static void apply_spawn_trap(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2367 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01);
2368}
2369
2370static void apply_yield(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2371 if (is_atomic) {
2372 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2373 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2374 }
2375 if (nargs == 1 && lbm_is_number(args[0])) {
2376 lbm_uint ts = lbm_dec_as_u32(args[0]);
2377 lbm_stack_drop(&ctx->K, nargs+1);
2378 yield_ctx(ts);
2379 } else {
2380 lbm_set_error_reason((char*)lbm_error_str_no_number);
2381 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2382 }
2383}
2384
2385static void apply_sleep(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2386 if (is_atomic) {
2387 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2388 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2389 }
2390 if (nargs == 1 && lbm_is_number(args[0])) {
2391 lbm_uint ts = (lbm_uint)(1000000.0f * lbm_dec_as_float(args[0]));
2392 lbm_stack_drop(&ctx->K, nargs+1);
2393 yield_ctx(ts);
2394 } else {
2395 lbm_set_error_reason((char*)lbm_error_str_no_number);
2396 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2397 }
2398}
2399
2400static void apply_wait(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2401 if (nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2402 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2403 lbm_value *sptr = get_stack_ptr(ctx, 2);
2404 sptr[0] = lbm_enc_i(cid);
2405 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2406 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2407 ctx->app_cont = true1;
2408 yield_ctx(50000);
2409 } else {
2410 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_WAIT(((0x30007) << 4) | 0x00000000u));
2411 }
2412}
2413
2414/* (eval expr)
2415 (eval env expr) */
2416static void apply_eval(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2417 if ( nargs == 1) {
2418 ctx->curr_exp = args[0];
2419 } else if (nargs == 2) {
2420 ctx->curr_exp = args[1];
2421 ctx->curr_env = args[0];
2422 } else {
2423 lbm_set_error_reason((char*)lbm_error_str_num_args);
2424 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL(((0x30008) << 4) | 0x00000000u));
2425 }
2426 lbm_stack_drop(&ctx->K, nargs+1);
2427}
2428
2429static void apply_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2430 int prg_pos = 0;
2431 if (nargs == 2) {
2432 prg_pos = 1;
2433 ctx->curr_env = args[0];
2434 }
2435 if (nargs == 1 || nargs == 2) {
2436 lbm_value prg = args[prg_pos];
2437 lbm_value app_cont;
2438 lbm_value app_cont_prg;
2439 lbm_value new_prg;
2440 lbm_value prg_copy;
2441
2442 int len = -1;
2443 WITH_GC(prg_copy, lbm_list_copy(&len, prg))(prg_copy) = (lbm_list_copy(&len, prg)); if (lbm_is_symbol_merror
((prg_copy))) { gc(); (prg_copy) = (lbm_list_copy(&len, prg
)); if (lbm_is_symbol_merror((prg_copy))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2444 lbm_stack_drop(&ctx->K, nargs+1);
2445
2446 if (ctx->K.sp > nargs+2) { // if there is a continuation
2447 app_cont = cons_with_gc(ENC_SYM_APP_CONT(((0x111) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2448 app_cont_prg = cons_with_gc(app_cont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2449 new_prg = lbm_list_append(app_cont_prg, ctx->program);
2450 new_prg = lbm_list_append(prg_copy, new_prg);
2451 } else {
2452 new_prg = lbm_list_append(prg_copy, ctx->program);
2453 }
2454 if (!lbm_is_list(new_prg)) {
2455 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2456 }
2457 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);
2458 ctx->program = get_cdr(new_prg);
2459 ctx->curr_exp = get_car(new_prg);
2460 } else {
2461 lbm_set_error_reason((char*)lbm_error_str_num_args);
2462 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2463 }
2464}
2465
2466static void apply_send(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2467 if (nargs == 2) {
2468 if (lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2469 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2470 lbm_value msg = args[1];
2471 lbm_value status = lbm_find_receiver_and_send(cid, msg);
2472 /* return the status */
2473 lbm_stack_drop(&ctx->K, nargs+1);
2474 ctx->r = status;
2475 ctx->app_cont = true1;
2476 } else {
2477 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2478 }
2479 } else {
2480 lbm_set_error_reason((char*)lbm_error_str_num_args);
2481 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2482 }
2483}
2484
2485static void apply_ok(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2486 lbm_value ok_val = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2487 if (nargs >= 1) {
2488 ok_val = args[0];
2489 }
2490 ctx->r = ok_val;
2491 ok_ctx();
2492}
2493
2494static void apply_error(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2495 (void) ctx;
2496 lbm_value err_val = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
2497 if (nargs >= 1) {
2498 err_val = args[0];
2499 }
2500 error_at_ctx(err_val, ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
2501}
2502
2503// (map f arg-list)
2504static void apply_map(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2505 if (nargs == 2 && lbm_is_cons(args[1])) {
2506 lbm_value *sptr = get_stack_ptr(ctx, 3);
2507
2508 lbm_value f = args[0];
2509 lbm_value h = get_car(args[1]);
2510 lbm_value t = get_cdr(args[1]);
2511
2512 lbm_value appli_1;
2513 lbm_value appli;
2514 WITH_GC(appli_1, lbm_heap_allocate_list(2))(appli_1) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli_1))) { gc(); (appli_1) = (lbm_heap_allocate_list(2));
if (lbm_is_symbol_merror((appli_1))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2515 WITH_GC_RMBR_1(appli, lbm_heap_allocate_list(2), appli_1)(appli) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli))) { lbm_gc_mark_phase(appli_1); gc(); (appli) = (lbm_heap_allocate_list
(2)); if (lbm_is_symbol_merror((appli))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2516
2517 lbm_value appli_0 = get_cdr(appli_1);
2518
2519 lbm_set_car_and_cdr(appli_0, h, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2520 lbm_set_car(appli_1, ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u));
2521
2522 lbm_set_car_and_cdr(get_cdr(appli), appli_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2523 lbm_set_car(appli, f);
2524
2525 lbm_value elt = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), appli);
2526 sptr[0] = t; // reuse stack space
2527 sptr[1] = ctx->curr_env;
2528 sptr[2] = elt;
2529 lbm_value *rptr = stack_reserve(ctx,4);
2530 rptr[0] = elt;
2531 rptr[1] = appli;
2532 rptr[2] = appli_0;
2533 rptr[3] = MAP(((26) << 2) | 0xF8000001u);
2534 ctx->curr_exp = appli;
2535 } else if (nargs == 2 && lbm_is_symbol_nil(args[1])) {
2536 lbm_stack_drop(&ctx->K, 3);
2537 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2538 ctx->app_cont = true1;
2539 return;
2540 } else {
2541 lbm_set_error_reason((char*)lbm_error_str_num_args);
2542 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_MAP(((0x3000D) << 4) | 0x00000000u));
2543 }
2544}
2545
2546static void apply_reverse(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2547 if (nargs == 1 && lbm_is_list(args[0])) {
2548 lbm_value curr = args[0];
2549
2550 lbm_value new_list = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2551 while (lbm_is_cons(curr)) {
2552 lbm_value tmp = cons_with_gc(get_car(curr), new_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2553 new_list = tmp;
2554 curr = get_cdr(curr);
2555 }
2556 lbm_stack_drop(&ctx->K, 2);
2557 ctx->r = new_list;
2558 ctx->app_cont = true1;
2559 } else {
2560 lbm_set_error_reason("Reverse requires a list argument");
2561 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_REVERSE(((0x3000E) << 4) | 0x00000000u));
2562 }
2563}
2564
2565static void apply_flatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2566 if (nargs == 1) {
2567
2568 lbm_value v = flatten_value(args[0]);
2569 if ( v == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)) {
2570 gc();
2571 v = flatten_value(args[0]);
2572 }
2573
2574 if (lbm_is_symbol(v)) {
2575 error_at_ctx(v, ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2576 } else {
2577 lbm_stack_drop(&ctx->K, 2);
2578 ctx->r = v;
2579 ctx->app_cont = true1;
2580 }
2581 return;
2582 }
2583 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2584}
2585
2586static void apply_unflatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2587 if(nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2588 lbm_array_header_t *array;
2589 array = (lbm_array_header_t *)get_car(args[0]);
2590
2591 lbm_flat_value_t fv;
2592 fv.buf = (uint8_t*)array->data;
2593 fv.buf_size = array->size;
2594 fv.buf_pos = 0;
2595
2596 lbm_value res;
2597
2598 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2599 if (lbm_unflatten_value(&fv, &res)) {
2600 ctx->r = res;
2601 }
2602 lbm_stack_drop(&ctx->K, 2);
2603 ctx->app_cont = true1;
2604 return;
2605 }
2606 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_UNFLATTEN(((0x30010) << 4) | 0x00000000u));
2607}
2608
2609static void apply_kill(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2610 if (nargs == 2 && lbm_is_number(args[0])) {
2611 lbm_cid cid = lbm_dec_as_i32(args[0]);
2612
2613 if (ctx->id == cid) {
2614 ctx->r = args[1];
2615 finish_ctx();
2616 return;
2617 }
2618 mutex_lock(&qmutex);
2619 eval_context_t *found = NULL((void*)0);
2620 found = lookup_ctx_nm(&blocked, cid);
2621 if (found)
2622 drop_ctx_nm(&blocked, found);
2623 else
2624 found = lookup_ctx_nm(&queue, cid);
2625 if (found)
2626 drop_ctx_nm(&queue, found);
2627
2628 if (found) {
2629 found->K.data[found->K.sp - 1] = KILL(((40) << 2) | 0xF8000001u);
2630 found->r = args[1];
2631 found->app_cont = true1;
2632 enqueue_ctx_nm(&queue,found);
2633 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2634 } else {
2635 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2636 }
2637 lbm_stack_drop(&ctx->K, 3);
2638 ctx->app_cont = true1;
2639 mutex_unlock(&qmutex);
2640 return;
2641 }
2642 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_KILL(((0x30011) << 4) | 0x00000000u));
2643}
2644
2645// (merge comparator list1 list2)
2646static void apply_merge(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2647 if (nargs == 3 && lbm_is_list(args[1]) && lbm_is_list(args[2])) {
2648
2649 if (!lbm_is_closure(args[0])) {
2650 lbm_value closure;
2651 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2652 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2653 lbm_value cl1 = lbm_cdr(closure);
2654 lbm_value par;
2655 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2656 lbm_set_car(cl1, par);
2657 lbm_value cl2 = lbm_cdr(cl1);
2658 lbm_value body;
2659 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2660 lbm_set_car(cl2, body);
2661 lbm_value cl3 = lbm_cdr(cl2);
2662 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2663
2664 // Replace operator on stack with closure and rest of the code is
2665 // compatible.
2666 args[0] = closure;
2667 }
2668
2669 // Copy input lists for functional behaviour at top-level
2670 // merge itself is in-place in the copied lists.
2671 lbm_value a;
2672 lbm_value b;
2673 int len_a = -1;
2674 int len_b = -1;
2675 WITH_GC(a, lbm_list_copy(&len_a, args[1]))(a) = (lbm_list_copy(&len_a, args[1])); if (lbm_is_symbol_merror
((a))) { gc(); (a) = (lbm_list_copy(&len_a, args[1])); if
(lbm_is_symbol_merror((a))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } };
2676 WITH_GC_RMBR_1(b, lbm_list_copy(&len_b, args[2]), a)(b) = (lbm_list_copy(&len_b, args[2])); if (lbm_is_symbol_merror
((b))) { lbm_gc_mark_phase(a); gc(); (b) = (lbm_list_copy(&
len_b, args[2])); if (lbm_is_symbol_merror((b))) { error_ctx(
(((0x23) << 4) | 0x00000000u)); } };
2677
2678 if (len_a == 0) {
2679 ctx->r = b;
2680 lbm_stack_drop(&ctx->K, 4);
2681 ctx->app_cont = true1;
2682 return;
2683 }
2684 if (len_b == 0) {
2685 ctx->r = a;
2686 lbm_stack_drop(&ctx->K, 4);
2687 ctx->app_cont = true1;
2688 return;
2689 }
2690
2691 args[1] = a; // keep safe by replacing the original on stack.
2692 args[2] = b;
2693
2694 lbm_value a_1 = a;
2695 lbm_value a_rest = lbm_cdr(a);
2696 lbm_value b_1 = b;
2697 lbm_value b_rest = lbm_cdr(b);
2698
2699 lbm_value cl[3]; // Comparator closure
2700 extract_n(lbm_cdr(args[0]), cl, 3);
2701 lbm_value cmp_env = cl[CLO_ENV2];
2702 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2703 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2704 lbm_uint len = lbm_list_length(cl[CLO_PARAMS0]);
2705 if (len == 2) {
2706 par1 = get_car(cl[CLO_PARAMS0]);
2707 par2 = get_cadr(cl[CLO_PARAMS0]);
2708 lbm_value new_env0;
2709 lbm_value new_env;
2710 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a_1)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a_1))); if (
lbm_is_symbol_merror((new_env0))) { gc(); (new_env0) = (lbm_env_set
(cmp_env, par1, lbm_car(a_1))); if (lbm_is_symbol_merror((new_env0
))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2711 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b_1)),new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1))); if (
lbm_is_symbol_merror((new_env))) { lbm_gc_mark_phase(new_env0
); gc(); (new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1
))); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2712 cmp_env = new_env;
2713 } else {
2714 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2715 }
2716 lbm_set_cdr(a_1, b_1);
2717 lbm_set_cdr(b_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2718 lbm_value cmp = cl[CLO_BODY1];
2719
2720 lbm_stack_drop(&ctx->K, 4); // TODO: Optimize drop 4 alloc 10 into alloc 6
2721 lbm_uint *sptr = stack_reserve(ctx, 10);
2722 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged list
2723 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged list
2724 sptr[2] = a_1;
2725 sptr[3] = a_rest;
2726 sptr[4] = b_rest;
2727 sptr[5] = cmp;
2728 sptr[6] = cmp_env;
2729 sptr[7] = par1;
2730 sptr[8] = par2;
2731 sptr[9] = MERGE_REST(((43) << 2) | 0xF8000001u);
2732 ctx->curr_exp = cl[CLO_BODY1];
2733 ctx->curr_env = cmp_env;
2734 return;
2735 }
2736 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MERGE(((0x30013) << 4) | 0x00000000u));
2737}
2738
2739// (sort comparator list)
2740static void apply_sort(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2741 if (nargs == 2 && lbm_is_list(args[1])) {
2742
2743 if (!lbm_is_closure(args[0])) {
2744 lbm_value closure;
2745 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2746 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2747 lbm_value cl1 = lbm_cdr(closure);
2748 lbm_value par;
2749 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2750 lbm_set_car(cl1, par);
2751 lbm_value cl2 = lbm_cdr(cl1);
2752 lbm_value body;
2753 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2754 lbm_set_car(cl2, body);
2755 lbm_value cl3 = lbm_cdr(cl2);
2756 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2757
2758 // Replace operator on stack with closure and rest of the code is
2759 // compatible.
2760 args[0] = closure;
2761 }
2762
2763 int len = -1;
2764 lbm_value list_copy;
2765 WITH_GC(list_copy, lbm_list_copy(&len, args[1]))(list_copy) = (lbm_list_copy(&len, args[1])); if (lbm_is_symbol_merror
((list_copy))) { gc(); (list_copy) = (lbm_list_copy(&len,
args[1])); if (lbm_is_symbol_merror((list_copy))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2766 if (len <= 1) {
2767 lbm_stack_drop(&ctx->K, 3);
2768 ctx->r = list_copy;
2769 ctx->app_cont = true1;
2770 return;
2771 }
2772
2773 args[1] = list_copy; // Keep safe, original replaced on stack.
2774
2775 // Take the headmost 2, 1-element sublists.
2776 lbm_value a = list_copy;
2777 lbm_value b = lbm_cdr(a);
2778 lbm_value rest = lbm_cdr(b);
2779 // Do not terminate b. keep rest of list safe from GC in the following
2780 // closure extraction.
2781 //lbm_set_cdr(a, b); // This is void
2782
2783 lbm_value cl[3]; // Comparator closure
2784 extract_n(lbm_cdr(args[0]), cl, 3);
2785 lbm_value cmp_env = cl[CLO_ENV2];
2786 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2787 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2788 lbm_uint cl_len = lbm_list_length(cl[CLO_PARAMS0]);
2789 if (cl_len == 2) {
2790 par1 = get_car(cl[CLO_PARAMS0]);
2791 par2 = get_cadr(cl[CLO_PARAMS0]);
2792 lbm_value new_env0;
2793 lbm_value new_env;
2794 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a))); if (lbm_is_symbol_merror
((new_env0))) { gc(); (new_env0) = (lbm_env_set(cmp_env, par1
, lbm_car(a))); if (lbm_is_symbol_merror((new_env0))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2795 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b)), new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { lbm_gc_mark_phase(new_env0); gc(); (new_env) =
(lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { error_ctx((((0x23) << 4) | 0x00000000u))
; } };
2796 cmp_env = new_env;
2797 } else {
2798 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2799 }
2800 lbm_value cmp = cl[CLO_BODY1];
2801
2802 // Terminate the comparator argument list.
2803 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2804
2805 lbm_stack_drop(&ctx->K, 3); //TODO: optimize drop 3, alloc 20 into alloc 17
2806 lbm_uint *sptr = stack_reserve(ctx, 20);
2807 sptr[0] = cmp;
2808 sptr[1] = cmp_env;
2809 sptr[2] = par1;
2810 sptr[3] = par2;
2811 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged accumulation of sublists
2812 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged accumulation of sublists
2813 sptr[6] = rest;
2814 sptr[7] = lbm_enc_i(1);
2815 sptr[8] = lbm_enc_i(len); //TODO: 28 bit i vs 32 bit i
2816 sptr[9] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
2817 sptr[10] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged sublist
2818 sptr[11] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged sublist
2819 sptr[12] = a;
2820 sptr[13] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no a_rest, 1 element lists in layer 1.
2821 sptr[14] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no b_rest, 1 element lists in layer 1.
2822 sptr[15] = cmp;
2823 sptr[16] = cmp_env;
2824 sptr[17] = par1;
2825 sptr[18] = par2;
2826 sptr[19] = MERGE_REST(((43) << 2) | 0xF8000001u);
2827 ctx->curr_exp = cmp;
2828 ctx->curr_env = cmp_env;
2829 return;
2830 }
2831 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
2832}
2833
2834static void apply_rest_args(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2835 lbm_value res;
2836 if (lbm_env_lookup_b(&res, ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ctx->curr_env)) {
2837 if (nargs == 1 && lbm_is_number(args[0])) {
2838 int32_t ix = lbm_dec_as_i32(args[0]);
2839 res = lbm_index_list(res, ix);
2840 }
2841 ctx->r = res;
2842 } else {
2843 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2844 }
2845 lbm_stack_drop(&ctx->K, nargs+1);
2846 ctx->app_cont = true1;
2847}
2848
2849/* (rotate list-expr dist/dir-expr) */
2850static void apply_rotate(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2851 if (nargs == 2 && lbm_is_list(args[0]) && lbm_is_number(args[1])) {
2852 int len = -1;
2853 lbm_value ls = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2854 WITH_GC(ls, lbm_list_copy(&len, args[0]))(ls) = (lbm_list_copy(&len, args[0])); if (lbm_is_symbol_merror
((ls))) { gc(); (ls) = (lbm_list_copy(&len, args[0])); if
(lbm_is_symbol_merror((ls))) { error_ctx((((0x23) << 4
) | 0x00000000u)); } };
2855 int dist = lbm_dec_as_i32(args[1]);
2856 if (len > 0 && dist != 0) {
2857 int d = dist;
2858 if (dist > 0) {
2859 ls = lbm_list_destructive_reverse(ls);
2860 } else {
2861 d = -dist;
2862 }
2863
2864 lbm_value start = ls;
2865 lbm_value end = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2866 lbm_value curr = start;
2867 while (lbm_is_cons(curr)) {
2868 end = curr;
2869 curr = get_cdr(curr);
2870 }
2871
2872 for (int i = 0; i < d; i ++) {
2873 lbm_value a = start;
2874 start = lbm_cdr(start);
2875 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2876 lbm_set_cdr(end, a);
2877 end = a;
2878 }
2879 ls = start;
2880 if (dist > 0) {
2881 ls = lbm_list_destructive_reverse(ls);
2882 }
2883 }
2884 lbm_stack_drop(&ctx->K, nargs+1);
2885 ctx->app_cont = true1;
2886 ctx->r = ls;
2887 return;
2888 }
2889 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2890}
2891
2892/***************************************************/
2893/* Application lookup table */
2894
2895typedef void (*apply_fun)(lbm_value *, lbm_uint, eval_context_t *);
2896static const apply_fun fun_table[] =
2897 {
2898 apply_setvar,
2899 apply_read,
2900 apply_read_program,
2901 apply_read_eval_program,
2902 apply_spawn,
2903 apply_spawn_trap,
2904 apply_yield,
2905 apply_wait,
2906 apply_eval,
2907 apply_eval_program,
2908 apply_send,
2909 apply_ok,
2910 apply_error,
2911 apply_map,
2912 apply_reverse,
2913 apply_flatten,
2914 apply_unflatten,
2915 apply_kill,
2916 apply_sleep,
2917 apply_merge,
2918 apply_sort,
2919 apply_rest_args,
2920 apply_rotate,
2921 };
2922
2923/***************************************************/
2924/* Application of function that takes arguments */
2925/* passed over the stack. */
2926
2927static void application(eval_context_t *ctx, lbm_value *fun_args, lbm_uint arg_count) {
2928 /* If arriving here, we know that the fun is a symbol.
2929 * and can be a built in operation or an extension.
2930 */
2931 lbm_value fun = fun_args[0];
2932
2933 lbm_uint fun_val = lbm_dec_sym(fun);
2934 lbm_uint fun_kind = SYMBOL_KIND(fun_val)((fun_val) >> 16);
2935
2936 switch (fun_kind) {
2937 case SYMBOL_KIND_EXTENSION1: {
2938 extension_fptr f = extension_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)].fptr;
2939
2940 lbm_value ext_res;
2941 WITH_GC(ext_res, f(&fun_args[1], arg_count))(ext_res) = (f(&fun_args[1], arg_count)); if (lbm_is_symbol_merror
((ext_res))) { gc(); (ext_res) = (f(&fun_args[1], arg_count
)); if (lbm_is_symbol_merror((ext_res))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2942 if (lbm_is_error(ext_res)) { //Error other than merror
2943 error_at_ctx(ext_res, fun);
2944 }
2945 lbm_stack_drop(&ctx->K, arg_count + 1);
2946
2947 ctx->app_cont = true1;
2948 ctx->r = ext_res;
2949
2950 if (blocking_extension) {
2951 blocking_extension = false0;
2952 if (blocking_extension_timeout) {
2953 blocking_extension_timeout = false0;
2954 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, blocking_extension_timeout_us,true1);
2955 } else {
2956 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,true1);
2957 }
2958 mutex_unlock(&blocking_extension_mutex);
2959 }
2960 } break;
2961 case SYMBOL_KIND_FUNDAMENTAL2:
2962 call_fundamental(SYMBOL_IX(fun_val)((fun_val) & 0xFFFF), &fun_args[1], arg_count, ctx);
2963 break;
2964 case SYMBOL_KIND_APPFUN3:
2965 fun_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)](&fun_args[1], arg_count, ctx);
2966 break;
2967 default:
2968 // Symbols that are "special" but not in the way caught above
2969 // ends up here.
2970 lbm_set_error_reason("Symbol does not represent a function");
2971 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),fun_args[0]);
2972 break;
2973 }
2974}
2975
2976static void cont_closure_application_args(eval_context_t *ctx) {
2977 lbm_uint* sptr = get_stack_ptr(ctx, 5);
2978
2979 lbm_value arg_env = (lbm_value)sptr[0];
2980 lbm_value exp = (lbm_value)sptr[1];
2981 lbm_value clo_env = (lbm_value)sptr[2];
2982 lbm_value params = (lbm_value)sptr[3];
2983 lbm_value args = (lbm_value)sptr[4];
2984
2985 lbm_value car_params, cdr_params;
2986 get_car_and_cdr(params, &car_params, &cdr_params);
2987
2988 bool_Bool a_nil = lbm_is_symbol_nil(args);
2989 bool_Bool p_nil = lbm_is_symbol_nil(cdr_params);
2990
2991 lbm_value binder = allocate_binding(car_params, ctx->r, clo_env);
2992
2993 if (!a_nil && !p_nil) {
2994 lbm_value car_args, cdr_args;
2995 get_car_and_cdr(args, &car_args, &cdr_args);
2996 sptr[2] = binder;
2997 sptr[3] = cdr_params;
2998 sptr[4] = cdr_args;
2999 stack_reserve(ctx,1)[0] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
3000 ctx->curr_exp = car_args;
3001 ctx->curr_env = arg_env;
3002 } else if (a_nil && p_nil) {
3003 // Arguments and parameters match up in number
3004 lbm_stack_drop(&ctx->K, 5);
3005 ctx->curr_env = binder;
3006 ctx->curr_exp = exp;
3007 } else if (p_nil) {
3008 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), binder);
3009 sptr[2] = rest_binder;
3010 sptr[3] = get_cdr(args);
3011 sptr[4] = get_car(rest_binder); // last element of rest_args so far
3012 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3013 ctx->curr_exp = get_car(args);
3014 ctx->curr_env = arg_env;
3015 } else {
3016 lbm_set_error_reason((char*)lbm_error_str_num_args);
3017 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
3018 }
3019}
3020
3021
3022static void cont_closure_args_rest(eval_context_t *ctx) {
3023 lbm_uint* sptr = get_stack_ptr(ctx, 5);
3024 lbm_value arg_env = (lbm_value)sptr[0];
3025 lbm_value exp = (lbm_value)sptr[1];
3026 lbm_value clo_env = (lbm_value)sptr[2];
3027 lbm_value args = (lbm_value)sptr[3];
3028 lbm_value last = (lbm_value)sptr[4];
3029 lbm_cons_t* heap = lbm_heap_state.heap;
3030
3031 lbm_value binding = lbm_heap_state.freelist;
3032 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3033 gc();
3034 binding = lbm_heap_state.freelist;
3035 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3036 }
3037 lbm_uint binding_ix = lbm_dec_ptr(binding);
3038 lbm_heap_state.freelist = heap[binding_ix].cdr;
3039 lbm_heap_state.num_alloc += 1;
3040 heap[binding_ix].car = ctx->r;
3041 heap[binding_ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3042
3043
3044 lbm_set_cdr(last, binding);
3045 sptr[4] = binding;
3046
3047 if (args == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3048 lbm_stack_drop(&ctx->K, 5);
3049 ctx->curr_env = clo_env;
3050 ctx->curr_exp = exp;
3051 } else {
3052 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3053 sptr[3] = get_cdr(args);
3054 ctx->curr_exp = get_car(args);
3055 ctx->curr_env = arg_env;
3056 }
3057}
3058
3059static void cont_application_args(eval_context_t *ctx) {
3060 lbm_uint *sptr = get_stack_ptr(ctx, 3);
3061
3062 lbm_value env = sptr[0];
3063 lbm_value rest = sptr[1];
3064 lbm_value count = sptr[2];
3065
3066 ctx->curr_env = env;
3067 sptr[0] = ctx->r; // Function 1st then Arguments
3068 if (lbm_is_cons(rest)) {
3069 lbm_cons_t *cell = lbm_ref_cell(rest);
3070 sptr[1] = env;
3071 sptr[2] = cell->cdr;
3072 lbm_value *rptr = stack_reserve(ctx,2);
3073 rptr[0] = count + (1 << LBM_VAL_SHIFT4);
3074 rptr[1] = APPLICATION_ARGS(((5) << 2) | 0xF8000001u);
3075 ctx->curr_exp = cell->car;
3076 } else {
3077 // No more arguments
3078 lbm_stack_drop(&ctx->K, 2);
3079 lbm_uint nargs = lbm_dec_u(count);
3080 lbm_value *args = get_stack_ptr(ctx, (uint32_t)(nargs + 1));
3081 application(ctx,args, nargs);
3082 }
3083}
3084
3085static void cont_and(eval_context_t *ctx) {
3086 lbm_value env;
3087 lbm_value rest;
3088 lbm_value arg = ctx->r;
3089 lbm_pop_2(&ctx->K, &rest, &env);
3090 if (lbm_is_symbol_nil(arg)) {
3091 ctx->app_cont = true1;
3092 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3093 } else if (lbm_is_symbol_nil(rest)) {
3094 ctx->app_cont = true1;
3095 } else {
3096 lbm_value *sptr = stack_reserve(ctx, 3);
3097 sptr[0] = env;
3098 sptr[1] = get_cdr(rest);
3099 sptr[2] = AND(((6) << 2) | 0xF8000001u);
3100 ctx->curr_env = env;
3101 ctx->curr_exp = get_car(rest);
3102 }
3103}
3104
3105static void cont_or(eval_context_t *ctx) {
3106 lbm_value env;
3107 lbm_value rest;
3108 lbm_value arg = ctx->r;
3109 lbm_pop_2(&ctx->K, &rest, &env);
3110 if (!lbm_is_symbol_nil(arg)) {
3111 ctx->app_cont = true1;
3112 } else if (lbm_is_symbol_nil(rest)) {
3113 ctx->app_cont = true1;
3114 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3115 } else {
3116 lbm_value *sptr = stack_reserve(ctx, 3);
3117 sptr[0] = env;
3118 sptr[1] = get_cdr(rest);
3119 sptr[2] = OR(((7) << 2) | 0xF8000001u);
3120 ctx->curr_exp = get_car(rest);
3121 ctx->curr_env = env;
3122 }
3123}
3124
3125static int fill_binding_location(lbm_value key, lbm_value value, lbm_value env) {
3126 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) {
3127 if (key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return FB_OK0;
3128 lbm_env_modify_binding(env,key,value);
3129 return FB_OK0;
3130 } else if (lbm_is_cons(key) &&
3131 lbm_is_cons(value)) {
3132 int r = fill_binding_location(get_car(key), get_car(value), env);
3133 if (r == FB_OK0) {
3134 r = fill_binding_location(get_cdr(key), get_cdr(value), env);
3135 }
3136 return r;
3137 }
3138 return FB_TYPE_ERROR-1;
3139}
3140
3141static void cont_bind_to_key_rest(eval_context_t *ctx) {
3142
3143 lbm_value *sptr = get_stack_ptr(ctx, 4);
3144
3145 lbm_value rest = sptr[1];
3146 lbm_value env = sptr[2];
3147 lbm_value key = sptr[3];
3148
3149 if (fill_binding_location(key, ctx->r, env) < 0) {
3150 lbm_set_error_reason("Incorrect type of name/key in let-binding");
3151 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
3152 }
3153
3154 if (lbm_is_cons(rest)) {
3155 lbm_value car_rest = get_car(rest);
3156 lbm_value key_val[2];
3157 extract_n(car_rest, key_val, 2);
3158
3159 sptr[1] = get_cdr(rest);
3160 sptr[3] = key_val[0];
3161 stack_reserve(ctx,1)[0] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
3162 ctx->curr_exp = key_val[1];
3163 ctx->curr_env = env;
3164 } else {
3165 // Otherwise evaluate the expression in the populated env
3166 ctx->curr_exp = sptr[0];
3167 ctx->curr_env = env;
3168 lbm_stack_drop(&ctx->K, 4);
3169 }
3170}
3171
3172static void cont_if(eval_context_t *ctx) {
3173
3174 lbm_value arg = ctx->r;
3175
3176 lbm_value *sptr = pop_stack_ptr(ctx, 2);
3177
3178 ctx->curr_env = sptr[1];
3179 if (lbm_is_symbol_nil(arg)) {
3180 ctx->curr_exp = get_cadr(sptr[0]); // else branch
3181 } else {
3182 ctx->curr_exp = get_car(sptr[0]); // then branch
3183 }
3184}
3185
3186static void cont_match(eval_context_t *ctx) {
3187 lbm_value e = ctx->r;
3188 bool_Bool do_gc = false0;
3189
3190 lbm_uint *sptr = get_stack_ptr(ctx, 2);
3191 lbm_value patterns = (lbm_value)sptr[0];
3192 lbm_value orig_env = (lbm_value)sptr[1]; // restore enclosing environment.
3193 lbm_value new_env = orig_env;
3194
3195 if (lbm_is_symbol_nil(patterns)) {
3196 // no more patterns
3197 lbm_stack_drop(&ctx->K, 2);
3198 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
3199 ctx->app_cont = true1;
3200 } else if (lbm_is_cons(patterns)) {
3201 lbm_value match_case = get_car(patterns);
3202 lbm_value pattern = get_car(match_case);
3203 lbm_value n1 = get_cadr(match_case);
3204 lbm_value n2 = get_cadr(get_cdr(match_case));
3205 lbm_value body;
3206 bool_Bool check_guard = false0;
3207 if (lbm_is_symbol_nil(n2)) { // TODO: Not a very robust check.
3208 body = n1;
3209 } else {
3210 body = n2;
3211 check_guard = true1;
3212 }
3213
3214 bool_Bool is_match = match(pattern, e, &new_env, &do_gc);
3215 if (do_gc) {
3216 gc();
3217 do_gc = false0;
3218 new_env = orig_env;
3219 is_match = match(pattern, e, &new_env, &do_gc);
3220 if (do_gc) {
3221 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3222 }
3223 }
3224 if (is_match) {
3225 if (check_guard) {
3226 lbm_value *rptr = stack_reserve(ctx,5);
3227 sptr[0] = get_cdr(patterns);
3228 sptr[1] = ctx->curr_env;
3229 rptr[0] = MATCH(((9) << 2) | 0xF8000001u);
3230 rptr[1] = new_env;
3231 rptr[2] = body;
3232 rptr[3] = e;
3233 rptr[4] = MATCH_GUARD(((27) << 2) | 0xF8000001u);
3234 ctx->curr_env = new_env;
3235 ctx->curr_exp = n1; // The guard
3236 } else {
3237 lbm_stack_drop(&ctx->K, 2);
3238 ctx->curr_env = new_env;
3239 ctx->curr_exp = body;
3240 }
3241 } else {
3242 // set up for checking of next pattern
3243 sptr[0] = get_cdr(patterns);
3244 sptr[1] = orig_env;
3245 stack_reserve(ctx,1)[0] = MATCH(((9) << 2) | 0xF8000001u);
3246 // leave r unaltered
3247 ctx->app_cont = true1;
3248 }
3249 } else {
3250 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MATCH(((0x108) << 4) | 0x00000000u));
3251 }
3252}
3253
3254static void cont_exit_atomic(eval_context_t *ctx) {
3255 is_atomic --;
3256 ctx->app_cont = true1;
3257}
3258
3259static void cont_map(eval_context_t *ctx) {
3260 lbm_value *sptr = get_stack_ptr(ctx, 6);
3261
3262 lbm_value ls = sptr[0];
3263 lbm_value env = sptr[1];
3264 lbm_value t = sptr[3];
3265 lbm_set_car(t, ctx->r); // update car field tailmost position.
3266 if (lbm_is_cons(ls)) {
3267 lbm_value next, rest;
3268 get_car_and_cdr(ls, &next, &rest);
3269 sptr[0] = rest;
3270 stack_reserve(ctx,1)[0] = MAP(((26) << 2) | 0xF8000001u);
3271 lbm_set_car(sptr[5], next); // new arguments
3272
3273 lbm_value elt = cons_with_gc(ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3274 lbm_set_cdr(t, elt);
3275 sptr[3] = elt; // (r1 ... rN . (nil . nil))
3276 ctx->curr_exp = sptr[4];
3277 ctx->curr_env = env;
3278 } else {
3279 ctx->r = sptr[2]; //head of result list
3280 ctx->curr_env = env;
3281 lbm_stack_drop(&ctx->K, 6);
3282 ctx->app_cont = true1;
3283 }
3284}
3285
3286static void cont_match_guard(eval_context_t *ctx) {
3287 if (lbm_is_symbol_nil(ctx->r)) {
3288 lbm_value e;
3289 lbm_pop(&ctx->K, &e);
3290 lbm_stack_drop(&ctx->K, 2);
3291 ctx->r = e;
3292 ctx->app_cont = true1;
3293 } else {
3294 lbm_value body;
3295 lbm_value env;
3296 lbm_stack_drop(&ctx->K, 1);
3297 lbm_pop_2(&ctx->K, &body, &env);
3298 lbm_stack_drop(&ctx->K, 3);
3299 ctx->curr_env = env;
3300 ctx->curr_exp = body;
3301 }
3302}
3303
3304static void cont_terminate(eval_context_t *ctx) {
3305 error_ctx(ctx->r);
3306}
3307
3308static void cont_loop(eval_context_t *ctx) {
3309 lbm_value *sptr = get_stack_ptr(ctx, 2);
3310 stack_reserve(ctx,1)[0] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
3311 ctx->curr_exp = sptr[1];
3312}
3313
3314static void cont_loop_condition(eval_context_t *ctx) {
3315 if (lbm_is_symbol_nil(ctx->r)) {
3316 lbm_stack_drop(&ctx->K, 2);
3317 ctx->app_cont = true1; // A loop returns nil? Makes sense to me... but in general?
3318 return;
3319 }
3320 lbm_value *sptr = get_stack_ptr(ctx, 2);
3321 stack_reserve(ctx,1)[0] = LOOP(((41) << 2) | 0xF8000001u);
3322 ctx->curr_exp = sptr[0];
3323}
3324
3325static void cont_merge_rest(eval_context_t *ctx) {
3326 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3327
3328 // If comparator returns true (result is in ctx->r):
3329 // "a" should be moved to the last element position in merged list.
3330 // A new element from "a_rest" should be moved into comparator argument 1 pos.
3331 // else
3332 // "b" should be moved to last element position in merged list.
3333 // A new element from "b_rest" should be moved into comparator argument 2 pos.
3334 //
3335 // If a_rest or b_rest is NIL:
3336 // we are done, the remaining elements of
3337 // non_nil list should be appended to merged list.
3338 // else
3339 // Set up for a new comparator evaluation and recurse.
3340 lbm_value a = sptr[2];
3341 lbm_value b = lbm_cdr(a);
3342 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate 1 element list
3343
3344 if (ctx->r == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) { // Comparison false
3345
3346 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3347 sptr[0] = b;
3348 sptr[1] = b;
3349 } else {
3350 lbm_set_cdr(sptr[1], b);
3351 sptr[1] = b;
3352 }
3353 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3354 lbm_set_cdr(a, sptr[3]);
3355 lbm_set_cdr(sptr[1], a);
3356 ctx->r = sptr[0];
3357 lbm_stack_drop(&ctx->K, 9);
3358 ctx->app_cont = true1;
3359 return;
3360 } else {
3361 b = sptr[4];
3362 sptr[4] = lbm_cdr(sptr[4]);
3363 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3364 }
3365 } else {
3366 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3367 sptr[0] = a;
3368 sptr[1] = a;
3369 } else {
3370 lbm_set_cdr(sptr[1], a);
3371 sptr[1] = a;
3372 }
3373
3374 if (sptr[3] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3375 lbm_set_cdr(b, sptr[4]);
3376 lbm_set_cdr(sptr[1], b);
3377 ctx->r = sptr[0];
3378 lbm_stack_drop(&ctx->K, 9);
3379 ctx->app_cont = true1;
3380 return;
3381 } else {
3382 a = sptr[3];
3383 sptr[3] = lbm_cdr(sptr[3]);
3384 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3385 }
3386 }
3387 lbm_set_cdr(a, b);
3388 sptr[2] = a;
3389
3390 lbm_value par1 = sptr[7];
3391 lbm_value par2 = sptr[8];
3392 lbm_value cmp_body = sptr[5];
3393 lbm_value cmp_env = sptr[6];
3394 // Environment should be preallocated already at this point
3395 // and the operations below should never need GC.
3396 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3397 lbm_value new_env = lbm_env_set(new_env0, par2, lbm_car(b));
3398 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3399 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3400 }
3401 cmp_env = new_env;
3402
3403 stack_reserve(ctx,1)[0] = MERGE_REST(((43) << 2) | 0xF8000001u);
3404 ctx->curr_exp = cmp_body;
3405 ctx->curr_env = cmp_env;
3406}
3407
3408// merge_layer stack contents
3409// s[sp-9] = cmp
3410// s[sp-8] = cmp_env
3411// s[sp-7] = par1
3412// s[sp-6] = par2
3413// s[sp-5] = acc - first cell
3414// s[sp-4] = acc - last cell
3415// s[sp-3] = rest;
3416// s[sp-2] = layer
3417// s[sp-1] = length or original list
3418//
3419// ctx->r merged sublist
3420static void cont_merge_layer(eval_context_t *ctx) {
3421 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3422 lbm_int layer = lbm_dec_i(sptr[7]);
3423 lbm_int len = lbm_dec_i(sptr[8]);
3424
3425 lbm_value r_curr = ctx->r;
3426 while (lbm_is_cons(r_curr)) {
3427 lbm_value next = lbm_cdr(r_curr);
3428 if (next == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3429 break;
3430 }
3431 r_curr = next;
3432 }
3433
3434 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3435 sptr[4] = ctx->r;
3436 sptr[5] = r_curr;
3437 } else {
3438 lbm_set_cdr(sptr[5], ctx->r); // accumulate merged sublists.
3439 sptr[5] = r_curr;
3440 }
3441
3442 lbm_value layer_rest = sptr[6];
3443 // switch layer or done ?
3444 if (layer_rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3445 if (layer * 2 >= len) {
3446 ctx->r = sptr[4];
3447 ctx->app_cont = true1;
3448 lbm_stack_drop(&ctx->K, 9);
3449 return;
3450 } else {
3451 // Setup for merges of the next layer
3452 layer = layer * 2;
3453 sptr[7] = lbm_enc_i(layer);
3454 layer_rest = sptr[4]; // continue on the accumulation of all sublists.
3455 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3456 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3457 }
3458 }
3459 // merge another sublist based on current layer.
3460 lbm_value a_list = layer_rest;
3461 // build sublist a
3462 lbm_value curr = layer_rest;
3463 for (int i = 0; i < layer-1; i ++) {
3464 if (lbm_is_cons(curr)) {
3465 curr = lbm_cdr(curr);
3466 } else {
3467 break;
3468 }
3469 }
3470 layer_rest = lbm_cdr(curr);
3471 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3472
3473 lbm_value b_list = layer_rest;
3474 // build sublist b
3475 curr = layer_rest;
3476 for (int i = 0; i < layer-1; i ++) {
3477 if (lbm_is_cons(curr)) {
3478 curr = lbm_cdr(curr);
3479 } else {
3480 break;
3481 }
3482 }
3483 layer_rest = lbm_cdr(curr);
3484 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3485
3486 sptr[6] = layer_rest;
3487
3488 if (b_list == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3489 stack_reserve(ctx,1)[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3490 ctx->r = a_list;
3491 ctx->app_cont = true1;
3492 return;
3493 }
3494 // Set up for a merge of sublists.
3495
3496 lbm_value a_rest = lbm_cdr(a_list);
3497 lbm_value b_rest = lbm_cdr(b_list);
3498 lbm_value a = a_list;
3499 lbm_value b = b_list;
3500 lbm_set_cdr(a, b);
3501 // Terminating the b list would be incorrect here
3502 // if there was any chance that the environment update below
3503 // performs GC.
3504 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3505
3506 lbm_value cmp_body = sptr[0];
3507 lbm_value cmp_env = sptr[1];
3508 lbm_value par1 = sptr[2];
3509 lbm_value par2 = sptr[3];
3510 // Environment should be preallocated already at this point
3511 // and the operations below should never need GC.
3512 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3513 lbm_value new_env = lbm_env_set(cmp_env, par2, lbm_car(b));
3514 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3515 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3516 }
3517 cmp_env = new_env;
3518
3519 lbm_uint *merge_cont = stack_reserve(ctx, 11);
3520 merge_cont[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3521 merge_cont[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3522 merge_cont[2] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3523 merge_cont[3] = a;
3524 merge_cont[4] = a_rest;
3525 merge_cont[5] = b_rest;
3526 merge_cont[6] = cmp_body;
3527 merge_cont[7] = cmp_env;
3528 merge_cont[8] = par1;
3529 merge_cont[9] = par2;
3530 merge_cont[10] = MERGE_REST(((43) << 2) | 0xF8000001u);
3531 ctx->curr_exp = cmp_body;
3532 ctx->curr_env = cmp_env;
3533 return;
3534}
3535
3536/****************************************************/
3537/* READER */
3538
3539static void read_finish(lbm_char_channel_t *str, eval_context_t *ctx) {
3540
3541 /* Tokenizer reached "end of file"
3542 The parser could be in a state where it needs
3543 more tokens to correctly finish an expression.
3544
3545 Three cases
3546 1. The program / expression is malformed and the context should die.
3547 2. We are finished reading a program and should close off the
3548 internal representation with a closing parenthesis. Then
3549 apply continuation.
3550 3. We are finished reading an expression and should
3551 apply the continuation.
3552
3553 In case 3, we should find the READ_DONE at sp - 1.
3554 In case 2, we should find the READ_DONE at sp - 5.
3555
3556 */
3557
3558 if (lbm_is_symbol(ctx->r)) {
3559 lbm_uint sym_val = lbm_dec_sym(ctx->r);
3560 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
3561 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
3562 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3563 }
3564 }
3565
3566 if (ctx->K.data[ctx->K.sp-1] == READ_DONE(((20) << 2) | 0xF8000001u) &&
3567 lbm_dec_u(ctx->K.data[ctx->K.sp-3]) == 0) {
3568 /* successfully finished reading an expression (CASE 3) */
3569 ctx->app_cont = true1;
3570 } else if (ctx->K.sp > 4 && ctx->K.data[ctx->K.sp - 4] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3571 lbm_value env;
3572 lbm_value s;
3573 lbm_value sym;
3574 lbm_pop_3(&ctx->K, &sym, &env, &s);
3575 ctx->curr_env = env;
3576 ctx->app_cont = true1; // Program evaluated and result is in ctx->r.
3577 } else if (ctx->K.sp > 5 && ctx->K.data[ctx->K.sp - 5] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3578 /* successfully finished reading a program (CASE 2) */
3579 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3580 ctx->app_cont = true1;
3581 } else {
3582 /* Parsing failed */
3583 if (lbm_channel_row(str) == 1 &&
3584 lbm_channel_column(str) == 1 ){
3585 // eof at empty stream.
3586 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3587 ctx->app_cont = true1;
3588 } else {
3589 lbm_set_error_reason((char*)lbm_error_str_parse_eof);
3590 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3591 }
3592 lbm_channel_reader_close(str);
3593 }
3594}
3595
3596/* cont_read_next_token
3597 sp-2 : Stream
3598 sp-1 : Grab row
3599*/
3600static void cont_read_next_token(eval_context_t *ctx) {
3601 lbm_value *sptr = get_stack_ptr(ctx, 2);
3602 lbm_value stream = sptr[0];
3603 lbm_value grab_row0 = sptr[1];
3604
3605 lbm_char_channel_t *chan = lbm_dec_channel(stream);
3606 if (chan == NULL((void*)0) || chan->state == NULL((void*)0)) {
3607 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3608 }
3609
3610 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3611 lbm_stack_drop(&ctx->K, 2);
3612 read_finish(chan, ctx);
3613 return;
3614 }
3615 /* Eat whitespace and comments */
3616 if (!tok_clean_whitespace(chan)) {
3617 sptr[0] = stream;
3618 sptr[1] = lbm_enc_u(0);
3619 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3620 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3621 return;
3622 }
3623 /* After eating whitespace we may be at end of file/stream */
3624 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3625 lbm_stack_drop(&ctx->K, 2);
3626 read_finish(chan, ctx);
3627 return;
3628 }
3629
3630 if (lbm_dec_u(grab_row0)) {
3631 ctx->row0 = (int32_t)lbm_channel_row(chan);
3632 }
3633
3634 /* Attempt to extract tokens from the character stream */
3635 int n = 0;
3636 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3637 unsigned int string_len = 0;
3638
3639 /*
3640 * SYNTAX
3641 */
3642 uint32_t match;
3643 n = tok_syntax(chan, &match);
3644 if (n > 0) {
3645 if (!lbm_channel_drop(chan, (unsigned int)n)) {
3646 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3647 }
3648 ctx->app_cont = true1;
3649 lbm_uint do_next = 0;
3650 switch(match) {
3651 case TOKOPENPAR1u: {
3652 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3653 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3654 lbm_value *rptr = stack_reserve(ctx,5);
3655 rptr[0] = stream;
3656 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3657 rptr[2] = stream;
3658 rptr[3] = lbm_enc_u(0);
3659 rptr[4] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3660 ctx->r = ENC_SYM_OPENPAR(((0x70) << 4) | 0x00000000u);
3661 } return;
3662 case TOKCLOSEPAR2u: {
3663 lbm_stack_drop(&ctx->K, 2);
3664 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3665 } return;
3666 case TOKOPENBRACK3u: {
3667 sptr[0] = stream;
3668 sptr[1] = READ_START_ARRAY(((24) << 2) | 0xF8000001u);
3669 lbm_value *rptr = stack_reserve(ctx, 3);
3670 rptr[0] = stream;
3671 rptr[1] = lbm_enc_u(0);
3672 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3673 ctx->r = ENC_SYM_OPENBRACK(((0x80) << 4) | 0x00000000u);
3674 } return;
3675 case TOKCLOSEBRACK4u:
3676 lbm_stack_drop(&ctx->K, 2);
3677 ctx->r = ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u);
3678 return;
3679 case TOKDOT5u:
3680 lbm_stack_drop(&ctx->K, 2);
3681 ctx->r = ENC_SYM_DOT(((0x76) << 4) | 0x00000000u);
3682 return;
3683 case TOKDONTCARE6u:
3684 lbm_stack_drop(&ctx->K, 2);
3685 ctx->r = ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u);
3686 return;
3687 case TOKQUOTE7u:
3688 do_next = READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u);
3689 break;
3690 case TOKBACKQUOTE8u: {
3691 sptr[0] = QQ_EXPAND_START(((35) << 2) | 0xF8000001u);
3692 sptr[1] = stream;
3693 lbm_value *rptr = stack_reserve(ctx, 2);
3694 rptr[0] = lbm_enc_u(0);
3695 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3696 ctx->app_cont = true1;
3697 } return;
3698 case TOKCOMMAAT9u:
3699 do_next = READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u);
3700 break;
3701 case TOKCOMMA10u:
3702 do_next = READ_COMMA_RESULT(((23) << 2) | 0xF8000001u);
3703 break;
3704 case TOKMATCHANY11u:
3705 lbm_stack_drop(&ctx->K, 2);
3706 ctx->r = ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u);
3707 return;
3708 case TOKOPENCURL12u: {
3709 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3710 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3711 lbm_value *rptr = stack_reserve(ctx,2);
3712 rptr[0] = stream;
3713 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3714 ctx->r = ENC_SYM_PROGN(((0x102) << 4) | 0x00000000u);
3715 } return;
3716 case TOKCLOSECURL13u:
3717 lbm_stack_drop(&ctx->K, 2);
3718 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3719 return;
3720 case TOKCONSTSTART14u: /* fall through */
3721 case TOKCONSTEND15u:
3722 case TOKCONSTSYMSTR16u: {
3723 if (match == TOKCONSTSTART14u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3724 if (match == TOKCONSTEND15u) ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3725 if (match == TOKCONSTSYMSTR16u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04;
3726 sptr[0] = stream;
3727 sptr[1] = lbm_enc_u(0);
3728 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3729 ctx->app_cont = true1;
3730 } return;
3731 default:
3732 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3733 }
3734 sptr[0] = do_next;
3735 sptr[1] = stream;
3736 lbm_value *rptr = stack_reserve(ctx, 2);
3737 rptr[0] = lbm_enc_u(0);
3738 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3739 ctx->app_cont = true1;
3740 return;
3741 } else if (n < 0) goto retry_token;
3742
3743 /*
3744 * STRING
3745 */
3746 n = tok_string(chan, &string_len);
3747 if (n >= 2) {
3748 lbm_channel_drop(chan, (unsigned int)n);
3749 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3750 gc();
3751 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3752 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3753 return; // dead return but static analysis does not know that.
3754 }
3755 }
3756 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(res);
3757 char *data = (char*)arr->data;
3758 memset(data,0, string_len + 1);
3759 memcpy(data, tokpar_sym_str, string_len);
3760 lbm_stack_drop(&ctx->K, 2);
3761 ctx->r = res;
3762 ctx->app_cont = true1;
3763 return;
3764 } else if (n < 0) goto retry_token;
3765
3766 /*
3767 * FLOAT
3768 */
3769 token_float f_val;
3770 n = tok_double(chan, &f_val);
3771 if (n > 0) {
3772 lbm_channel_drop(chan, (unsigned int) n);
3773 switch(f_val.type) {
3774 case TOKTYPEF32107u:
3775 WITH_GC(res, lbm_enc_float((float)f_val.value))(res) = (lbm_enc_float((float)f_val.value)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (lbm_enc_float((float)f_val.value));
if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
3776 break;
3777 case TOKTYPEF64108u:
3778 res = lbm_enc_double(f_val.value);
3779 break;
3780 default:
3781 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3782 }
3783 lbm_stack_drop(&ctx->K, 2);
3784 ctx->r = res;
3785 ctx->app_cont = true1;
3786 return;
3787 } else if (n < 0) goto retry_token;
3788
3789 /*
3790 * INTEGER
3791 */
3792 token_int int_result;
3793 n = tok_integer(chan, &int_result);
3794 if (n > 0) {
3795 lbm_channel_drop(chan, (unsigned int)n);
3796 switch(int_result.type) {
3797 case TOKTYPEBYTE100u:
3798 res = lbm_enc_char((uint8_t)(int_result.negative ? -int_result.value : int_result.value));
3799 break;
3800 case TOKTYPEI101u:
3801 res = lbm_enc_i((lbm_int)(int_result.negative ? -int_result.value : int_result.value));
3802 break;
3803 case TOKTYPEU102u:
3804 res = lbm_enc_u((lbm_uint)(int_result.negative ? -int_result.value : int_result.value));
3805 break;
3806 case TOKTYPEI32103u:
3807 WITH_GC(res, lbm_enc_i32((int32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i32((int32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i32((int32_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3808 break;
3809 case TOKTYPEU32104u:
3810 WITH_GC(res,lbm_enc_u32((uint32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u32((uint32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u32((uint32_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3811 break;
3812 case TOKTYPEI64105u:
3813 WITH_GC(res,lbm_enc_i64((int64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i64((int64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i64((int64_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3814 break;
3815 case TOKTYPEU64106u:
3816 WITH_GC(res,lbm_enc_u64((uint64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u64((uint64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u64((uint64_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3817 break;
3818 default:
3819 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3820 }
3821 lbm_stack_drop(&ctx->K, 2);
3822 ctx->r = res;
3823 ctx->app_cont = true1;
3824 return;
3825 } else if (n < 0) goto retry_token;
3826
3827 /*
3828 * SYMBOL
3829 */
3830 n = tok_symbol(chan);
3831 if (n > 0) {
3832 lbm_channel_drop(chan, (unsigned int) n);
3833 lbm_uint symbol_id;
3834 if (lbm_get_symbol_by_name(tokpar_sym_str, &symbol_id)) {
3835 res = lbm_enc_sym(symbol_id);
3836 } else {
3837 int r = 0;
3838 if (n > 4 &&
3839 tokpar_sym_str[0] == 'e' &&
3840 tokpar_sym_str[1] == 'x' &&
3841 tokpar_sym_str[2] == 't' &&
3842 tokpar_sym_str[3] == '-') {
3843 lbm_uint ext_id;
3844 lbm_uint ext_name_len = (lbm_uint)n + 1;
3845 char *ext_name = lbm_malloc(ext_name_len);
3846 if (!ext_name) {
3847 gc();
3848 ext_name = lbm_malloc(ext_name_len);
3849 }
3850 if (ext_name) {
3851 memcpy(ext_name, tokpar_sym_str, ext_name_len);
3852 r = lbm_add_extension(ext_name, lbm_extensions_default);
3853 if (!lbm_lookup_extension_id(ext_name, &ext_id)) {
3854 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3855 }
3856 symbol_id = ext_id;
3857 } else {
3858 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3859 }
3860 } else {
3861 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04 &&
3862 ctx->flags & EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08) {
3863 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id, true1); //flash
3864 if (!r) {
3865 lbm_set_error_reason((char*)lbm_error_str_flash_error);
3866 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3867 }
3868 } else {
3869 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3870 if (!r) {
3871 gc();
3872 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3873 }
3874 }
3875 }
3876 if (r) {
3877 res = lbm_enc_sym(symbol_id);
3878 } else {
3879 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3880 }
3881 }
3882 lbm_stack_drop(&ctx->K, 2);
3883 ctx->r = res;
3884 ctx->app_cont = true1;
3885 return;
3886 } else if (n == TOKENIZER_NEED_MORE-1) {
3887 goto retry_token;
3888 } else if (n <= TOKENIZER_STRING_ERROR-2) {
3889 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3890 }
3891
3892 /*
3893 * CHAR
3894 */
3895 char c_val;
3896 n = tok_char(chan, &c_val);
3897 if(n > 0) {
3898 lbm_channel_drop(chan,(unsigned int) n);
3899 lbm_stack_drop(&ctx->K, 2);
3900 ctx->r = lbm_enc_char((uint8_t)c_val);
3901 ctx->app_cont = true1;
3902 return;
3903 }else if (n < 0) goto retry_token;
3904
3905 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3906
3907 retry_token:
3908 if (n == TOKENIZER_NEED_MORE-1) {
3909 sptr[0] = stream;
3910 sptr[1] = lbm_enc_u(0);
3911 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3912 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3913 return;
3914 }
3915 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3916}
3917
3918static void cont_read_start_array(eval_context_t *ctx) {
3919 lbm_value *sptr = get_stack_ptr(ctx, 1);
3920 lbm_value stream = sptr[0];
3921
3922 lbm_char_channel_t *str = lbm_dec_channel(stream);
3923 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
3924 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3925 }
3926
3927 lbm_uint num_free = lbm_memory_longest_free();
3928 lbm_uint initial_size = (lbm_uint)((float)num_free * 0.9);
3929 if (initial_size == 0) {
3930 gc();
3931 num_free = lbm_memory_longest_free();
3932 initial_size = (lbm_uint)((float)num_free * 0.9);
3933 if (initial_size == 0) {
3934 lbm_channel_reader_close(str);
3935 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3936 }
3937 }
3938
3939 if (lbm_is_number(ctx->r)) {
3940 lbm_value array;
3941 initial_size = sizeof(lbm_uint) * initial_size;
3942
3943 if (!lbm_heap_allocate_array(&array, initial_size)) {
3944 lbm_set_error_reason("Out of memory while reading.");
3945 lbm_channel_reader_close(str);
3946 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3947 // NOTE: If array is not created evaluation ends here.
3948 // Static analysis seems unaware.
3949 }
3950
3951 sptr[0] = array;
3952 lbm_value *rptr = stack_reserve(ctx, 4);
3953 rptr[0] = lbm_enc_u(initial_size);
3954 rptr[1] = lbm_enc_u(0);
3955 rptr[2] = stream;
3956 rptr[3] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3957 ctx->app_cont = true1;
3958 } else {
3959 lbm_channel_reader_close(str);
3960 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3961 }
3962}
3963
3964static void cont_read_append_array(eval_context_t *ctx) {
3965 lbm_uint *sptr = get_stack_ptr(ctx, 4);
3966
3967 lbm_value array = sptr[0];
1
'array' initialized here
→
3968 lbm_value size = lbm_dec_as_u32(sptr[1]);
3969 lbm_value ix = lbm_dec_as_u32(sptr[2]);
3970 lbm_value stream = sptr[3];
3971
3972 if (ix >= (size - 1)) {
2
←
Assuming the condition is false
→
3
←
Taking false branch
→
3973 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3974 }
3975
3976 // get_car can return nil. Whose value is 0!
3977 // So static Analysis is right about this being a potential NULL pointer.
3978 // However, if the array was created correcly to begin with, it should be fine.
3979 lbm_value arr_car = get_car(array);
4
←
Passing value via 1st parameter 'a'
→
5
←
Calling 'get_car'
→
14
←
Returning from 'get_car'
→
15
←
'arr_car' initialized to 0
→
3980 lbm_array_header_t *arr = (lbm_array_header_t*)arr_car;
16
←
'arr' initialized to a null pointer value
→
3981
3982 if (lbm_is_number(ctx->r)) {
17
←
Calling 'lbm_is_number'
→
21
←
Returning from 'lbm_is_number'
→
22
←
Assuming the condition is false
→
23
←
Taking false branch
→
3983 ((uint8_t*)arr->data)[ix] = (uint8_t)lbm_dec_as_u32(ctx->r);
3984
3985 sptr[2] = lbm_enc_u(ix + 1);
3986 lbm_value *rptr = stack_reserve(ctx, 4);
3987 rptr[0] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3988 rptr[1] = stream;
3989 rptr[2] = lbm_enc_u(0);
3990 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3991 ctx->app_cont = true1;
3992 } else if (lbm_is_symbol(ctx->r) && ctx->r == ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u)) {
24
←
Calling 'lbm_is_symbol'
→
27
←
Returning from 'lbm_is_symbol'
→
28
←
Assuming the condition is true
→
29
←
Taking true branch
→
3993 lbm_uint array_size = ix / sizeof(lbm_uint);
3994
3995 if (ix % sizeof(lbm_uint) != 0) {
30
←
Assuming the condition is false
→
31
←
Taking false branch
→
3996 array_size = array_size + 1;
3997 }
3998 lbm_memory_shrink((lbm_uint*)arr->data, array_size);
32
←
Access to field 'data' results in a dereference of a null pointer (loaded from variable 'arr')
3999 arr->size = ix;
4000 lbm_stack_drop(&ctx->K, 4);
4001 ctx->r = array;
4002 ctx->app_cont = true1;
4003 } else {
4004 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
4005 }
4006}
4007
4008static void cont_read_append_continue(eval_context_t *ctx) {
4009 lbm_value *sptr = get_stack_ptr(ctx, 3);
4010
4011 lbm_value first_cell = sptr[0];
4012 lbm_value last_cell = sptr[1];
4013 lbm_value stream = sptr[2];
4014
4015 lbm_char_channel_t *str = lbm_dec_channel(stream);
4016 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4017 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4018 }
4019
4020 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4021
4022 switch(ctx->r) {
4023 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4024 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4025 lbm_set_cdr(last_cell, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate the list
4026 ctx->r = first_cell;
4027 } else {
4028 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4029 }
4030 lbm_stack_drop(&ctx->K, 3);
4031 /* Skip reading another token and apply the continuation */
4032 ctx->app_cont = true1;
4033 return;
4034 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4035 lbm_value *rptr = stack_reserve(ctx, 4);
4036 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4037 rptr[1] = stream;
4038 rptr[2] = lbm_enc_u(0);
4039 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4040 ctx->app_cont = true1;
4041 } return;
4042 }
4043 }
4044 lbm_value new_cell = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4045 if (lbm_is_symbol_merror(new_cell)) {
4046 lbm_channel_reader_close(str);
4047 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4048 return;
4049 }
4050 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4051 lbm_set_cdr(last_cell, new_cell);
4052 last_cell = new_cell;
4053 } else {
4054 first_cell = last_cell = new_cell;
4055 }
4056 sptr[0] = first_cell;
4057 sptr[1] = last_cell;
4058 sptr[2] = stream; // unchanged.
4059 lbm_value *rptr = stack_reserve(ctx, 4);
4060 rptr[0] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
4061 rptr[1] = stream;
4062 rptr[2] = lbm_enc_u(0);
4063 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4064 ctx->app_cont = true1;
4065}
4066
4067static void cont_read_eval_continue(eval_context_t *ctx) {
4068 lbm_value env;
4069 lbm_value stream;
4070 lbm_pop_2(&ctx->K, &env, &stream);
4071
4072 lbm_char_channel_t *str = lbm_dec_channel(stream);
4073 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4074 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4075 }
4076
4077 ctx->row1 = (lbm_int)str->row(str);
4078
4079 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4080
4081 switch(ctx->r) {
4082 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4083 ctx->app_cont = true1;
4084 return;
4085 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4086 // This case is a bit mysterious.
4087 // A dot, may in reality be an error in this location.
4088 lbm_value *rptr = stack_reserve(ctx, 4);
4089 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4090 rptr[1] = stream;
4091 rptr[2] = lbm_enc_u(0);
4092 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4093 ctx->app_cont = true1;
4094 } return;
4095 }
4096 }
4097
4098 lbm_value *rptr = stack_reserve(ctx, 6);
4099 rptr[0] = stream;
4100 rptr[1] = env;
4101 rptr[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
4102 rptr[3] = stream;
4103 rptr[4] = lbm_enc_u(1);
4104 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4105 rptr[6] = lbm_enc_u(ctx->flags);
4106 rptr[7] = POP_READER_FLAGS(((47) << 2) | 0xF8000001u);
4107 ctx->curr_env = env;
4108 ctx->curr_exp = ctx->r;
4109}
4110
4111static void cont_read_expect_closepar(eval_context_t *ctx) {
4112 lbm_value res;
4113 lbm_value stream;
4114
4115 lbm_pop_2(&ctx->K, &res, &stream);
4116
4117 lbm_char_channel_t *str = lbm_dec_channel(stream);
4118 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4119 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4120 }
4121
4122 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4123 ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u)) {
4124 ctx->r = res;
4125 ctx->app_cont = true1;
4126 } else {
4127 lbm_channel_reader_close(str);
4128 lbm_set_error_reason((char*)lbm_error_str_parse_close);
4129 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4130 }
4131}
4132
4133static void cont_read_dot_terminate(eval_context_t *ctx) {
4134 lbm_value *sptr = get_stack_ptr(ctx, 3);
4135
4136 lbm_value first_cell = sptr[0];
4137 lbm_value last_cell = sptr[1];
4138 lbm_value stream = sptr[2];
4139
4140 lbm_char_channel_t *str = lbm_dec_channel(stream);
4141 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4142 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4143 }
4144
4145 lbm_stack_drop(&ctx->K ,3);
4146
4147 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4148 (ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u) ||
4149 ctx->r == ENC_SYM_DOT(((0x76) << 4) | 0x00000000u))) {
4150 lbm_channel_reader_close(str);
4151 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4152 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4153 } else {
4154 if (lbm_is_cons(last_cell)) {
4155 lbm_set_cdr(last_cell, ctx->r);
4156 ctx->r = first_cell;
4157 lbm_value *rptr = stack_reserve(ctx, 6);
4158 rptr[0] = stream;
4159 rptr[1] = ctx->r;
4160 rptr[2] = READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u);
4161 rptr[3] = stream;
4162 rptr[4] = lbm_enc_u(0);
4163 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4164 ctx->app_cont = true1;
4165 } else {
4166 lbm_channel_reader_close(str);
4167 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4168 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4169 }
4170 }
4171}
4172
4173static void cont_read_done(eval_context_t *ctx) {
4174 lbm_value stream;
4175 lbm_value f_val;
4176 lbm_pop_2(&ctx->K, &stream ,&f_val);
4177
4178 uint32_t flags = lbm_dec_as_u32(f_val);
4179 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4180 ctx->flags |= (flags & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4181
4182 lbm_char_channel_t *str = lbm_dec_channel(stream);
4183 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4184 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4185 }
4186
4187 lbm_channel_reader_close(str);
4188 if (lbm_is_symbol(ctx->r)) {
4189 lbm_uint sym_val = lbm_dec_sym(ctx->r);
4190 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
4191 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
4192 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4193 }
4194 }
4195
4196 ctx->row0 = -1;
4197 ctx->row1 = -1;
4198 ctx->app_cont = true1;
4199}
4200
4201static void cont_read_quote_result(eval_context_t *ctx) {
4202 lbm_value cell;
4203 WITH_GC(cell, lbm_heap_allocate_list_init(2,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4204 ENC_SYM_QUOTE,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4205 ctx->r))(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
};
4206 ctx->r = cell;
4207 ctx->app_cont = true1;
4208}
4209
4210static void cont_read_commaat_result(eval_context_t *ctx) {
4211 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4212 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4213 ctx->r = cell1;
4214 ctx->app_cont = true1;
4215}
4216
4217static void cont_read_comma_result(eval_context_t *ctx) {
4218 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u),ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4219 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4220 ctx->r = cell1;
4221 ctx->app_cont = true1;
4222}
4223
4224static void cont_application_start(eval_context_t *ctx) {
4225
4226 /* sptr[0] = env
4227 * sptr[1] = args
4228 * ctx->r = function
4229 */
4230
4231 if (lbm_is_symbol(ctx->r)) {
4232 stack_reserve(ctx,1)[0] = lbm_enc_u(0);
4233 cont_application_args(ctx);
4234 } else if (lbm_is_cons(ctx->r)) {
4235 lbm_uint *sptr = get_stack_ptr(ctx, 2);
4236 lbm_value args = (lbm_value)sptr[1];
4237 switch (get_car(ctx->r)) {
4238 case ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u): {
4239 lbm_value cl[3];
4240 extract_n(get_cdr(ctx->r), cl, 3);
4241 lbm_value arg_env = (lbm_value)sptr[0];
4242 lbm_value arg0, arg_rest;
4243 get_car_and_cdr(args, &arg0, &arg_rest);
4244 sptr[1] = cl[CLO_BODY1];
4245 bool_Bool a_nil = lbm_is_symbol_nil(args);
4246 bool_Bool p_nil = lbm_is_symbol_nil(cl[CLO_PARAMS0]);
4247 lbm_value *reserved = stack_reserve(ctx, 4);
4248
4249 if (!a_nil && !p_nil) {
4250 reserved[0] = cl[CLO_ENV2];
4251 reserved[1] = cl[CLO_PARAMS0];
4252 reserved[2] = arg_rest;
4253 reserved[3] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
4254 ctx->curr_exp = arg0;
4255 ctx->curr_env = arg_env;
4256 } else if (a_nil && p_nil) {
4257 // No params, No args
4258 lbm_stack_drop(&ctx->K, 6);
4259 ctx->curr_exp = cl[CLO_BODY1];
4260 ctx->curr_env = cl[CLO_ENV2];
4261 } else if (p_nil) {
4262 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), cl[CLO_ENV2]);
4263 reserved[0] = rest_binder;
4264 reserved[1] = get_cdr(args);
4265 reserved[2] = get_car(rest_binder);
4266 reserved[3] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
4267 ctx->curr_exp = get_car(args);
4268 ctx->curr_env = arg_env;
4269 } else {
4270 lbm_set_error_reason((char*)lbm_error_str_num_args);
4271 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->r);
4272 }
4273 } break;
4274 case ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u):{
4275 /* Continuation created using call-cc.
4276 * ((SYM_CONT . cont-array) arg0 )
4277 */
4278 lbm_value c = get_cdr(ctx->r); /* should be the continuation array*/
4279
4280 if (!lbm_is_lisp_array_r(c)) {
4281 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4282 }
4283
4284 lbm_uint arg_count = lbm_list_length(args);
4285 lbm_value arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4286 switch (arg_count) {
4287 case 0:
4288 arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4289 break;
4290 case 1:
4291 arg = get_car(args);
4292 break;
4293 default:
4294 lbm_set_error_reason((char*)lbm_error_str_num_args);
4295 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4296 }
4297 lbm_stack_clear(&ctx->K);
4298
4299 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(c);
4300
4301 ctx->K.sp = arr->size / sizeof(lbm_uint);
4302 memcpy(ctx->K.data, arr->data, arr->size);
4303
4304 ctx->curr_exp = arg;
4305 break;
4306 }
4307 case ENC_SYM_MACRO(((0x10D) << 4) | 0x00000000u):{
4308 /*
4309 * Perform macro expansion.
4310 * Macro expansion is really just evaluation in an
4311 * environment augmented with the unevaluated expressions passed
4312 * as arguments.
4313 */
4314 lbm_value env = (lbm_value)sptr[0];
4315
4316 lbm_value curr_param = get_cadr(ctx->r);
4317 lbm_value curr_arg = args;
4318 lbm_value expand_env = env;
4319 while (lbm_is_cons(curr_param) &&
4320 lbm_is_cons(curr_arg)) {
4321 lbm_value car_curr_param, cdr_curr_param;
4322 lbm_value car_curr_arg, cdr_curr_arg;
4323 get_car_and_cdr(curr_param, &car_curr_param, &cdr_curr_param);
4324 get_car_and_cdr(curr_arg, &car_curr_arg, &cdr_curr_arg);
4325
4326 lbm_value entry = cons_with_gc(car_curr_param, car_curr_arg, expand_env);
4327 lbm_value aug_env = cons_with_gc(entry, expand_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4328 expand_env = aug_env;
4329
4330 curr_param = cdr_curr_param;
4331 curr_arg = cdr_curr_arg;
4332 }
4333 /* Two rounds of evaluation is performed.
4334 * First to instantiate the arguments into the macro body.
4335 * Second to evaluate the resulting program.
4336 */
4337 sptr[1] = EVAL_R(((11) << 2) | 0xF8000001u);
4338 lbm_value exp = get_cadr(get_cdr(ctx->r));
4339 ctx->curr_exp = exp;
4340 ctx->curr_env = expand_env;
4341 } break;
4342 default:
4343 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4344 }
4345 } else {
4346 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4347 }
4348}
4349
4350static void cont_eval_r(eval_context_t* ctx) {
4351 lbm_value env;
4352 lbm_pop(&ctx->K, &env);
4353 ctx->curr_exp = ctx->r;
4354 ctx->curr_env = env;
4355}
4356
4357static void cont_progn_var(eval_context_t* ctx) {
4358
4359 lbm_value key;
4360 lbm_value env;
4361
4362 lbm_pop_2(&ctx->K, &key, &env);
4363
4364 if (fill_binding_location(key, ctx->r, env) < 0) {
4365 lbm_set_error_reason("Incorrect type of name/key in let-binding");
4366 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
4367 }
4368
4369 ctx->app_cont = true1;
4370}
4371
4372static void cont_setq(eval_context_t *ctx) {
4373 lbm_value sym;
4374 lbm_value env;
4375 lbm_pop_2(&ctx->K, &sym, &env);
4376 lbm_value res;
4377 WITH_GC(res, perform_setvar(sym, ctx->r, env))(res) = (perform_setvar(sym, ctx->r, env)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (perform_setvar(sym, ctx->r, env)
); if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
4378 ctx->r = res;
4379 ctx->app_cont = true1;
4380}
4381
4382lbm_flash_status request_flash_storage_cell(lbm_value val, lbm_value *res) {
4383
4384 lbm_value flash_cell;
4385 lbm_flash_status s = lbm_allocate_const_cell(&flash_cell);
4386 if (s != LBM_FLASH_WRITE_OK)
4387 return s;
4388 lbm_value new_val = val;
4389 new_val &= ~LBM_PTR_VAL_MASK0x03FFFFFCu; // clear the value part of the ptr
4390 new_val |= (flash_cell & LBM_PTR_VAL_MASK0x03FFFFFCu);
4391 new_val |= LBM_PTR_TO_CONSTANT_BIT0x04000000u;
4392 *res = new_val;
4393 return s;
4394}
4395
4396static void cont_move_to_flash(eval_context_t *ctx) {
4397
4398 lbm_value args;
4399 lbm_pop(&ctx->K, &args);
4400
4401 if (lbm_is_symbol_nil(args)) {
4402 // Done looping over arguments. return true.
4403 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
4404 ctx->app_cont = true1;
4405 return;
4406 }
4407
4408 lbm_value first_arg, rest;
4409 get_car_and_cdr(args, &first_arg, &rest);
4410
4411 lbm_value val;
4412 if (lbm_is_symbol(first_arg) && lbm_global_env_lookup(&val, first_arg)) {
4413 // Prepare to copy the rest of the arguments when done with first.
4414 lbm_value *rptr = stack_reserve(ctx, 2);
4415 rptr[0] = rest;
4416 rptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
4417 if (lbm_is_ptr(val) &&
4418 (!(val & LBM_PTR_TO_CONSTANT_BIT0x04000000u))) {
4419 lbm_value * rptr1 = stack_reserve(ctx, 3);
4420 rptr1[0] = first_arg;
4421 rptr1[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
4422 rptr1[2] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4423 ctx->r = val;
4424 }
4425 ctx->app_cont = true1;
4426 return;
4427 }
4428 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4429}
4430
4431static void cont_move_val_to_flash_dispatch(eval_context_t *ctx) {
4432
4433 lbm_value val = ctx->r;
4434
4435 if (lbm_is_cons(val)) {
4436 lbm_value *rptr = stack_reserve(ctx, 5);
4437 rptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // fst cell of list
4438 rptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last cell of list
4439 rptr[2] = get_cdr(val);
4440 rptr[3] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4441 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4442 ctx->r = get_car(val);
4443 ctx->app_cont = true1;
4444 return;
4445 }
4446
4447 if (lbm_is_ptr(val) && (val & LBM_PTR_TO_CONSTANT_BIT0x04000000u)) {
4448 ctx->r = val;
4449 ctx->app_cont = true1;
4450 return;
4451 }
4452
4453 if (lbm_is_ptr(val)) {
4454 lbm_cons_t *ref = lbm_ref_cell(val);
4455 if (lbm_type_of(ref->cdr) == LBM_TYPE_SYMBOL0x00000000u) {
4456 switch (ref->cdr) {
4457 case ENC_SYM_RAW_I_TYPE(((0x31) << 4) | 0x00000000u): /* fall through */
4458 case ENC_SYM_RAW_U_TYPE(((0x32) << 4) | 0x00000000u):
4459 case ENC_SYM_RAW_F_TYPE(((0x33) << 4) | 0x00000000u): {
4460 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4461 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4462 handle_flash_status(write_const_car(flash_cell, ref->car));
4463 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4464 ctx->r = flash_cell;
4465 } break;
4466 case ENC_SYM_IND_I_TYPE(((0x34) << 4) | 0x00000000u): /* fall through */
4467 case ENC_SYM_IND_U_TYPE(((0x35) << 4) | 0x00000000u):
4468 case ENC_SYM_IND_F_TYPE(((0x36) << 4) | 0x00000000u): {
4469#ifndef LBM64
4470 /* 64 bit values are in lbm mem on 32bit platforms. */
4471 lbm_uint *lbm_mem_ptr = (lbm_uint*)ref->car;
4472 lbm_uint flash_ptr;
4473
4474 handle_flash_status(lbm_write_const_raw(lbm_mem_ptr, 2, &flash_ptr));
4475 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4476 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4477 handle_flash_status(write_const_car(flash_cell, flash_ptr));
4478 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4479 ctx->r = flash_cell;
4480#else
4481 // There are no indirect types in LBM64
4482 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4483#endif
4484 } break;
4485 case ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u): {
4486 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4487 lbm_uint size = arr->size / sizeof(lbm_uint);
4488 lbm_uint flash_addr;
4489 lbm_value *arrdata = (lbm_value *)arr->data;
4490 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4491 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4492 handle_flash_status(lbm_allocate_const_raw(size, &flash_addr));
4493 lift_array_flash(flash_cell,
4494 false0,
4495 (char *)flash_addr,
4496 arr->size);
4497 // Move array contents to flash recursively
4498 lbm_value *rptr = stack_reserve(ctx, 5);
4499 rptr[0] = flash_cell;
4500 rptr[1] = lbm_enc_u(0);
4501 rptr[2] = val;
4502 rptr[3] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4503 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4504 ctx->r = arrdata[0];
4505 ctx->app_cont = true1;
4506 return;
4507 }
4508 case ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u): {
4509 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4510 // arbitrary address: flash_arr.
4511 lbm_uint flash_arr;
4512 handle_flash_status(lbm_write_const_array_padded((uint8_t*)arr->data, arr->size, &flash_arr));
4513 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4514 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4515 lift_array_flash(flash_cell,
4516 true1,
4517 (char *)flash_arr,
4518 arr->size);
4519 ctx->r = flash_cell;
4520 } break;
4521 case ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u): /* fall through */
4522 case ENC_SYM_CUSTOM_TYPE(((0x38) << 4) | 0x00000000u):
4523 lbm_set_error_reason((char *)lbm_error_str_flash_not_possible);
4524 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4525 }
4526 } else {
4527 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4528 }
4529 ctx->app_cont = true1;
4530 return;
4531 }
4532 ctx->r = val;
4533 ctx->app_cont = true1;
4534}
4535
4536static void cont_move_list_to_flash(eval_context_t *ctx) {
4537
4538 // ctx->r holds the value that should go in car
4539
4540 lbm_value *sptr = get_stack_ptr(ctx, 3);
4541
4542 lbm_value fst = sptr[0];
4543 lbm_value lst = sptr[1];
4544 lbm_value val = sptr[2];
4545
4546
4547 lbm_value new_lst = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4548 // Allocate element ptr storage after storing the element to flash.
4549 handle_flash_status(request_flash_storage_cell(lbm_enc_cons_ptr(LBM_PTR_NULL(0x03FFFFFCu >> 2)), &new_lst));
4550
4551 if (lbm_is_symbol_nil(fst)) {
4552 lst = new_lst;
4553 fst = new_lst;
4554 handle_flash_status(write_const_car(lst, ctx->r));
4555 } else {
4556 handle_flash_status(write_const_cdr(lst, new_lst)); // low before high
4557 handle_flash_status(write_const_car(new_lst, ctx->r));
4558 lst = new_lst;
4559 }
4560
4561 if (lbm_is_cons(val)) {
4562 sptr[0] = fst;
4563 sptr[1] = lst;//rest_cell;
4564 sptr[2] = get_cdr(val);
4565 lbm_value *rptr = stack_reserve(ctx, 2);
4566 rptr[0] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4567 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4568 ctx->r = get_car(val);
4569 } else {
4570 sptr[0] = fst;
4571 sptr[1] = lst;
4572 sptr[2] = CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u);
4573 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4574 ctx->r = val;
4575 }
4576 ctx->app_cont = true1;
4577}
4578
4579static void cont_close_list_in_flash(eval_context_t *ctx) {
4580 lbm_value fst;
4581 lbm_value lst;
4582 lbm_pop_2(&ctx->K, &lst, &fst);
4583 lbm_value val = ctx->r;
4584 handle_flash_status(write_const_cdr(lst, val));
4585 ctx->r = fst;
4586 ctx->app_cont = true1;
4587}
4588
4589static void cont_move_array_elts_to_flash(eval_context_t *ctx) {
4590 lbm_value *sptr = get_stack_ptr(ctx, 3);
4591 // sptr[2] = source array in RAM
4592 // sptr[1] = current index
4593 // sptr[0] = target array in flash
4594 lbm_array_header_t *src_arr = (lbm_array_header_t*)get_car(sptr[2]);
4595 lbm_uint size = src_arr->size / sizeof(lbm_uint);
4596 lbm_value *srcdata = (lbm_value *)src_arr->data;
4597
4598 lbm_array_header_t *tgt_arr = (lbm_array_header_t*)get_car(sptr[0]);
4599 lbm_uint *tgtdata = (lbm_value *)tgt_arr->data;
4600 lbm_uint ix = lbm_dec_as_u32(sptr[1]);
4601 handle_flash_status(lbm_const_write(&tgtdata[ix], ctx->r));
4602 if (ix >= size-1) {
4603 ctx->r = sptr[0];
4604 lbm_stack_drop(&ctx->K, 3);
4605 ctx->app_cont = true1;
4606 return;
4607 }
4608 sptr[1] = lbm_enc_u(ix + 1);
4609 lbm_value *rptr = stack_reserve(ctx, 2);
4610 rptr[0] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4611 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4612 ctx->r = srcdata[ix+1];
4613 ctx->app_cont = true1;
4614 return;
4615}
4616
4617static void cont_qq_expand_start(eval_context_t *ctx) {
4618 lbm_value *rptr = stack_reserve(ctx, 2);
4619 rptr[0] = ctx->r;
4620 rptr[1] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4621 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4622 ctx->app_cont = true1;
4623}
4624
4625lbm_value quote_it(lbm_value qquoted) {
4626 if (lbm_is_symbol(qquoted) &&
4627 lbm_is_special(qquoted)) return qquoted;
4628
4629 lbm_value val = cons_with_gc(qquoted, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4630 return cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4631}
4632
4633bool_Bool is_append(lbm_value a) {
4634 return (lbm_is_cons(a) &&
4635 lbm_is_symbol(get_car(a)) &&
4636 (get_car(a) == ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u)));
4637}
4638
4639lbm_value append(lbm_value front, lbm_value back) {
4640 if (lbm_is_symbol_nil(front)) return back;
4641 if (lbm_is_symbol_nil(back)) return front;
4642
4643 if (lbm_is_quoted_list(front) &&
4644 lbm_is_quoted_list(back)) {
4645 lbm_value f = get_cadr(front);
4646 lbm_value b = get_cadr(back);
4647 return quote_it(lbm_list_append(f, b));
4648 }
4649
4650 if (is_append(back) &&
4651 lbm_is_quoted_list(get_cadr(back)) &&
4652 lbm_is_quoted_list(front)) {
4653 lbm_value ql = get_cadr(back);
4654 lbm_value f = get_cadr(front);
4655 lbm_value b = get_cadr(ql);
4656
4657 lbm_value v = lbm_list_append(f, b);
4658 lbm_set_car(get_cdr(ql), v);
4659 return back;
4660 }
4661
4662 if (is_append(back)) {
4663 back = get_cdr(back);
4664 lbm_value new = cons_with_gc(front, back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4665 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), new, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4666 }
4667
4668 lbm_value t0, t1;
4669
4670 t0 = cons_with_gc(back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), front);
4671 t1 = cons_with_gc(front, t0, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4672 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), t1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4673}
4674
4675/* Bawden's qq-expand implementation
4676(define (qq-expand x)
4677 (cond ((tag-comma? x)
4678 (tag-data x))
4679 ((tag-comma-atsign? x)
4680 (error "Illegal"))
4681 ((tag-backquote? x)
4682 (qq-expand
4683 (qq-expand (tag-data x))))
4684 ((pair? x)
4685 `(append
4686 ,(qq-expand-list (car x))
4687 ,(qq-expand (cdr x))))
4688 (else `',x)))
4689 */
4690static void cont_qq_expand(eval_context_t *ctx) {
4691 lbm_value qquoted;
4692 lbm_pop(&ctx->K, &qquoted);
4693
4694 switch(lbm_type_of(qquoted)) {
4695 case LBM_TYPE_CONS0x10000000u: {
4696 lbm_value car_val = get_car(qquoted);
4697 lbm_value cdr_val = get_cdr(qquoted);
4698 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4699 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4700 ctx->r = append(ctx->r, get_car(cdr_val));
4701 ctx->app_cont = true1;
4702 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4703 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4704 error_ctx(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u));
4705 } else {
4706 lbm_value *rptr = stack_reserve(ctx, 6);
4707 rptr[0] = ctx->r;
4708 rptr[1] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4709 rptr[2] = cdr_val;
4710 rptr[3] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4711 rptr[4] = car_val;
4712 rptr[5] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4713 ctx->app_cont = true1;
4714 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4715 }
4716
4717 } break;
4718 default: {
4719 lbm_value res = quote_it(qquoted);
4720 ctx->r = append(ctx->r, res);
4721 ctx->app_cont = true1;
4722 }
4723 }
4724}
4725
4726static void cont_qq_append(eval_context_t *ctx) {
4727 lbm_value head;
4728 lbm_pop(&ctx->K, &head);
4729 ctx->r = append(head, ctx->r);
4730 ctx->app_cont = true1;
4731}
4732
4733/* Bawden's qq-expand-list implementation
4734(define (qq-expand-list x)
4735 (cond ((tag-comma? x)
4736 `(list ,(tag-data x)))
4737 ((tag-comma-atsign? x)
4738 (tag-data x))
4739 ((tag-backquote? x)
4740 (qq-expand-list
4741 (qq-expand (tag-data x))))
4742 ((pair? x)
4743 `(list
4744 (append
4745 ,(qq-expand-list (car x))
4746 ,(qq-expand (cdr x)))))
4747 (else `'(,x))))
4748*/
4749
4750static void cont_qq_expand_list(eval_context_t* ctx) {
4751 lbm_value l;
4752 lbm_pop(&ctx->K, &l);
4753
4754 ctx->app_cont = true1;
4755 switch(lbm_type_of(l)) {
4756 case LBM_TYPE_CONS0x10000000u: {
4757 lbm_value car_val = get_car(l);
4758 lbm_value cdr_val = get_cdr(l);
4759 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4760 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4761 lbm_value tl = cons_with_gc(get_car(cdr_val), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4762 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4763 ctx->r = append(ctx->r, tmp);
4764 return;
4765 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4766 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4767 ctx->r = get_car(cdr_val);
4768 return;
4769 } else {
4770 lbm_value *rptr = stack_reserve(ctx, 7);
4771 rptr[0] = QQ_LIST(((39) << 2) | 0xF8000001u);
4772 rptr[1] = ctx->r;
4773 rptr[2] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4774 rptr[3] = cdr_val;
4775 rptr[4] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4776 rptr[5] = car_val;
4777 rptr[6] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4778 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4779 }
4780
4781 } break;
4782 default: {
4783 lbm_value a_list = cons_with_gc(l, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4784 lbm_value tl = cons_with_gc(a_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4785 lbm_value tmp = cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4786 ctx->r = append(ctx->r, tmp);
4787 }
4788 }
4789}
4790
4791static void cont_qq_list(eval_context_t *ctx) {
4792 lbm_value val = ctx->r;
4793 lbm_value apnd_app = cons_with_gc(val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4794 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), apnd_app, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4795 ctx->r = tmp;
4796 ctx->app_cont = true1;
4797}
4798
4799static void cont_kill(eval_context_t *ctx) {
4800 (void) ctx;
4801 finish_ctx();
4802}
4803
4804static void cont_pop_reader_flags(eval_context_t *ctx) {
4805 lbm_value flags;
4806 lbm_pop(&ctx->K, &flags);
4807 ctx->flags = ctx->flags & ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4808 ctx->flags |= (lbm_dec_as_u32(flags) & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4809 // r is unchanged.
4810 ctx->app_cont = true1;
4811}
4812
4813static void cont_exception_handler(eval_context_t *ctx) {
4814 lbm_value *sptr = pop_stack_ptr(ctx, 2);
4815 lbm_value retval = sptr[0];
4816 lbm_value flags = sptr[1];
4817 lbm_set_car(get_cdr(retval), ctx->r);
4818 ctx->flags = flags;
4819 ctx->r = retval;
4820 ctx->app_cont = true1;
4821}
4822
4823/*********************************************************/
4824/* Continuations table */
4825typedef void (*cont_fun)(eval_context_t *);
4826
4827static const cont_fun continuations[NUM_CONTINUATIONS49] =
4828 { advance_ctx, // CONT_DONE
4829 cont_set_global_env,
4830 cont_bind_to_key_rest,
4831 cont_if,
4832 cont_progn_rest,
4833 cont_application_args,
4834 cont_and,
4835 cont_or,
4836 cont_wait,
4837 cont_match,
4838 cont_application_start,
4839 cont_eval_r,
4840 cont_resume,
4841 cont_closure_application_args,
4842 cont_exit_atomic,
4843 cont_read_next_token,
4844 cont_read_append_continue,
4845 cont_read_eval_continue,
4846 cont_read_expect_closepar,
4847 cont_read_dot_terminate,
4848 cont_read_done,
4849 cont_read_quote_result,
4850 cont_read_commaat_result,
4851 cont_read_comma_result,
4852 cont_read_start_array,
4853 cont_read_append_array,
4854 cont_map,
4855 cont_match_guard,
4856 cont_terminate,
4857 cont_progn_var,
4858 cont_setq,
4859 cont_move_to_flash,
4860 cont_move_val_to_flash_dispatch,
4861 cont_move_list_to_flash,
4862 cont_close_list_in_flash,
4863 cont_qq_expand_start,
4864 cont_qq_expand,
4865 cont_qq_append,
4866 cont_qq_expand_list,
4867 cont_qq_list,
4868 cont_kill,
4869 cont_loop,
4870 cont_loop_condition,
4871 cont_merge_rest,
4872 cont_merge_layer,
4873 cont_closure_args_rest,
4874 cont_move_array_elts_to_flash,
4875 cont_pop_reader_flags,
4876 cont_exception_handler
4877 };
4878
4879/*********************************************************/
4880/* Evaluators lookup table (special forms) */
4881typedef void (*evaluator_fun)(eval_context_t *);
4882
4883static const evaluator_fun evaluators[] =
4884 {
4885 eval_quote,
4886 eval_define,
4887 eval_progn,
4888 eval_lambda,
4889 eval_if,
4890 eval_let,
4891 eval_and,
4892 eval_or,
4893 eval_match,
4894 eval_receive,
4895 eval_receive_timeout,
4896 eval_callcc,
4897 eval_atomic,
4898 eval_selfevaluating, // macro
4899 eval_selfevaluating, // cont
4900 eval_selfevaluating, // closure
4901 eval_cond,
4902 eval_app_cont,
4903 eval_var,
4904 eval_setq,
4905 eval_move_to_flash,
4906 eval_loop,
4907 eval_trap
4908 };
4909
4910
4911/*********************************************************/
4912/* Evaluator step function */
4913
4914static void evaluation_step(void){
4915 eval_context_t *ctx = ctx_running;
4916#ifdef VISUALIZE_HEAP
4917 heap_vis_gen_image();
4918#endif
4919
4920 if (ctx->app_cont) {
4921 lbm_value k;
4922 lbm_pop(&ctx->K, &k);
4923 ctx->app_cont = false0;
4924
4925 lbm_uint decoded_k = DEC_CONTINUATION(k)(((k) & ~0xF8000001u) >> 2);
4926
4927 if (decoded_k < NUM_CONTINUATIONS49) {
4928 continuations[decoded_k](ctx);
4929 } else {
4930 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4931 }
4932 return;
4933 }
4934
4935 if (lbm_is_symbol(ctx->curr_exp)) {
4936 eval_symbol(ctx);
4937 return;
4938 }
4939 if (lbm_is_cons(ctx->curr_exp)) {
4940 lbm_cons_t *cell = lbm_ref_cell(ctx->curr_exp);
4941 lbm_value h = cell->car;
4942 if (lbm_is_symbol(h) && ((h & ENC_SPECIAL_FORMS_MASK0xFFFFF000) == ENC_SPECIAL_FORMS_BIT0x00001000)) {
4943 lbm_uint eval_index = lbm_dec_sym(h) & SPECIAL_FORMS_INDEX_MASK0x000000FF;
4944 evaluators[eval_index](ctx);
4945 return;
4946 }
4947 /*
4948 * At this point head can be anything. It should evaluate
4949 * into a form that can be applied (closure, symbol, ...) though.
4950 */
4951 lbm_value *reserved = stack_reserve(ctx, 3);
4952 reserved[0] = ctx->curr_env;
4953 reserved[1] = cell->cdr;
4954 reserved[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
4955 ctx->curr_exp = h; // evaluate the function
4956 return;
4957 }
4958
4959 eval_selfevaluating(ctx);
4960 return;
4961}
4962
4963void lbm_pause_eval(void ) {
4964 eval_cps_next_state_arg = 0;
4965 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4966 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4967}
4968
4969void lbm_pause_eval_with_gc(uint32_t num_free) {
4970 eval_cps_next_state_arg = num_free;
4971 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4972 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4973}
4974
4975void lbm_continue_eval(void) {
4976 eval_cps_next_state = EVAL_CPS_STATE_RUNNING2;
4977 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4978}
4979
4980void lbm_kill_eval(void) {
4981 eval_cps_next_state = EVAL_CPS_STATE_KILL4;
4982 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4983}
4984
4985uint32_t lbm_get_eval_state(void) {
4986 return eval_cps_run_state;
4987}
4988
4989// Will wake up thread that is sleeping as well.
4990// Not sure this is good behavior.
4991static void handle_event_unblock_ctx(lbm_cid cid, lbm_value v) {
4992 eval_context_t *found = NULL((void*)0);
4993 mutex_lock(&qmutex);
4994
4995 found = lookup_ctx_nm(&blocked, cid);
4996 if (found) {
4997 drop_ctx_nm(&blocked,found);
4998 if (lbm_is_error(v)) {
4999 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
5000 found->app_cont = true1;
5001 }
5002 found->r = v;
5003 enqueue_ctx_nm(&queue,found);
5004 }
5005 mutex_unlock(&qmutex);
5006}
5007
5008static void handle_event_define(lbm_value key, lbm_value val) {
5009 lbm_uint dec_key = lbm_dec_sym(key);
5010 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
5011 lbm_value *global_env = lbm_get_global_env();
5012 lbm_uint orig_env = global_env[ix_key];
5013 lbm_value new_env;
5014 // A key is a symbol and should not need to be remembered.
5015 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
5016
5017 global_env[ix_key] = new_env;
5018}
5019
5020static lbm_value get_event_value(lbm_event_t *e) {
5021 lbm_value v;
5022 if (e->buf_len > 0) {
5023 lbm_flat_value_t fv;
5024 fv.buf = (uint8_t*)e->buf_ptr;
5025 fv.buf_size = e->buf_len;
5026 fv.buf_pos = 0;
5027 if (!lbm_unflatten_value(&fv, &v)) {
5028 lbm_set_flags(LBM_FLAG_HANDLER_EVENT_DELIVERY_FAILED(1 << 1));
5029 v = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
5030 }
5031 // Free the flat value buffer. GC is unaware of its existence.
5032 lbm_free(fv.buf);
5033 } else {
5034 v = (lbm_value)e->buf_ptr;
5035 }
5036 return v;
5037}
5038
5039static void process_events(void) {
5040
5041 if (!lbm_events) return;
5042 lbm_event_t e;
5043
5044 while (lbm_event_pop(&e)) {
5045
5046 lbm_value event_val = get_event_value(&e);
5047 switch(e.type) {
5048 case LBM_EVENT_UNBLOCK_CTX:
5049 handle_event_unblock_ctx((lbm_cid)e.parameter, event_val);
5050 break;
5051 case LBM_EVENT_DEFINE:
5052 handle_event_define((lbm_value)e.parameter, event_val);
5053 break;
5054 case LBM_EVENT_FOR_HANDLER:
5055 if (lbm_event_handler_pid >= 0) {
5056 lbm_find_receiver_and_send(lbm_event_handler_pid, event_val);
5057 }
5058 break;
5059 }
5060 }
5061}
5062
5063/* eval_cps_run can be paused
5064 I think it would be better use a mailbox for
5065 communication between other threads and the run_eval
5066 but for now a set of variables will be used. */
5067void lbm_run_eval(void){
5068
5069 if (setjmp(critical_error_jmp_buf)_setjmp (critical_error_jmp_buf) > 0) {
5070 printf_callback("GC stack overflow!\n");
5071 critical_error_callback();
5072 // terminate evaluation thread.
5073 return;
5074 }
5075
5076 setjmp(error_jmp_buf)_setjmp (error_jmp_buf);
5077
5078 while (eval_running) {
5079 if (eval_cps_state_changed || eval_cps_run_state == EVAL_CPS_STATE_PAUSED1) {
5080 eval_cps_state_changed = false0;
5081 switch (eval_cps_next_state) {
5082 case EVAL_CPS_STATE_PAUSED1:
5083 if (eval_cps_run_state != EVAL_CPS_STATE_PAUSED1) {
5084 if (lbm_heap_num_free() < eval_cps_next_state_arg) {
5085 gc();
5086 }
5087 eval_cps_next_state_arg = 0;
5088 }
5089 eval_cps_run_state = EVAL_CPS_STATE_PAUSED1;
5090 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5091 continue; /* jump back to start of eval_running loop */
5092 case EVAL_CPS_STATE_KILL4:
5093 eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
5094 eval_running = false0;
5095 continue;
5096 default: // running state
5097 eval_cps_run_state = eval_cps_next_state;
5098 break;
5099 }
5100 }
5101 while (true1) {
5102 if (eval_steps_quota && ctx_running) {
5103 eval_steps_quota--;
5104 evaluation_step();
5105 } else {
5106 if (eval_cps_state_changed) break;
5107 eval_steps_quota = eval_steps_refill;
5108 if (is_atomic) {
5109 if (!ctx_running) {
5110 lbm_set_flags(LBM_FLAG_ATOMIC_MALFUNCTION(1 << 0));
5111 is_atomic = 0;
5112 }
5113 } else {
5114 if (gc_requested) {
5115 gc();
5116 }
5117 process_events();
5118 mutex_lock(&qmutex);
5119 if (ctx_running) {
5120 enqueue_ctx_nm(&queue, ctx_running);
5121 ctx_running = NULL((void*)0);
5122 }
5123 wake_up_ctxs_nm();
5124 ctx_running = dequeue_ctx_nm(&queue);
5125 mutex_unlock(&qmutex);
5126 if (!ctx_running) {
5127 lbm_system_sleeping = true1;
5128 //Fixed sleep interval to poll events regularly.
5129 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5130 lbm_system_sleeping = false0;
5131 }
5132 }
5133 }
5134 }
5135 }
5136}
5137
5138lbm_cid lbm_eval_program(lbm_value lisp) {
5139 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), 256, NULL((void*)0));
5140}
5141
5142lbm_cid lbm_eval_program_ext(lbm_value lisp, unsigned int stack_size) {
5143 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), stack_size, NULL((void*)0));
5144}
5145
5146int lbm_eval_init() {
5147 if (!qmutex_initialized) {
5148 mutex_init(&qmutex);
5149 qmutex_initialized = true1;
5150 }
5151 if (!lbm_events_mutex_initialized) {
5152 mutex_init(&lbm_events_mutex);
5153 lbm_events_mutex_initialized = true1;
5154 }
5155 if (!blocking_extension_mutex_initialized) {
5156 mutex_init(&blocking_extension_mutex);
5157 blocking_extension_mutex_initialized = true1;
5158 }
5159
5160 mutex_lock(&qmutex);
5161 mutex_lock(&lbm_events_mutex);
5162
5163 blocked.first = NULL((void*)0);
5164 blocked.last = NULL((void*)0);
5165 queue.first = NULL((void*)0);
5166 queue.last = NULL((void*)0);
5167 ctx_running = NULL((void*)0);
5168
5169 eval_cps_run_state = EVAL_CPS_STATE_RUNNING2;
5170
5171 mutex_unlock(&lbm_events_mutex);
5172 mutex_unlock(&qmutex);
5173
5174 if (!lbm_init_env()) return 0;
5175 eval_running = true1;
5176 return 1;
5177}
5178
5179bool_Bool lbm_eval_init_events(unsigned int num_events) {
5180
5181 mutex_lock(&lbm_events_mutex);
5182 lbm_events = (lbm_event_t*)lbm_malloc(num_events * sizeof(lbm_event_t));
5183 bool_Bool r = false0;
5184 if (lbm_events) {
5185 lbm_events_max = num_events;
5186 lbm_events_head = 0;
5187 lbm_events_tail = 0;
5188 lbm_events_full = false0;
5189 lbm_event_handler_pid = -1;
5190 r = true1;
5191 }
5192 mutex_unlock(&lbm_events_mutex);
5193 return r;
5194}
+
+
←

./include/heap.h

+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1
2/*
3 Copyright 2018, 2024 Joel Svensson svenssonjoel@yahoo.se
4
5 This program is free software: you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation, either version 3 of the License, or
8 (at your option) any later version.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
14
15 You should have received a copy of the GNU General Public License
16 along with this program. If not, see <http://www.gnu.org/licenses/>.
17*/
18/** \file heap.h */
19
20#ifndef HEAP_H_
21#define HEAP_H_
22
23#include <string.h>
24#include <stdarg.h>
25
26#include "lbm_types.h"
27#include "symrepr.h"
28#include "stack.h"
29#include "lbm_memory.h"
30#include "lbm_defines.h"
31#include "lbm_channel.h"
32
33#ifdef __cplusplus
34extern "C" {
35#endif
36
37/*
38Planning for a more space efficient heap representation.
39TODO: Need to find a good reference to read up on this.
40 - List based heap
41 - Easy to implement and somewhat efficient
42
430000 0000 Size Free bits
44003F FFFF 4MB 10
45007F FFFF 8MB 9
4600FF FFFF 16MB 8
4701FF FFFF 32MB 7
4803FF FFFF 64MB 6 * Kind of heap size I am looking for
4907FF FFFF 128MB 5
500FFF FFFF 256MB 4
511FFF FFFF 512MB 3
52
53
54--- May 9 2021 ---
55Actually now I am much more interested in way smaller memories ;)
56
570000 0000 Size Free bits
580000 0FFF 4KB 20 |
590000 1FFF 8KB 19 |
600000 3FFF 16KB 18 |
610000 7FFF 32KB 17 |
620000 FFFF 64KB 16 |
630001 FFFF 128KB 15 |
640003 FFFF 256KB 14 | - This range is very interesting.
650007 FFFF 512KB 13
66000F FFFF 1MB 12
67001F FFFF 2MB 11
68003F FFFF 4MB 10
69007F FFFF 8MB 9
7000FF FFFF 16MB 8
7101FF FFFF 32MB 7
7203FF FFFF 64MB 6
7307FF FFFF 128MB 5
740FFF FFFF 256MB 4
751FFF FFFF 512MB 3
76
77Those are the kind of platforms that are fun... so a bunch of
78wasted bits in heap pointers if we run on small MCUs.
79
80-----------------
81
82it is also the case that not all addresses will be used if all "cells" are
83of the same size, 8 bytes...
84
85value 0: 0000 0000
86value 1: 0000 0008
87value 3: 0000 0010
88value 4: 0000 0018
89
90Means bits 0,1,2 will always be empty in a valid address.
91
92Cons cells also need to be have room for 2 pointers. So each ted cell from
93memory should be 8bytes.
94
95Things that needs to be represented within these bits:
96
97 - GC MARK one per cell
98 - TYPE: type of CAR and type of cons
99
100Types I would want:
101 - Full 32bit integer. Does not leave room for identification of type
102 - Float values. Same problem
103
104
105Free bits in pointers 64MB heap:
10631 30 29 28 27 26 2 1 0
1070 0 0 0 0 0 XX XXXX XXXX XXXX XXXX XXXX X 0 0 0
108
109
110Information needed for each cell:
111 Meaning | bits total | bits per car | bits per cdr
112 GC mark | 2 | 1 | 1 - only one of them will be used (the other is wasted)
113 Type | 2x | x | x
114 Ptr/!ptr | 2 | 1 | 1
115
116
117Types (unboxed):
118 - Symbols
119 - 28bit integer ( will need signed shift right functionality )
120 - 28bit unsigned integer
121 - Character
122
123If four types is all that should be possible (unboxed). then 2 bits are needed to differentiate.
1242 + 1 + 1 = 4 => 28bits for data.
125
126bit 0: ptr/!ptr
127bit 1: gc
128bit 2-3: type (if not ptr)
129bit 3 - 24 ptr (if ptr)
130bit 4 - 31 value (if value)
131
132An unboxed value can occupy a car or cdr field in a cons cell.
133
134types (boxed) extra information in pointer to cell can contain information
135 - 32 bit integer
136 - 32 bit unsigned integer
137 - 32 bit float
138
139boxed representation:
140 [ptr| cdr]
141 |
142 [Value | Aux + GC_MARK]
143
144Kinds of pointers:
145 - Pointer to cons cell.
146 - Pointer to unboxed value (fixnums not in a list, I hope this is so rare that it can be removed )
147 - integer
148 - unsigned integer
149 - symbol
150 - float
151 - Pointer to boxed value.
152 - 32 bit integer
153 - 32 bit unsigned integer
154 - 32 bit float
155 - (Maybe something else ? Vectors/strings allocated in memory not occupied by heap?)
156 - vector of int
157 - vector of uint
158 - vector of float
159 - vector of double
160 - String
161
16213 pointer"types" -> needs 4 bits
163for 64MB heap there are 6 free bits. So with this scheme going to 128MB or 256MB heap
164is also possible
165
166 a pointer to some off heap vector/string could be represented by
167
168 [ptr | cdr]
169 |
170 [full pointer | Aux + GC_MARK]
171 |
172 [VECTOR]
173
174Aux bits could be used for storing vector size. Up to 30bits should be available there
175>> This is problematic. Now the information that something is a vector is split up
176>> between 2 cons cells. This means GC needs both of these intact to be able to make
177>> proper decision.
178>> Will try to resolve this by adding some special symbols. But these must be symbols
179>> that cannot occur normally in programs. Then an array could be:
180
181 [Full pointer | ARRAY_SYM + GC_MARK]
182 |
183 [VECTOR]
184
185>> Boxed values same treatment as above.
186>> TODO: Could this be simpler?
187
188[ VALUE | TYPE_SYM + GC_MARK]
189
190
1910000 00XX XXXX XXXX XXXX XXXX XXXX X000 : 0x03FF FFF8
1921111 AA00 0000 0000 0000 0000 0000 0000 : 0xFC00 0000 (AA bits left unused for now, future heap growth?)
193 */
194
195typedef enum {
196 LBM_FLASH_WRITE_OK,
197 LBM_FLASH_FULL,
198 LBM_FLASH_WRITE_ERROR
199} lbm_flash_status;
200
201/** Struct representing a heap cons-cell.
202 *
203 */
204typedef struct {
205 lbm_value car;
206 lbm_value cdr;
207} lbm_cons_t;
208
209/**
210 * Heap state
211 */
212typedef struct {
213 lbm_cons_t *heap;
214 lbm_value freelist; // list of free cons cells.
215 lbm_stack_t gc_stack;
216
217 lbm_uint heap_size; // In number of cells.
218 lbm_uint heap_bytes; // In bytes.
219
220 lbm_uint num_alloc; // Number of cells allocated.
221 lbm_uint num_alloc_arrays; // Number of arrays allocated.
222
223 lbm_uint gc_num; // Number of times gc has been performed.
224 lbm_uint gc_marked; // Number of cells marked by mark phase.
225 lbm_uint gc_recovered; // Number of cells recovered by sweep phase.
226 lbm_uint gc_recovered_arrays;// Number of arrays recovered by sweep.
227 lbm_uint gc_least_free; // The smallest length of the freelist.
228 lbm_uint gc_last_free; // Number of elements on the freelist
229 // after most recent GC.
230} lbm_heap_state_t;
231
232extern lbm_heap_state_t lbm_heap_state;
233
234typedef bool_Bool (*const_heap_write_fun)(lbm_uint ix, lbm_uint w);
235
236typedef struct {
237 lbm_uint *heap;
238 lbm_uint next; // next free index.
239 lbm_uint size; // in lbm_uint words. (cons-cells = words / 2)
240} lbm_const_heap_t;
241
242/**
243 * The header portion of an array stored in array and symbol memory.
244 * An array is always a byte array. use the array-extensions for
245 * storing and reading larger values from arrays.
246 */
247typedef struct {
248 lbm_uint size; /// Number of elements
249 lbm_uint *data; /// pointer to lbm_memory array or C array.
250} lbm_array_header_t;
251
252typedef struct {
253 lbm_uint size;
254 lbm_uint *data;
255 uint32_t index; // Limits arrays to max 2^32-1 elements.
256} lbm_array_header_extended_t;
257
258/** Lock GC mutex
259 * Locks a mutex during GC marking when using the pointer reversal algorithm.
260 * Does nothing when using stack based GC mark.
261 */
262void lbm_gc_lock(void);
263/* Unlock GC mutex
264 */
265void lbm_gc_unlock(void);
266
267/** Initialize heap storage.
268 * \param addr Pointer to an array of lbm_cons_t elements. This array must at least be aligned 4.
269 * \param num_cells Number of lbm_cons_t elements in the array.
270 * \param gc_stack_size Size of the gc_stack in number of words.
271 * \return 1 on success or 0 for failure.
272 */
273int lbm_heap_init(lbm_cons_t *addr, lbm_uint num_cells,
274 lbm_uint gc_stack_size);
275
276/** Add GC time statistics to heap_stats
277 *
278 * \param dur Duration as reported by the timestamp callback.
279 */
280void lbm_heap_new_gc_time(lbm_uint dur);
281/** Add a new free_list length to the heap_stats.
282 * Calculates a new freelist length and updates
283 * the GC statistics.
284 */
285void lbm_heap_new_freelist_length(void);
286/** Check how many lbm_cons_t cells are on the free-list
287 *
288 * \return Number of free lbm_cons_t cells.
289 */
290lbm_uint lbm_heap_num_free(void);
291/** Check how many lbm_cons_t cells are allocated.
292 *
293 * \return Number of lbm_cons_t cells that are currently allocated.
294 */
295lbm_uint lbm_heap_num_allocated(void);
296/** Size of the heap in number of lbm_cons_t cells.
297 *
298 * \return Size of the heap in number of lbm_cons_t cells.
299 */
300lbm_uint lbm_heap_size(void);
301/** Size of the heap in bytes.
302 *
303 * \return Size of heap in bytes.
304 */
305lbm_uint lbm_heap_size_bytes(void);
306/** Allocate an lbm_cons_t cell from the heap.
307 *
308 * \param type A type that can be encoded onto the cell (most often LBM_PTR_TYPE_CONS).
309 * \param car Value to write into car position of allocated cell.
310 * \param cdr Value to write into cdr position of allocated cell.
311 * \return An lbm_value referring to a cons_cell or enc_sym(SYM_MERROR) in case the heap is full.
312 */
313lbm_value lbm_heap_allocate_cell(lbm_type type, lbm_value car, lbm_value cdr);
314/** Allocate a list of n heap-cells.
315 * \param n The number of heap-cells to allocate.
316 * \return A list of heap-cells of Memory error if unable to allocate.
317 */
318lbm_value lbm_heap_allocate_list(lbm_uint n);
319/** Allocate a list of n heap-cells and initialize the values.
320 * \pram ls The result list is passed through this ptr.
321 * \param n The length of list to allocate.
322 * \param valist The values in a va_list to initialize the list with.
323 * \return True of False depending on success of allocation.
324 */
325lbm_value lbm_heap_allocate_list_init_va(unsigned int n, va_list valist);
326/** Allocate a list of n heap-cells and initialize the values.
327 * \param n The length of list to allocate.
328 * \param ... The values to initialize the list with.
329 * \return allocated list or error symbol.
330 */
331lbm_value lbm_heap_allocate_list_init(unsigned int n, ...);
332/** Decode an lbm_value representing a string into a C string
333 *
334 * \param val Value
335 * \return allocated list or error symbol
336 */
337char *lbm_dec_str(lbm_value val);
338/** Decode an lbm_value representing a char channel into an lbm_char_channel_t pointer.
339 *
340 * \param val Value
341 * \return A pointer to an lbm_char_channel_t or NULL if the value does not encode a channel.
342 */
343lbm_char_channel_t *lbm_dec_channel(lbm_value val);
344/** Decode an lbm_value representing a custom type into a lbm_uint value.
345 *
346 * \param val Value.
347 * \return The custom type payload.
348 */
349lbm_uint lbm_dec_custom(lbm_value val);
350/** Decode a numerical value as if it is char
351 *
352 * \param val Value to decode
353 * \return The value encoded in val casted to a char. Returns 0 if val does not encode a number.
354 */
355uint8_t lbm_dec_as_char(lbm_value a);
356/** Decode a numerical value as if it is unsigned
357 *
358 * \param val Value to decode
359 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
360 */
361uint32_t lbm_dec_as_u32(lbm_value val);
362/** Decode a numerical value as a signed integer.
363 *
364 * \param val Value to decode
365 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
366 */
367int32_t lbm_dec_as_i32(lbm_value val);
368/** Decode a numerical value as a float.
369 *
370 * \param val Value to decode.
371 * \return The value encoded in val casted to a float. Returns 0 if val does not encode a number.
372 */
373float lbm_dec_as_float(lbm_value val);
374/** Decode a numerical value as if it is a 64bit unsigned
375 *
376 * \param val Value to decode
377 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
378 */
379uint64_t lbm_dec_as_u64(lbm_value val);
380/** Decode a numerical value as a 64bit signed integer.
381 *
382 * \param val Value to decode
383 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
384 */
385int64_t lbm_dec_as_i64(lbm_value val);
386/** Decode a numerical value as a float.
387 *
388 * \param val Value to decode.
389 * \return The value encoded in val casted to a float. Returns 0 if val does not encode a number.
390 */
391double lbm_dec_as_double(lbm_value val);
392
393/** Decode a numerical value into the architecture defined unsigned integer type.
394 *
395 * \param val Value to decode
396 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
397 */
398lbm_uint lbm_dec_as_uint(lbm_value val);
399
400/** Decode a numerical value into the architecture defined signed integer type.
401 *
402 * \param val Value to decode
403 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
404 */
405lbm_int lbm_dec_as_int(lbm_value val);
406
407lbm_uint lbm_dec_raw(lbm_value v);
408/** Allocates an lbm_cons_t cell from the heap and populates it.
409 *
410 * \param car The value to put in the car field of the allocated lbm_cons_t.
411 * \param cdr The value to put in the cdr field of the allocated lbm_cons_t.
412 * \return A value referencing the lbm_cons_t or enc_sym(SYM_MERROR) if heap is full.
413 */
414lbm_value lbm_cons(lbm_value car, lbm_value cdr);
415
416/** Accesses the car field of an lbm_cons_t.
417 *
418 * \param cons Value
419 * \return The car field of the lbm_cons_t if cons is a reference to a heap cell.
420 * If cons is nil, the return value is nil. If the value
421 * is not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
422 */
423lbm_value lbm_car(lbm_value cons);
424/** Accesses the car field the car field of an lbm_cons_t.
425 *
426 * \param cons Value
427 * \return The car of car field or nil.
428 */
429lbm_value lbm_caar(lbm_value c);
430/** Accesses the car of the cdr of an cons cell
431 *
432 * \param c Value
433 * \return the cdr field or type error.
434 */
435lbm_value lbm_cadr(lbm_value c);
436/** Accesses the cdr field of an lbm_cons_t.
437 *
438 * \param cons Value
439 * \return The cdr field of the lbm_cons_t if cons is a reference to a heap cell.
440 * If cons is nil, the return value is nil. If the value
441 * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
442 */
443lbm_value lbm_cdr(lbm_value cons);
444/** Accesses the cdr of an cdr field of an lbm_cons_t.
445 *
446 * \param cons Value
447 * \return The cdr of the cdr field of the lbm_cons_t if cons is a reference to a heap cell.
448 * If cons is nil, the return value is nil. If the value
449 * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
450 */
451lbm_value lbm_cddr(lbm_value c);
452/** Update the value stored in the car field of a heap cell.
453 *
454 * \param c Value referring to a heap cell.
455 * \param v Value to replace the car field with.
456 * \return 1 on success and 0 if the c value does not refer to a heap cell.
457 */
458int lbm_set_car(lbm_value c, lbm_value v);
459/** Update the value stored in the cdr field of a heap cell.
460 *
461 * \param c Value referring to a heap cell.
462 * \param v Value to replace the cdr field with.
463 * \return 1 on success and 0 if the c value does not refer to a heap cell.
464 */
465int lbm_set_cdr(lbm_value c, lbm_value v);
466/** Update the value stored in the car and cdr fields of a heap cell.
467 *
468 * \param c Value referring to a heap cell.
469 * \param car_val Value to replace the car field with.
470 * \param cdr_val Value to replace the cdr field with.
471 * \return 1 on success and 0 if the c value does not refer to a heap cell.
472 */
473int lbm_set_car_and_cdr(lbm_value c, lbm_value car_val, lbm_value cdr_val);
474// List functions
475/** Calculate the length of a proper list
476 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
477 * may lead to the function not terminating.
478 *
479 * \param c A list
480 * \return The length of the list. Unless the value is a cyclic structure on the heap, this function will terminate.
481 */
482lbm_uint lbm_list_length(lbm_value c);
483
484/** Calculate the length of a proper list and evaluate a predicate for each element.
485 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
486 * may lead to the function not terminating.
487 *
488 * \param c A list
489 * \param pres Boolean result of predicate, false if predicate is false for any of the elements in the list, otherwise true.
490 * \param pred Predicate to evaluate for each element of the list.
491 */
492unsigned int lbm_list_length_pred(lbm_value c, bool_Bool *pres, bool_Bool (*pred)(lbm_value));
493/** Reverse a proper list
494 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
495 * may lead to the function not terminating.
496 *
497 * \param list A list
498 * \return The list reversed or enc_sym(SYM_MERROR) if heap is full.
499 */
500lbm_value lbm_list_reverse(lbm_value list);
501/** Reverse a proper list destroying the original.
502 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
503 * may lead to the function not terminating.
504 *
505 * \param list A list
506 * \return The list reversed
507 */
508lbm_value lbm_list_destructive_reverse(lbm_value list);
509/** Copy a list
510 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
511 * may lead to the function not terminating.
512 *
513 * \param m Number of elements to copy or -1 for all. If 1, m will be updated with the length of the list
514 * \param list A list.
515 * \return Reversed list or enc_sym(SYM_MERROR) if heap is full.
516 */
517lbm_value lbm_list_copy(int *m, lbm_value list);
518
519/** A destructive append of two lists
520 *
521 * \param list1 A list
522 * \param list2 A list
523 * \return list1 with list2 appended at the end.
524 */
525lbm_value lbm_list_append(lbm_value list1, lbm_value list2);
526
527/** Drop values from the head of a list.
528 * \param n Number of values to drop.
529 * \param ls List to drop values from.
530 * \return The list with the n first elements removed.
531 */
532lbm_value lbm_list_drop(unsigned int n, lbm_value ls);
533/** Index into a list.
534 * \param l List to index into.
535 * \param n Position to read out of the list.
536 * \return Value at position n of l or nil if out of bounds.
537 */
538lbm_value lbm_index_list(lbm_value l, int32_t n);
539
540// State and statistics
541/** Get a copy of the heap statistics structure.
542 *
543 * \param A pointer to an lbm_heap_state_t to populate
544 * with the current statistics.
545 */
546void lbm_get_heap_state(lbm_heap_state_t *);
547/** Get the maximum stack level of the GC stack
548 * \return maximum value the gc stack sp reached so far.
549 */
550lbm_uint lbm_get_gc_stack_max(void);
551/** Get the size of the GC stack.
552 * \return the size of the gc stack.
553 */
554lbm_uint lbm_get_gc_stack_size(void);
555// Garbage collection
556/** Increment the counter that is counting the number of times GC ran
557 *
558 */
559void lbm_gc_state_inc(void);
560/** Set the freelist to NIL. Means that no memory will be available
561 * until after a garbage collection.
562 */
563void lbm_nil_freelist(void);
564/** Mark all heap cells reachable from an environment.
565 * \param environment.
566 */
567void lbm_gc_mark_env(lbm_value);
568/** Mark heap cells reachable from the lbm_value v.
569 * \param root
570 */
571void lbm_gc_mark_phase(lbm_value root);
572/** Performs lbm_gc_mark_phase on all the values of an array.
573 * This function is similar to lbm_gc_mark_roots but performs
574 * extra checks to not traverse into non-standard values.
575 * TODO: Check if this function is really needed.
576 * \param data Array of roots to traverse from.
577 * \param n Number of elements in roots-array.
578 */
579void lbm_gc_mark_aux(lbm_uint *data, lbm_uint n);
580/** Performs lbm_gc_mark_phase on all the values in the roots array.
581 * \param roots pointer to array of roots.
582 * \param num_roots size of array of roots.
583 */
584void lbm_gc_mark_roots(lbm_uint *roots, lbm_uint num_roots);
585/** Sweep up all non marked heap cells and place them on the free list.
586 *
587 * \return 1
588 */
589int lbm_gc_sweep_phase(void);
590
591// Array functionality
592/** Allocate an bytearray in symbols and arrays memory (lispbm_memory.h)
593 * and create a heap cell that refers to this bytearray.
594 * \param res The resulting lbm_value is returned through this argument.
595 * \param size Array size in number of 32 bit words.
596 * \return 1 for success of 0 for failure.
597 */
598int lbm_heap_allocate_array(lbm_value *res, lbm_uint size);
599/** Allocate an array in symbols and arrays memory (lispbm_memory.h)
600 * and create a heap cell that refers to this array.
601 * \param res The resulting lbm_value is returned through this argument.
602 * \param size Array size in number of 32 bit words.
603 * \return 1 for success of 0 for failure.
604 */
605int lbm_heap_allocate_lisp_array(lbm_value *res, lbm_uint size);
606/** Convert a C array into an lbm array. If the C array is allocated in LBM MEMORY
607 * the lifetime of the array will be managed by GC.
608 * \param res lbm_value result pointer for storage of the result array.
609 * \param data C array.
610 * \param type The type tag to assign to the resulting LBM array.
611 * \param num_elt Number of elements in the array.
612 * \return 1 for success and 0 for failure.
613 */
614int lbm_lift_array(lbm_value *value, char *data, lbm_uint num_elt);
615/** Get the size of an array value.
616 * \param arr lbm_value array to get size of.
617 * \return -1 for failure or length of array.
618 */
619lbm_int lbm_heap_array_get_size(lbm_value arr);
620/** Get a pointer to the data of an array for read only purposes.
621 * \param arr lbm_value array to get pointer from.
622 * \return NULL or valid pointer.
623 */
624const uint8_t *lbm_heap_array_get_data_ro(lbm_value arr);
625/** Get a pointer to the data of an array for read/write purposes.
626 * \param arr lbm_value array to get pointer from.
627 * \return NULL or valid pointer.
628 */
629uint8_t *lbm_heap_array_get_data_rw(lbm_value arr);
630/** Explicitly free an array.
631 * This function needs to be used with care and knowledge.
632 * \param arr Array value.
633 */
634int lbm_heap_explicit_free_array(lbm_value arr);
635/** Query the size in bytes of an lbm_type.
636 * \param t Type
637 * \return Size in bytes of type or 0 if the type represents a composite.
638 */
639lbm_uint lbm_size_of(lbm_type t);
640
641int lbm_const_heap_init(const_heap_write_fun w_fun,
642 lbm_const_heap_t *heap,
643 lbm_uint *addr,
644 lbm_uint num_words);
645
646lbm_flash_status lbm_allocate_const_cell(lbm_value *res);
647lbm_flash_status lbm_write_const_raw(lbm_uint *data, lbm_uint n, lbm_uint *res);
648lbm_flash_status lbm_allocate_const_raw(lbm_uint nwords, lbm_uint *res);
649lbm_flash_status write_const_cdr(lbm_value cell, lbm_value val);
650lbm_flash_status write_const_car(lbm_value cell, lbm_value val);
651lbm_flash_status lbm_const_write(lbm_uint *tgt, lbm_uint val);
652lbm_uint lbm_flash_memory_usage(void);
653
654/** Query the type information of a value.
655 *
656 * \param x Value to check the type of.
657 * \return The type information.
658 */
659static inline lbm_type lbm_type_of(lbm_value x) {
660 return (x & LBM_PTR_BIT0x00000001u) ? (x & LBM_PTR_TYPE_MASK0xFC000000u) : (x & LBM_VAL_TYPE_MASK0x0000000Cu);
661}
662
663// type-of check that is safe in functional code
664static inline lbm_type lbm_type_of_functional(lbm_value x) {
665 return (x & LBM_PTR_BIT0x00000001u) ?
666 (x & (LBM_PTR_TO_CONSTANT_MASK~0x04000000u & LBM_PTR_TYPE_MASK0xFC000000u)) :
667 (x & LBM_VAL_TYPE_MASK0x0000000Cu);
668}
669
670static inline lbm_value lbm_enc_cons_ptr(lbm_uint x) {
671 return ((x << LBM_ADDRESS_SHIFT2) | LBM_TYPE_CONS0x10000000u | LBM_PTR_BIT0x00000001u);
672}
673
674static inline lbm_uint lbm_dec_ptr(lbm_value p) {
675 return ((LBM_PTR_VAL_MASK0x03FFFFFCu & p) >> LBM_ADDRESS_SHIFT2);
676}
677
678extern lbm_cons_t *lbm_heaps[2];
679
680static inline lbm_uint lbm_dec_cons_cell_ptr(lbm_value p) {
681 lbm_uint h = (p & LBM_PTR_TO_CONSTANT_BIT0x04000000u) >> LBM_PTR_TO_CONSTANT_SHIFT26;
682 return lbm_dec_ptr(p) >> h;
683}
684
685static inline lbm_cons_t *lbm_dec_heap(lbm_value p) {
686 lbm_uint h = (p & LBM_PTR_TO_CONSTANT_BIT0x04000000u) >> LBM_PTR_TO_CONSTANT_SHIFT26;
687 return lbm_heaps[h];
688}
689
690static inline lbm_value lbm_set_ptr_type(lbm_value p, lbm_type t) {
691 return ((LBM_PTR_VAL_MASK0x03FFFFFCu & p) | t | LBM_PTR_BIT0x00000001u);
692}
693
694static inline lbm_value lbm_enc_sym(lbm_uint s) {
695 return (s << LBM_VAL_SHIFT4) | LBM_TYPE_SYMBOL0x00000000u;
696}
697
698static inline lbm_value lbm_enc_i(lbm_int x) {
699 return ((lbm_uint)x << LBM_VAL_SHIFT4) | LBM_TYPE_I0x00000008u;
700}
701
702static inline lbm_value lbm_enc_u(lbm_uint x) {
703 return (x << LBM_VAL_SHIFT4) | LBM_TYPE_U0x0000000Cu;
704}
705
706/** Encode 32 bit integer into an lbm_value.
707 * \param x Value to encode.
708 * \return result encoded value.
709 */
710extern lbm_value lbm_enc_i32(int32_t x);
711
712/** Encode 32 bit unsigned integer into an lbm_value.
713 * \param x Value to encode.
714 * \return result encoded value.
715 */
716extern lbm_value lbm_enc_u32(uint32_t x);
717
718/** Encode a float into an lbm_value.
719 * \param x float value to encode.
720 * \return result encoded value.
721 */
722extern lbm_value lbm_enc_float(float x);
723
724/** Encode a 64 bit integer into an lbm_value.
725 * \param x 64 bit integer to encode.
726 * \return result encoded value.
727 */
728extern lbm_value lbm_enc_i64(int64_t x);
729
730/** Encode a 64 bit unsigned integer into an lbm_value.
731 * \param x 64 bit unsigned integer to encode.
732 * \return result encoded value.
733 */
734extern lbm_value lbm_enc_u64(uint64_t x);
735
736/** Encode a double into an lbm_value.
737 * \param x double to encode.
738 * \return result encoded value.
739 */
740extern lbm_value lbm_enc_double(double x);
741
742static inline lbm_value lbm_enc_char(uint8_t x) {
743 return ((lbm_uint)x << LBM_VAL_SHIFT4) | LBM_TYPE_CHAR0x00000004u;
744}
745
746static inline lbm_int lbm_dec_i(lbm_value x) {
747 return (lbm_int)x >> LBM_VAL_SHIFT4;
748}
749
750static inline lbm_uint lbm_dec_u(lbm_value x) {
751 return x >> LBM_VAL_SHIFT4;
752}
753
754static inline uint8_t lbm_dec_char(lbm_value x) {
755 return (uint8_t)(x >> LBM_VAL_SHIFT4);
756}
757
758static inline lbm_uint lbm_dec_sym(lbm_value x) {
759 return x >> LBM_VAL_SHIFT4;
760}
761
762/** Decode an lbm_value representing a float.
763 * \param x Value to decode.
764 * \return decoded float.
765 */
766extern float lbm_dec_float(lbm_value x);
767
768/** Decode an lbm_value representing a double.
769 * \param x Value to decode.
770 * \return decoded float.
771 */
772extern double lbm_dec_double(lbm_value x);
773
774
775static inline uint32_t lbm_dec_u32(lbm_value x) {
776#ifndef LBM64
777 return (uint32_t)lbm_car(x);
778#else
779 return (uint32_t)(x >> LBM_VAL_SHIFT4);
780#endif
781}
782
783/** Decode an lbm_value representing a 64 bit unsigned integer.
784 * \param x Value to decode.
785 * \return decoded uint64_t.
786 */
787extern uint64_t lbm_dec_u64(lbm_value x);
788
789static inline int32_t lbm_dec_i32(lbm_value x) {
790#ifndef LBM64
791 return (int32_t)lbm_car(x);
792#else
793 return (int32_t)(x >> LBM_VAL_SHIFT4);
794#endif
795}
796
797/** Decode an lbm_value representing a 64 bit integer.
798 * \param x Value to decode.
799 * \return decoded int64_t.
800 */
801extern int64_t lbm_dec_i64(lbm_value x);
802
803/**
804 * Check if a value is a heap pointer
805 * \param x Value to check
806 * \return true if x is a pointer to a heap cell, false otherwise.
807 */
808static inline bool_Bool lbm_is_ptr(lbm_value x) {
809 return (x & LBM_PTR_BIT0x00000001u);
810}
811
812/**
813 * Check if a value is a Read/Writeable cons cell
814 * \param x Value to check
815 * \return true if x is a Read/Writeable cons cell, false otherwise.
816 */
817static inline bool_Bool lbm_is_cons_rw(lbm_value x) {
818 return (lbm_type_of(x) == LBM_TYPE_CONS0x10000000u);
819}
820
821/**
822 * Check if a value is a Readable cons cell
823 * \param x Value to check
824 * \return true if x is a readable cons cell, false otherwise.
825 */
826static inline bool_Bool lbm_is_cons(lbm_value x) {
827 return lbm_is_ptr(x) && ((x & LBM_CONS_TYPE_MASK0xF0000000u) == LBM_TYPE_CONS0x10000000u);
828}
829
830/** Check if a value represents a number
831 * \param x Value to check.
832 * \return true is x represents a number and false otherwise.
833 */
834static inline bool_Bool lbm_is_number(lbm_value x) {
835 return
20
←
Returning value, which participates in a condition later
→
836 (x & LBM_PTR_BIT0x00000001u) ?
18
←
Assuming the condition is false
→
19
←
'?' condition is false
→
837 ((x & LBM_NUMBER_MASK0x08000000u) == LBM_NUMBER_MASK0x08000000u) :
838 (x & LBM_VAL_TYPE_MASK0x0000000Cu);
839}
840
841/** Check if value is an array that can be READ
842 * \param x Value to check.
843 * \return true if x represents a readable array and false otherwise.
844 */
845static inline bool_Bool lbm_is_array_r(lbm_value x) {
846 lbm_type t = lbm_type_of(x);
847 return ((t & LBM_PTR_TO_CONSTANT_MASK~0x04000000u) == LBM_TYPE_ARRAY0x80000000u);
848}
849
850static inline bool_Bool lbm_is_array_rw(lbm_value x) {
851 return( (lbm_type_of(x) == LBM_TYPE_ARRAY0x80000000u) && !(x & LBM_PTR_TO_CONSTANT_BIT0x04000000u));
852}
853
854static inline bool_Bool lbm_is_lisp_array_r(lbm_value x) {
855 lbm_type t = lbm_type_of(x);
856 return ((t & LBM_PTR_TO_CONSTANT_MASK~0x04000000u) == LBM_TYPE_LISPARRAY0xB0000000u);
857}
858
859static inline bool_Bool lbm_is_lisp_array_rw(lbm_value x) {
860 return( (lbm_type_of(x) == LBM_TYPE_LISPARRAY0xB0000000u) && !(x & LBM_PTR_TO_CONSTANT_BIT0x04000000u));
861}
862
863
864static inline bool_Bool lbm_is_channel(lbm_value x) {
865 return (lbm_type_of(x) == LBM_TYPE_CHANNEL0x90000000u &&
866 lbm_type_of(lbm_cdr(x)) == LBM_TYPE_SYMBOL0x00000000u &&
867 lbm_cdr(x) == ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
868}
869static inline bool_Bool lbm_is_char(lbm_value x) {
870 return (lbm_type_of(x) == LBM_TYPE_CHAR0x00000004u);
871}
872
873static inline bool_Bool lbm_is_special(lbm_value symrep) {
874 return ((lbm_type_of(symrep) == LBM_TYPE_SYMBOL0x00000000u) &&
875 (lbm_dec_sym(symrep) < SPECIAL_SYMBOLS_END0xFFFF));
876}
877
878static inline bool_Bool lbm_is_closure(lbm_value exp) {
879 return ((lbm_is_cons(exp)) &&
880 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
881 (lbm_car(exp) == ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u)));
882}
883
884static inline bool_Bool lbm_is_continuation(lbm_value exp) {
885 return ((lbm_type_of(exp) == LBM_TYPE_CONS0x10000000u) &&
886 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
887 (lbm_car(exp) == ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u)));
888}
889
890static inline bool_Bool lbm_is_macro(lbm_value exp) {
891 return ((lbm_type_of(exp) == LBM_TYPE_CONS0x10000000u) &&
892 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
893 (lbm_car(exp) == ENC_SYM_MACRO(((0x10D) << 4) | 0x00000000u)));
894}
895
896static inline bool_Bool lbm_is_match_binder(lbm_value exp) {
897 return (lbm_is_cons(exp) &&
898 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
899 (lbm_car(exp) == ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u)));
900}
901
902static inline bool_Bool lbm_is_comma_qualified_symbol(lbm_value exp) {
903 return (lbm_is_cons(exp) &&
904 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
905 (lbm_car(exp) == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) &&
906 (lbm_type_of(lbm_cadr(exp)) == LBM_TYPE_SYMBOL0x00000000u));
907}
908
909static inline bool_Bool lbm_is_symbol(lbm_value exp) {
910 return !(exp & LBM_LOW_RESERVED_BITS0x0000000Fu);
25
←
Assuming the condition is true
→
26
←
Returning the value 1, which participates in a condition later
→
911}
912
913static inline bool_Bool lbm_is_symbol_nil(lbm_value exp) {
914 return !exp;
9
←
Assuming 'exp' is 0
→
10
←
Returning the value 1, which participates in a condition later
→
915}
916
917static inline bool_Bool lbm_is_symbol_true(lbm_value exp) {
918 return (lbm_is_symbol(exp) && exp == ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u));
919}
920
921static inline bool_Bool lbm_is_symbol_eval(lbm_value exp) {
922 return (lbm_is_symbol(exp) && exp == ENC_SYM_EVAL(((0x30008) << 4) | 0x00000000u));
923}
924
925static inline bool_Bool lbm_is_symbol_merror(lbm_value exp) {
926 return lbm_is_symbol(exp) && (exp == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
927}
928
929static inline bool_Bool lbm_is_list(lbm_value x) {
930 return (lbm_is_cons(x) || lbm_is_symbol_nil(x));
931}
932
933static inline bool_Bool lbm_is_list_rw(lbm_value x) {
934 return (lbm_is_cons_rw(x) || lbm_is_symbol_nil(x));
935}
936
937static inline bool_Bool lbm_is_quoted_list(lbm_value x) {
938 return (lbm_is_cons(x) &&
939 lbm_is_symbol(lbm_car(x)) &&
940 (lbm_car(x) == ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u)) &&
941 lbm_is_cons(lbm_cdr(x)) &&
942 lbm_is_cons(lbm_cadr(x)));
943}
944
945#ifndef LBM64
946#define ERROR_SYMBOL_MASK0xFFFFFFF0 0xFFFFFFF0
947#else
948#define ERROR_SYMBOL_MASK0xFFFFFFF0 0xFFFFFFFFFFFFFFF0
949#endif
950
951/* all error signaling symbols are in the range 0x20 - 0x2F */
952static inline bool_Bool lbm_is_error(lbm_value v){
953 return (lbm_is_symbol(v) &&
954 ((lbm_dec_sym(v) & ERROR_SYMBOL_MASK0xFFFFFFF0) == 0x20));
955}
956
957// ref_cell: returns a reference to the cell addressed by bits 3 - 26
958// Assumes user has checked that is_ptr was set
959static inline lbm_cons_t* lbm_ref_cell(lbm_value addr) {
960 return &lbm_dec_heap(addr)[lbm_dec_cons_cell_ptr(addr)];
961 //return &lbm_heap_state.heap[lbm_dec_ptr(addr)];
962}
963
964
965// lbm_uint a = lbm_heaps[0];
966// lbm_uint b = lbm_heaps[1];
967// lbm_uint i = (addr & LBM_PTR_TO_CONSTANT_BIT) >> LBM_PTR_TO_CONSTANT_SHIFT) - 1;
968// lbm_uint h = (a & i) | (b & ~i);
969
970#ifdef __cplusplus
971}
972#endif
973#endif
diff --git a/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-49137f.html b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-49137f.html new file mode 100644 index 00000000..babfc0e4 --- /dev/null +++ b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-49137f.html @@ -0,0 +1,5543 @@ + + + +src/eval_cps.c + + + + + + + + + + + + + + + + + + + + + + + + + + +

Bug Summary

+ + + + +
File:eval_cps.c
Warning:line 4077, column 24
Access to field 'row' results in a dereference of a null pointer (loaded from variable 'str')
+ +

Annotated Source Code

+

Press '?' + to see keyboard shortcuts

+ + +
clang -cc1 -triple i386-pc-linux-gnu -analyze -disable-free -disable-llvm-verifier -discard-value-names -main-file-name eval_cps.c -analyzer-store=region -analyzer-opt-analyze-nested-blocks -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -mrelocation-model static -mthread-model posix -mframe-pointer=none -fmath-errno -fno-rounding-math -masm-verbose -mconstructor-aliases -target-cpu i686 -dwarf-column-info -fno-split-dwarf-inlining -debugger-tuning=gdb -resource-dir /usr/lib/llvm-10/lib/clang/10.0.0 -I ./include -I ./include/extensions -I platform/linux/include -D _PRELUDE -internal-isystem /usr/local/include -internal-isystem /usr/lib/llvm-10/lib/clang/10.0.0/include -internal-externc-isystem /usr/include/i386-linux-gnu -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -std=c99 -fdebug-compilation-dir /home/joels/Current/lispbm -ferror-limit 19 -fmessage-length 0 -fgnuc-version=4.2.1 -fobjc-runtime=gcc -fdiagnostics-show-option -vectorize-loops -vectorize-slp -analyzer-output=html -faddrsig -o /home/joels/Current/lispbm/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1 -x c src/eval_cps.c +
+ + + +
+ + +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1/*
2 Copyright 2018, 2020 - 2024 Joel Svensson svenssonjoel@yahoo.se
3
4 This program is free software: you can redistribute it and/or modify
5 it under the terms of the GNU General Public License as published by
6 the Free Software Foundation, either version 3 of the License, or
7 (at your option) any later version.
8
9 This program is distributed in the hope that it will be useful,
10 but WITHOUT ANY WARRANTY; without even the implied warranty of
11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 GNU General Public License for more details.
13
14 You should have received a copy of the GNU General Public License
15 along with this program. If not, see <http://www.gnu.org/licenses/>.
16*/
17
18#include <lbm_memory.h>
19#include <lbm_types.h>
20#include "symrepr.h"
21#include "heap.h"
22#include "env.h"
23#include "eval_cps.h"
24#include "stack.h"
25#include "fundamental.h"
26#include "extensions.h"
27#include "tokpar.h"
28#include "lbm_channel.h"
29#include "print.h"
30#include "platform_mutex.h"
31#include "lbm_flat_value.h"
32#include "lbm_flags.h"
33
34#ifdef VISUALIZE_HEAP
35#include "heap_vis.h"
36#endif
37
38#include <setjmp.h>
39#include <stdarg.h>
40
41static jmp_buf error_jmp_buf;
42static jmp_buf critical_error_jmp_buf;
43
44#define S_TO_US(X)(lbm_uint)((X) * 1000000) (lbm_uint)((X) * 1000000)
45
46#define DEC_CONTINUATION(x)(((x) & ~0xF8000001u) >> 2) (((x) & ~LBM_CONTINUATION_INTERNAL0xF8000001u) >> LBM_ADDRESS_SHIFT2)
47#define IS_CONTINUATION(x)(((x) & 0xF8000001u) == 0xF8000001u) (((x) & LBM_CONTINUATION_INTERNAL0xF8000001u) == LBM_CONTINUATION_INTERNAL0xF8000001u)
48#define CONTINUATION(x)(((x) << 2) | 0xF8000001u) (((x) << LBM_ADDRESS_SHIFT2) | LBM_CONTINUATION_INTERNAL0xF8000001u)
49
50#define DONE(((0) << 2) | 0xF8000001u) CONTINUATION(0)(((0) << 2) | 0xF8000001u)
51#define SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u) CONTINUATION(1)(((1) << 2) | 0xF8000001u)
52#define BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u) CONTINUATION(2)(((2) << 2) | 0xF8000001u)
53#define IF(((3) << 2) | 0xF8000001u) CONTINUATION(3)(((3) << 2) | 0xF8000001u)
54#define PROGN_REST(((4) << 2) | 0xF8000001u) CONTINUATION(4)(((4) << 2) | 0xF8000001u)
55#define APPLICATION_ARGS(((5) << 2) | 0xF8000001u) CONTINUATION(5)(((5) << 2) | 0xF8000001u)
56#define AND(((6) << 2) | 0xF8000001u) CONTINUATION(6)(((6) << 2) | 0xF8000001u)
57#define OR(((7) << 2) | 0xF8000001u) CONTINUATION(7)(((7) << 2) | 0xF8000001u)
58#define WAIT(((8) << 2) | 0xF8000001u) CONTINUATION(8)(((8) << 2) | 0xF8000001u)
59#define MATCH(((9) << 2) | 0xF8000001u) CONTINUATION(9)(((9) << 2) | 0xF8000001u)
60#define APPLICATION_START(((10) << 2) | 0xF8000001u) CONTINUATION(10)(((10) << 2) | 0xF8000001u)
61#define EVAL_R(((11) << 2) | 0xF8000001u) CONTINUATION(11)(((11) << 2) | 0xF8000001u)
62#define RESUME(((12) << 2) | 0xF8000001u) CONTINUATION(12)(((12) << 2) | 0xF8000001u)
63#define CLOSURE_ARGS(((13) << 2) | 0xF8000001u) CONTINUATION(13)(((13) << 2) | 0xF8000001u)
64#define EXIT_ATOMIC(((14) << 2) | 0xF8000001u) CONTINUATION(14)(((14) << 2) | 0xF8000001u)
65#define READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u) CONTINUATION(15)(((15) << 2) | 0xF8000001u)
66#define READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u) CONTINUATION(16)(((16) << 2) | 0xF8000001u)
67#define READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u) CONTINUATION(17)(((17) << 2) | 0xF8000001u)
68#define READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u) CONTINUATION(18)(((18) << 2) | 0xF8000001u)
69#define READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u) CONTINUATION(19)(((19) << 2) | 0xF8000001u)
70#define READ_DONE(((20) << 2) | 0xF8000001u) CONTINUATION(20)(((20) << 2) | 0xF8000001u)
71#define READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u) CONTINUATION(21)(((21) << 2) | 0xF8000001u)
72#define READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u) CONTINUATION(22)(((22) << 2) | 0xF8000001u)
73#define READ_COMMA_RESULT(((23) << 2) | 0xF8000001u) CONTINUATION(23)(((23) << 2) | 0xF8000001u)
74#define READ_START_ARRAY(((24) << 2) | 0xF8000001u) CONTINUATION(24)(((24) << 2) | 0xF8000001u)
75#define READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u) CONTINUATION(25)(((25) << 2) | 0xF8000001u)
76#define MAP(((26) << 2) | 0xF8000001u) CONTINUATION(26)(((26) << 2) | 0xF8000001u)
77#define MATCH_GUARD(((27) << 2) | 0xF8000001u) CONTINUATION(27)(((27) << 2) | 0xF8000001u)
78#define TERMINATE(((28) << 2) | 0xF8000001u) CONTINUATION(28)(((28) << 2) | 0xF8000001u)
79#define PROGN_VAR(((29) << 2) | 0xF8000001u) CONTINUATION(29)(((29) << 2) | 0xF8000001u)
80#define SETQ(((30) << 2) | 0xF8000001u) CONTINUATION(30)(((30) << 2) | 0xF8000001u)
81#define MOVE_TO_FLASH(((31) << 2) | 0xF8000001u) CONTINUATION(31)(((31) << 2) | 0xF8000001u)
82#define MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u) CONTINUATION(32)(((32) << 2) | 0xF8000001u)
83#define MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u) CONTINUATION(33)(((33) << 2) | 0xF8000001u)
84#define CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u) CONTINUATION(34)(((34) << 2) | 0xF8000001u)
85#define QQ_EXPAND_START(((35) << 2) | 0xF8000001u) CONTINUATION(35)(((35) << 2) | 0xF8000001u)
86#define QQ_EXPAND(((36) << 2) | 0xF8000001u) CONTINUATION(36)(((36) << 2) | 0xF8000001u)
87#define QQ_APPEND(((37) << 2) | 0xF8000001u) CONTINUATION(37)(((37) << 2) | 0xF8000001u)
88#define QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u) CONTINUATION(38)(((38) << 2) | 0xF8000001u)
89#define QQ_LIST(((39) << 2) | 0xF8000001u) CONTINUATION(39)(((39) << 2) | 0xF8000001u)
90#define KILL(((40) << 2) | 0xF8000001u) CONTINUATION(40)(((40) << 2) | 0xF8000001u)
91#define LOOP(((41) << 2) | 0xF8000001u) CONTINUATION(41)(((41) << 2) | 0xF8000001u)
92#define LOOP_CONDITION(((42) << 2) | 0xF8000001u) CONTINUATION(42)(((42) << 2) | 0xF8000001u)
93#define MERGE_REST(((43) << 2) | 0xF8000001u) CONTINUATION(43)(((43) << 2) | 0xF8000001u)
94#define MERGE_LAYER(((44) << 2) | 0xF8000001u) CONTINUATION(44)(((44) << 2) | 0xF8000001u)
95#define CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u) CONTINUATION(45)(((45) << 2) | 0xF8000001u)
96#define MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u) CONTINUATION(46)(((46) << 2) | 0xF8000001u)
97#define POP_READER_FLAGS(((47) << 2) | 0xF8000001u) CONTINUATION(47)(((47) << 2) | 0xF8000001u)
98#define EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u) CONTINUATION(48)(((48) << 2) | 0xF8000001u)
99#define NUM_CONTINUATIONS49 49
100
101#define FM_NEED_GC-1 -1
102#define FM_NO_MATCH-2 -2
103#define FM_PATTERN_ERROR-3 -3
104
105typedef enum {
106 BL_OK = 0,
107 BL_NO_MEMORY,
108 BL_INCORRECT_KEY
109} binding_location_status;
110
111#define FB_OK0 0
112#define FB_TYPE_ERROR-1 -1
113
114const char* lbm_error_str_parse_eof = "End of parse stream.";
115const char* lbm_error_str_parse_dot = "Incorrect usage of '.'.";
116const char* lbm_error_str_parse_close = "Expected closing parenthesis.";
117const char* lbm_error_str_num_args = "Incorrect number of arguments.";
118const char* lbm_error_str_forbidden_in_atomic = "Operation is forbidden in an atomic block.";
119const char* lbm_error_str_no_number = "Argument(s) must be a number.";
120const char* lbm_error_str_not_a_boolean = "Argument must be t or nil (true or false).";
121const char* lbm_error_str_incorrect_arg = "Incorrect argument.";
122const char* lbm_error_str_var_outside_progn = "Usage of var outside of progn.";
123const char* lbm_error_str_flash_not_possible = "Value cannot be written to flash.";
124const char* lbm_error_str_flash_error = "Error writing to flash.";
125const char* lbm_error_str_flash_full = "Flash memory is full.";
126const char* lbm_error_str_variable_not_bound = "Variable not bound.";
127
128static lbm_value lbm_error_suspect;
129static bool_Bool lbm_error_has_suspect = false0;
130#ifdef LBM_ALWAYS_GC
131
132#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
133 gc(); \
134 (y) = (x); \
135 if (lbm_is_symbol_merror((y))) { \
136 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
137 }
138
139#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
140 lbm_gc_mark_phase(r); \
141 gc(); \
142 (y) = (x); \
143 if (lbm_is_symbol_merror((y))) { \
144 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
145 }
146
147#else
148
149#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
150 (y) = (x); \
151 if (lbm_is_symbol_merror((y))) { \
152 gc(); \
153 (y) = (x); \
154 if (lbm_is_symbol_merror((y))) { \
155 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
156 } \
157 /* continue executing statements below */ \
158 }
159#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
160 (y) = (x); \
161 if (lbm_is_symbol_merror((y))) { \
162 lbm_gc_mark_phase(r); \
163 gc(); \
164 (y) = (x); \
165 if (lbm_is_symbol_merror((y))) { \
166 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
167 } \
168 /* continue executing statements below */ \
169 }
170
171#endif
172
173typedef struct {
174 eval_context_t *first;
175 eval_context_t *last;
176} eval_context_queue_t;
177
178#ifdef CLEAN_UP_CLOSURES
179static lbm_value clean_cl_env_symbol = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
180#endif
181
182static int gc(void);
183static void error_ctx(lbm_value);
184static void error_at_ctx(lbm_value err_val, lbm_value at);
185static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx);
186static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail);
187
188// The currently executing context.
189eval_context_t *ctx_running = NULL((void*)0);
190volatile bool_Bool lbm_system_sleeping = false0;
191
192static volatile bool_Bool gc_requested = false0;
193void lbm_request_gc(void) {
194 gc_requested = true1;
195}
196
197/*
198 On ChibiOs the CH_CFG_ST_FREQUENCY setting in chconf.h sets the
199 resolution of the timer used for sleep operations. If this is set
200 to 10KHz the resolution is 100us.
201
202 The CH_CFG_ST_TIMEDELTA specifies the minimum number of ticks that
203 can be safely specified in a timeout directive (wonder if that
204 means sleep-period). The timedelta is set to 2.
205
206 If I have understood these correctly it means that the minimum
207 sleep duration possible is 2 * 100us = 200us.
208*/
209
210#define EVAL_CPS_DEFAULT_STACK_SIZE256 256
211#define EVAL_CPS_MIN_SLEEP200 200
212#define EVAL_STEPS_QUOTA10 10
213
214static volatile uint32_t eval_steps_refill = EVAL_STEPS_QUOTA10;
215static uint32_t eval_steps_quota = EVAL_STEPS_QUOTA10;
216
217void lbm_set_eval_step_quota(uint32_t quota) {
218 eval_steps_refill = quota;
219}
220
221static uint32_t eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
222static volatile uint32_t eval_cps_next_state = EVAL_CPS_STATE_NONE0;
223static volatile uint32_t eval_cps_next_state_arg = 0;
224static volatile bool_Bool eval_cps_state_changed = false0;
225
226static void usleep_nonsense(uint32_t us) {
227 (void) us;
228}
229
230static bool_Bool dynamic_load_nonsense(const char *sym, const char **code) {
231 (void) sym;
232 (void) code;
233 return false0;
234}
235
236static uint32_t timestamp_nonsense(void) {
237 return 0;
238}
239
240static int printf_nonsense(const char *fmt, ...) {
241 (void) fmt;
242 return 0;
243}
244
245static void ctx_done_nonsense(eval_context_t *ctx) {
246 (void) ctx;
247}
248
249static void critical_nonsense(void) {
250 return;
251}
252
253static void (*critical_error_callback)(void) = critical_nonsense;
254static void (*usleep_callback)(uint32_t) = usleep_nonsense;
255static uint32_t (*timestamp_us_callback)(void) = timestamp_nonsense;
256static void (*ctx_done_callback)(eval_context_t *) = ctx_done_nonsense;
257static int (*printf_callback)(const char *, ...) = printf_nonsense;
258static bool_Bool (*dynamic_load_callback)(const char *, const char **) = dynamic_load_nonsense;
259
260void lbm_set_critical_error_callback(void (*fptr)(void)) {
261 if (fptr == NULL((void*)0)) critical_error_callback = critical_nonsense;
262 else critical_error_callback = fptr;
263}
264
265void lbm_set_usleep_callback(void (*fptr)(uint32_t)) {
266 if (fptr == NULL((void*)0)) usleep_callback = usleep_nonsense;
267 else usleep_callback = fptr;
268}
269
270void lbm_set_timestamp_us_callback(uint32_t (*fptr)(void)) {
271 if (fptr == NULL((void*)0)) timestamp_us_callback = timestamp_nonsense;
272 else timestamp_us_callback = fptr;
273}
274
275void lbm_set_ctx_done_callback(void (*fptr)(eval_context_t *)) {
276 if (fptr == NULL((void*)0)) ctx_done_callback = ctx_done_nonsense;
277 else ctx_done_callback = fptr;
278}
279
280void lbm_set_printf_callback(int (*fptr)(const char*, ...)){
281 if (fptr == NULL((void*)0)) printf_callback = printf_nonsense;
282 else printf_callback = fptr;
283}
284
285void lbm_set_dynamic_load_callback(bool_Bool (*fptr)(const char *, const char **)) {
286 if (fptr == NULL((void*)0)) dynamic_load_callback = dynamic_load_nonsense;
287 else dynamic_load_callback = fptr;
288}
289
290static volatile lbm_event_t *lbm_events = NULL((void*)0);
291static unsigned int lbm_events_head = 0;
292static unsigned int lbm_events_tail = 0;
293static unsigned int lbm_events_max = 0;
294static bool_Bool lbm_events_full = false0;
295static mutex_t lbm_events_mutex;
296static bool_Bool lbm_events_mutex_initialized = false0;
297static volatile lbm_cid lbm_event_handler_pid = -1;
298
299lbm_cid lbm_get_event_handler_pid(void) {
300 return lbm_event_handler_pid;
301}
302
303void lbm_set_event_handler_pid(lbm_cid pid) {
304 lbm_event_handler_pid = pid;
305}
306
307bool_Bool lbm_event_handler_exists(void) {
308 return(lbm_event_handler_pid > 0);
309}
310
311
312static bool_Bool event_internal(lbm_event_type_t event_type, lbm_uint parameter, lbm_uint buf_ptr, lbm_uint buf_len) {
313 bool_Bool r = false0;
314 if (lbm_events) {
315 mutex_lock(&lbm_events_mutex);
316 if (!lbm_events_full) {
317 lbm_event_t event;
318 event.type = event_type;
319 event.parameter = parameter;
320 event.buf_ptr = buf_ptr;
321 event.buf_len = buf_len;
322 lbm_events[lbm_events_head] = event;
323 lbm_events_head = (lbm_events_head + 1) % lbm_events_max;
324 lbm_events_full = lbm_events_head == lbm_events_tail;
325 r = true1;
326 }
327 mutex_unlock(&lbm_events_mutex);
328 }
329 return r;
330}
331
332bool_Bool lbm_event_define(lbm_value key, lbm_flat_value_t *fv) {
333 return event_internal(LBM_EVENT_DEFINE, key, (lbm_uint)fv->buf, fv->buf_size);
334}
335
336bool_Bool lbm_event_unboxed(lbm_value unboxed) {
337 lbm_uint t = lbm_type_of(unboxed);
338 if (t == LBM_TYPE_SYMBOL0x00000000u ||
339 t == LBM_TYPE_I0x00000008u ||
340 t == LBM_TYPE_U0x0000000Cu ||
341 t == LBM_TYPE_CHAR0x00000004u) {
342 if (lbm_event_handler_pid > 0) {
343 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)unboxed, 0);
344 }
345 }
346 return false0;
347}
348
349bool_Bool lbm_event(lbm_flat_value_t *fv) {
350 if (lbm_event_handler_pid > 0) {
351 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)fv->buf, fv->buf_size);
352 }
353 return false0;
354}
355
356static bool_Bool lbm_event_pop(lbm_event_t *event) {
357 mutex_lock(&lbm_events_mutex);
358 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
359 mutex_unlock(&lbm_events_mutex);
360 return false0;
361 }
362 *event = lbm_events[lbm_events_tail];
363 lbm_events_tail = (lbm_events_tail + 1) % lbm_events_max;
364 lbm_events_full = false0;
365 mutex_unlock(&lbm_events_mutex);
366 return true1;
367}
368
369bool_Bool lbm_event_queue_is_empty(void) {
370 mutex_lock(&lbm_events_mutex);
371 bool_Bool empty = false0;
372 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
373 empty = true1;
374 }
375 mutex_unlock(&lbm_events_mutex);
376 return empty;
377}
378
379static bool_Bool eval_running = false0;
380static volatile bool_Bool blocking_extension = false0;
381static mutex_t blocking_extension_mutex;
382static bool_Bool blocking_extension_mutex_initialized = false0;
383static lbm_uint blocking_extension_timeout_us = 0;
384static bool_Bool blocking_extension_timeout = false0;
385
386static uint32_t is_atomic = 0;
387
388/* Process queues */
389static eval_context_queue_t blocked = {NULL((void*)0), NULL((void*)0)};
390static eval_context_queue_t queue = {NULL((void*)0), NULL((void*)0)};
391
392/* one mutex for all queue operations */
393mutex_t qmutex;
394bool_Bool qmutex_initialized = false0;
395
396
397// MODES
398static volatile bool_Bool lbm_verbose = false0;
399
400void lbm_toggle_verbose(void) {
401 lbm_verbose = !lbm_verbose;
402}
403
404void lbm_set_verbose(bool_Bool verbose) {
405 lbm_verbose = verbose;
406}
407
408lbm_cid lbm_get_current_cid(void) {
409 if (ctx_running)
410 return ctx_running->id;
411 else
412 return -1;
413}
414
415eval_context_t *lbm_get_current_context(void) {
416 return ctx_running;
417}
418
419/****************************************************/
420/* Utilities used locally in this file */
421
422static lbm_value cons_with_gc(lbm_value head, lbm_value tail, lbm_value remember) {
423#ifdef LBM_ALWAYS_GC
424 lbm_value roots[3] = {head, tail, remember};
425 lbm_gc_mark_roots(roots, 3);
426 gc();
427 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
428 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
429 if (lbm_is_symbol_merror(res)) {
430 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
431 }
432 return res;
433#else
434 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
435 if (lbm_is_symbol_merror(res)) {
436 lbm_value roots[3] = {head, tail, remember};
437 lbm_gc_mark_roots(roots,3);
438 gc();
439 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
440 if (lbm_is_symbol_merror(res)) {
441 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
442 }
443 }
444 return res;
445#endif
446}
447
448static lbm_uint *get_stack_ptr(eval_context_t *ctx, unsigned int n) {
449 if (n <= ctx->K.sp) {
450 lbm_uint index = ctx->K.sp - n;
451 return &ctx->K.data[index];
452 }
453 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
454 return 0; // dead code cannot be reached, but C compiler doesn't realise.
455}
456
457// pop_stack_ptr is safe when no GC is performed and
458// the values of the stack will be dropped.
459static lbm_uint *pop_stack_ptr(eval_context_t *ctx, unsigned int n) {
460 if (n <= ctx->K.sp) {
461 ctx->K.sp -= n;
462 return &ctx->K.data[ctx->K.sp];
463 }
464 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
465 return 0; // dead code cannot be reached, but C compiler doesn't realise.
466}
467
468static inline lbm_uint *stack_reserve(eval_context_t *ctx, unsigned int n) {
469 if (ctx->K.sp + n < ctx->K.size) {
470 lbm_uint *ptr = &ctx->K.data[ctx->K.sp];
471 ctx->K.sp += n;
472 return ptr;
473 }
474 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
475 return 0; // dead code cannot be reached, but C compiler doesn't realise.
476}
477
478static void handle_flash_status(lbm_flash_status s) {
479 if ( s == LBM_FLASH_FULL) {
480 lbm_set_error_reason((char*)lbm_error_str_flash_full);
481 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
482 }
483 if (s == LBM_FLASH_WRITE_ERROR) {
484 lbm_set_error_reason((char*)lbm_error_str_flash_error);
485 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
486 }
487}
488
489static void lift_array_flash(lbm_value flash_cell, bool_Bool bytearray, char *data, lbm_uint num_elt) {
490
491 lbm_array_header_t flash_array_header;
492 flash_array_header.size = num_elt;
493 flash_array_header.data = (lbm_uint*)data;
494 lbm_uint flash_array_header_ptr;
495 handle_flash_status(lbm_write_const_raw((lbm_uint*)&flash_array_header,
496 sizeof(lbm_array_header_t) / sizeof(lbm_uint),
497 &flash_array_header_ptr));
498 handle_flash_status(write_const_car(flash_cell, flash_array_header_ptr));
499 lbm_uint t = bytearray ? ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u) : ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u);
500 handle_flash_status(write_const_cdr(flash_cell, t));
501}
502
503static void get_car_and_cdr(lbm_value a, lbm_value *a_car, lbm_value *a_cdr) {
504 if (lbm_is_ptr(a)) {
505 lbm_cons_t *cell = lbm_ref_cell(a);
506 *a_car = cell->car;
507 *a_cdr = cell->cdr;
508 } else if (lbm_is_symbol_nil(a)) {
509 *a_car = *a_cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
510 } else {
511 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
512 }
513}
514
515/* car cdr caar cadr replacements that are evaluator safe. */
516static lbm_value get_car(lbm_value a) {
517 if (lbm_is_ptr(a)) {
518 lbm_cons_t *cell = lbm_ref_cell(a);
519 return cell->car;
520 } else if (lbm_is_symbol_nil(a)) {
521 return a;
522 }
523 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
524 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
525}
526
527static lbm_value get_cdr(lbm_value a) {
528 if (lbm_is_ptr(a)) {
529 lbm_cons_t *cell = lbm_ref_cell(a);
530 return cell->cdr;
531 } else if (lbm_is_symbol_nil(a)) {
532 return a;
533 }
534 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
535 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
536}
537
538static lbm_value get_cadr(lbm_value a) {
539 if (lbm_is_ptr(a)) {
540 lbm_cons_t *cell = lbm_ref_cell(a);
541 lbm_value tmp = cell->cdr;
542 if (lbm_is_ptr(tmp)) {
543 return lbm_ref_cell(tmp)->car;
544 } else if (lbm_is_symbol_nil(tmp)) {
545 return tmp;
546 }
547 } else if (lbm_is_symbol_nil(a)) {
548 return a;
549 }
550 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
551 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
552}
553
554static lbm_value allocate_closure(lbm_value params, lbm_value body, lbm_value env) {
555
556#ifdef LBM_ALWAYS_GC
557 gc();
558 if (lbm_heap_num_free() < 4) {
559 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
560 }
561#else
562 if (lbm_heap_num_free() < 4) {
563 gc();
564 if (lbm_heap_num_free() < 4) {
565 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
566 }
567 }
568#endif
569 // The freelist will always contain just plain heap-cells.
570 // So dec_ptr is sufficient.
571 lbm_value res = lbm_heap_state.freelist;
572 if (lbm_type_of(res) == LBM_TYPE_CONS0x10000000u) {
573 lbm_cons_t *heap = lbm_heap_state.heap;
574 lbm_uint ix = lbm_dec_ptr(res);
575 heap[ix].car = ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u);
576 ix = lbm_dec_ptr(heap[ix].cdr);
577 heap[ix].car = params;
578 ix = lbm_dec_ptr(heap[ix].cdr);
579 heap[ix].car = body;
580 ix = lbm_dec_ptr(heap[ix].cdr);
581 heap[ix].car = env;
582 lbm_heap_state.freelist = heap[ix].cdr;
583 heap[ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
584 lbm_heap_state.num_alloc+=4;
585 } else {
586 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
587 }
588 return res;
589}
590
591// Allocate a binding and attach it to a list (if so desired)
592static lbm_value allocate_binding(lbm_value key, lbm_value val, lbm_value the_cdr) {
593 if (lbm_heap_num_free() < 2) {
594 gc();
595 if (lbm_heap_num_free() < 2) {
596 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
597 }
598 }
599 lbm_cons_t* heap = lbm_heap_state.heap;
600 lbm_value binding_cell = lbm_heap_state.freelist;
601 lbm_uint binding_cell_ix = lbm_dec_ptr(binding_cell);
602 lbm_value list_cell = heap[binding_cell_ix].cdr;
603 lbm_uint list_cell_ix = lbm_dec_ptr(list_cell);
604 lbm_heap_state.freelist = heap[list_cell_ix].cdr;
605 lbm_heap_state.num_alloc += 2;
606 heap[binding_cell_ix].car = key;
607 heap[binding_cell_ix].cdr = val;
608 heap[list_cell_ix].car = binding_cell;
609 heap[list_cell_ix].cdr = the_cdr;
610 return list_cell;
611}
612
613#define CLO_PARAMS0 0
614#define CLO_BODY1 1
615#define CLO_ENV2 2
616#define LOOP_BINDS0 0
617#define LOOP_COND1 1
618#define LOOP_BODY2 2
619
620// (a b c) -> [a b c]
621static lbm_value extract_n(lbm_value curr, lbm_value *res, unsigned int n) {
622 for (unsigned int i = 0; i < n; i ++) {
623 if (lbm_is_ptr(curr)) {
624 lbm_cons_t *cell = lbm_ref_cell(curr);
625 res[i] = cell->car;
626 curr = cell->cdr;
627 } else {
628 res[i] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
629 }
630 }
631 return curr; // Rest of list is returned here.
632}
633
634static void call_fundamental(lbm_uint fundamental, lbm_value *args, lbm_uint arg_count, eval_context_t *ctx) {
635 lbm_value res;
636 res = fundamental_table[fundamental](args, arg_count, ctx);
637 if (lbm_is_error(res)) {
638 if (lbm_is_symbol_merror(res)) {
639 gc();
640 res = fundamental_table[fundamental](args, arg_count, ctx);
641 }
642 if (lbm_is_error(res)) {
643 error_at_ctx(res, lbm_enc_sym(FUNDAMENTAL_SYMBOLS_START0x20000 | fundamental));
644 }
645 }
646 lbm_stack_drop(&ctx->K, arg_count+1);
647 ctx->app_cont = true1;
648 ctx->r = res;
649}
650
651// block_current_ctx blocks a context until it is
652// woken up externally or a timeout period of time passes.
653static void block_current_ctx(uint32_t state, lbm_uint sleep_us, bool_Bool do_cont) {
654 ctx_running->timestamp = timestamp_us_callback();
655 ctx_running->sleep_us = sleep_us;
656 ctx_running->state = state;
657 ctx_running->app_cont = do_cont;
658 enqueue_ctx(&blocked, ctx_running);
659 ctx_running = NULL((void*)0);
660}
661
662lbm_flash_status lbm_write_const_array_padded(uint8_t *data, lbm_uint n, lbm_uint *res) {
663 lbm_uint full_words = n / sizeof(lbm_uint);
664 lbm_uint n_mod = n % sizeof(lbm_uint);
665
666 if (n_mod == 0) { // perfect fit.
667 return lbm_write_const_raw((lbm_uint*)data, full_words, res);
668 } else {
669 lbm_uint last_word = 0;
670 memcpy(&last_word, &data[full_words * sizeof(lbm_uint)], n_mod);
671 if (full_words >= 1) {
672 lbm_flash_status s = lbm_write_const_raw((lbm_uint*)data, full_words, res);
673 if ( s == LBM_FLASH_WRITE_OK) {
674 lbm_uint dummy;
675 s = lbm_write_const_raw(&last_word, 1, &dummy);
676 }
677 return s;
678 } else {
679 return lbm_write_const_raw(&last_word, 1, res);
680 }
681 }
682}
683
684/****************************************************/
685/* Error message creation */
686
687#define ERROR_MESSAGE_BUFFER_SIZE_BYTES256 256
688
689void print_environments(char *buf, unsigned int size) {
690
691 lbm_value curr_l = ctx_running->curr_env;
692 printf_callback("\tCurrent local environment:\n");
693 while (lbm_type_of(curr_l) == LBM_TYPE_CONS0x10000000u) {
694 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_l));
695 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_l)));
696 printf_callback("\t%s = %s\n", buf, buf+(size/2));
697 curr_l = lbm_cdr(curr_l);
698 }
699 printf_callback("\n\n");
700 printf_callback("\tCurrent global environment:\n");
701 lbm_value *glob_env = lbm_get_global_env();
702
703 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
704 lbm_value curr_g = glob_env[i];;
705 while (lbm_type_of(curr_g) == LBM_TYPE_CONS0x10000000u) {
706
707 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_g));
708 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_g)));
709 printf_callback("\t%s = %s\n", buf, buf+(size/2));
710 curr_g = lbm_cdr(curr_g);
711 }
712 }
713}
714
715void print_error_message(lbm_value error, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int col, lbm_int row0, lbm_int row1) {
716 if (!printf_callback) return;
717
718 /* try to allocate a lbm_print_value buffer on the lbm_memory */
719 char *buf = lbm_malloc_reserve(ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
720 if (!buf) {
721 printf_callback("Error: Not enough free memory to create a human readable error message\n");
722 return;
723 }
724
725 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, error);
726 printf_callback( "*** Error: %s\n", buf);
727 if (has_at) {
728 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, at);
729 printf_callback("*** In: %s\n",buf);
730 if (lbm_error_has_suspect) {
731 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, lbm_error_suspect);
732 lbm_error_has_suspect = false0;
733 printf_callback("*** At: %s\n", buf);
734 } else {
735 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
736 printf_callback("*** After: %s\n",buf);
737 }
738 } else {
739 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
740 printf_callback("*** Near: %s\n",buf);
741 }
742
743 printf_callback("\n");
744
745 if (lbm_is_symbol(error) &&
746 error == ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u)) {
747 printf_callback("*** Line: %u\n", row);
748 printf_callback("*** Column: %u\n", col);
749 } else if (row0 != -1 || row1 != -1 ) {
750 printf_callback("*** Between rows: (-1 unknown) \n");
751 printf_callback("*** Start: %d\n", (int32_t)row0);
752 printf_callback("*** End: %d\n", (int32_t)row1);
753 }
754
755 printf_callback("\n");
756
757 if (ctx_running->error_reason) {
758 printf_callback("Reason:\n %s\n\n", ctx_running->error_reason);
759 }
760 if (lbm_verbose) {
761 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
762 printf_callback(" In context: %d\n", ctx_running->id);
763 printf_callback(" Current intermediate result: %s\n\n", buf);
764
765 print_environments(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
766 printf_callback("\n\n");
767
768 printf_callback(" Stack:\n");
769 for (unsigned int i = 0; i < ctx_running->K.sp; i ++) {
770 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->K.data[i]);
771 printf_callback(" %s\n", buf);
772 }
773 }
774 lbm_free(buf);
775}
776
777/****************************************************/
778/* Tokenizing and parsing */
779
780bool_Bool create_string_channel(char *str, lbm_value *res) {
781
782 lbm_char_channel_t *chan = NULL((void*)0);
783 lbm_string_channel_state_t *st = NULL((void*)0);
784
785 st = (lbm_string_channel_state_t*)lbm_memory_allocate(sizeof(lbm_string_channel_state_t) / sizeof(lbm_uint) +1);
786 if (st == NULL((void*)0)) {
787 return false0;
788 }
789 chan = (lbm_char_channel_t*)lbm_memory_allocate(sizeof(lbm_char_channel_t) / sizeof(lbm_uint) + 1);
790 if (chan == NULL((void*)0)) {
791 lbm_memory_free((lbm_uint*)st);
792 return false0;
793 }
794
795 lbm_create_string_char_channel(st, chan, str);
796 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
797 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
798 lbm_memory_free((lbm_uint*)st);
799 lbm_memory_free((lbm_uint*)chan);
800 return false0;
801 }
802
803 *res = cell;
804 return true1;
805}
806
807bool_Bool lift_char_channel(lbm_char_channel_t *chan , lbm_value *res) {
808 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
809 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
810 return false0;
811 }
812 *res = cell;
813 return true1;
814}
815
816
817/****************************************************/
818/* Queue functions */
819
820static void queue_iterator_nm(eval_context_queue_t *q, ctx_fun f, void *arg1, void *arg2) {
821 eval_context_t *curr;
822 curr = q->first;
823
824 while (curr != NULL((void*)0)) {
825 f(curr, arg1, arg2);
826 curr = curr->next;
827 }
828}
829
830void lbm_running_iterator(ctx_fun f, void *arg1, void *arg2){
831 mutex_lock(&qmutex);
832 queue_iterator_nm(&queue, f, arg1, arg2);
833 mutex_unlock(&qmutex);
834}
835
836void lbm_blocked_iterator(ctx_fun f, void *arg1, void *arg2){
837 mutex_lock(&qmutex);
838 queue_iterator_nm(&blocked, f, arg1, arg2);
839 mutex_unlock(&qmutex);
840}
841
842static void enqueue_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
843 if (q->last == NULL((void*)0)) {
844 ctx->prev = NULL((void*)0);
845 ctx->next = NULL((void*)0);
846 q->first = ctx;
847 q->last = ctx;
848 } else {
849 ctx->prev = q->last;
850 ctx->next = NULL((void*)0);
851 q->last->next = ctx;
852 q->last = ctx;
853 }
854}
855
856static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx) {
857 mutex_lock(&qmutex);
858 enqueue_ctx_nm(q,ctx);
859 mutex_unlock(&qmutex);
860}
861
862static eval_context_t *lookup_ctx_nm(eval_context_queue_t *q, lbm_cid cid) {
863 eval_context_t *curr;
864 curr = q->first;
865 while (curr != NULL((void*)0)) {
866 if (curr->id == cid) {
867 return curr;
868 }
869 curr = curr->next;
870 }
871 return NULL((void*)0);
872}
873
874static bool_Bool drop_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
875
876 bool_Bool res = false0;
877 if (q->first == NULL((void*)0) || q->last == NULL((void*)0)) {
878 if (!(q->last == NULL((void*)0) && q->first == NULL((void*)0))) {
879 /* error state that should not happen */
880 return res;
881 }
882 /* Queue is empty */
883 return res;
884 }
885
886 eval_context_t *curr = q->first;
887 while (curr) {
888 if (curr->id == ctx->id) {
889 res = true1;
890 eval_context_t *tmp = curr->next;
891 if (curr->prev == NULL((void*)0)) {
892 if (curr->next == NULL((void*)0)) {
893 q->last = NULL((void*)0);
894 q->first = NULL((void*)0);
895 } else {
896 q->first = tmp;
897 tmp->prev = NULL((void*)0);
898 }
899 } else { /* curr->prev != NULL */
900 if (curr->next == NULL((void*)0)) {
901 q->last = curr->prev;
902 q->last->next = NULL((void*)0);
903 } else {
904 curr->prev->next = tmp;
905 tmp->prev = curr->prev;
906 }
907 }
908 break;
909 }
910 curr = curr->next;
911 }
912 return res;
913}
914
915/* End execution of the running context. */
916static void finish_ctx(void) {
917
918 if (!ctx_running) {
919 return;
920 }
921 /* Drop the continuation stack immediately to free up lbm_memory */
922 lbm_stack_free(&ctx_running->K);
923 ctx_done_callback(ctx_running);
924 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->name)) {
925 lbm_free(ctx_running->name);
926 }
927 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->error_reason)) {
928 lbm_memory_free((lbm_uint*)ctx_running->error_reason);
929 }
930 lbm_memory_free((lbm_uint*)ctx_running->mailbox);
931 lbm_memory_free((lbm_uint*)ctx_running);
932 ctx_running = NULL((void*)0);
933}
934
935static void context_exists(eval_context_t *ctx, void *cid, void *b) {
936 if (ctx->id == *(lbm_cid*)cid) {
937 *(bool_Bool*)b = true1;
938 }
939}
940
941bool_Bool lbm_wait_ctx(lbm_cid cid, lbm_uint timeout_ms) {
942
943 bool_Bool exists;
944 uint32_t i = 0;
945
946 do {
947 exists = false0;
948 lbm_blocked_iterator(context_exists, &cid, &exists);
949 lbm_running_iterator(context_exists, &cid, &exists);
950
951 if (ctx_running &&
952 ctx_running->id == cid) {
953 exists = true1;
954 }
955
956 if (exists) {
957 if (usleep_callback) {
958 usleep_callback(1000);
959 }
960 if (timeout_ms > 0) i ++;
961 }
962 } while (exists && i < timeout_ms);
963
964 if (exists) return false0;
965 return true1;
966}
967
968void lbm_set_error_suspect(lbm_value suspect) {
969 lbm_error_suspect = suspect;
970 lbm_error_has_suspect = true1;
971}
972
973void lbm_set_error_reason(char *error_str) {
974 if (ctx_running != NULL((void*)0)) {
975 ctx_running->error_reason = error_str;
976 }
977}
978
979// Not possible to CONS_WITH_GC in error_ctx_base (potential loop)
980static void error_ctx_base(lbm_value err_val, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int column) {
981
982 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
983 if (lbm_heap_num_free() < 3) {
984 gc();
985 }
986
987 if (lbm_heap_num_free() >= 3) {
988 lbm_value msg = lbm_cons(err_val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
989 msg = lbm_cons(lbm_enc_i(ctx_running->id), msg);
990 msg = lbm_cons(ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u), msg);
991 if (!lbm_is_symbol_merror(msg)) {
992 lbm_find_receiver_and_send(ctx_running->parent, msg);
993 goto error_ctx_base_done;
994 }
995 }
996 }
997 if ((ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10) &&
998 (err_val != ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u))) {
999 lbm_uint v;
1000 while (ctx_running->K.sp > 0) {
1001 lbm_pop(&ctx_running->K, &v);
1002 if (v == EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u)) {
1003 lbm_value *sptr = get_stack_ptr(ctx_running, 2);
1004 lbm_set_car(sptr[0], ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
1005 stack_reserve(ctx_running, 1)[0] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1006 ctx_running->app_cont = true1;
1007 ctx_running->r = err_val;
1008 longjmp(error_jmp_buf, 1);
1009 }
1010 }
1011 err_val = ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u);
1012 }
1013 print_error_message(err_val,
1014 has_at,
1015 at,
1016 row,
1017 column,
1018 ctx_running->row0,
1019 ctx_running->row1);
1020 error_ctx_base_done:
1021 ctx_running->r = err_val;
1022 finish_ctx();
1023 longjmp(error_jmp_buf, 1);
1024}
1025
1026static void error_at_ctx(lbm_value err_val, lbm_value at) {
1027 error_ctx_base(err_val, true1, at, 0, 0);
1028}
1029
1030static void error_ctx(lbm_value err_val) {
1031 error_ctx_base(err_val, false0, 0, 0, 0);
1032}
1033
1034static void read_error_ctx(unsigned int row, unsigned int column) {
1035 error_ctx_base(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u), false0, 0, row, column);
1036}
1037
1038void lbm_critical_error(void) {
1039 longjmp(critical_error_jmp_buf, 1);
1040}
1041
1042// successfully finish a context
1043static void ok_ctx(void) {
1044 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
1045 lbm_value msg;
1046 WITH_GC(msg, lbm_heap_allocate_list_init(3,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1047 ENC_SYM_EXIT_OK,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1048 lbm_enc_i(ctx_running->id),(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1049 ctx_running->r))(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
1050 lbm_find_receiver_and_send(ctx_running->parent, msg);
1051 }
1052 finish_ctx();
1053}
1054
1055static eval_context_t *dequeue_ctx_nm(eval_context_queue_t *q) {
1056 if (q->last == NULL((void*)0)) {
1057 return NULL((void*)0);
1058 }
1059 // q->first should only be NULL if q->last is.
1060 eval_context_t *res = q->first;
1061
1062 if (q->first == q->last) { // One thing in queue
1063 q->first = NULL((void*)0);
1064 q->last = NULL((void*)0);
1065 } else {
1066 q->first = q->first->next;
1067 q->first->prev = NULL((void*)0);
1068 }
1069 res->prev = NULL((void*)0);
1070 res->next = NULL((void*)0);
1071 return res;
1072}
1073
1074static void wake_up_ctxs_nm(void) {
1075 lbm_uint t_now;
1076
1077 if (timestamp_us_callback) {
1078 t_now = timestamp_us_callback();
1079 } else {
1080 t_now = 0;
1081 }
1082
1083 eval_context_queue_t *q = &blocked;
1084 eval_context_t *curr = q->first;
1085
1086 while (curr != NULL((void*)0)) {
1087 lbm_uint t_diff;
1088 eval_context_t *next = curr->next;
1089 if (curr->state != LBM_THREAD_STATE_BLOCKED(uint32_t)1) {
1090 if ( curr->timestamp > t_now) {
1091 /* There was an overflow on the counter */
1092#ifndef LBM64
1093 t_diff = (0xFFFFFFFF - curr->timestamp) + t_now;
1094#else
1095 t_diff = (0xFFFFFFFFFFFFFFFF - curr->timestamp) + t_now;
1096#endif
1097 } else {
1098 t_diff = t_now - curr->timestamp;
1099 }
1100
1101 if (t_diff >= curr->sleep_us) {
1102 eval_context_t *wake_ctx = curr;
1103 if (curr == q->last) {
1104 if (curr->prev) {
1105 q->last = curr->prev;
1106 q->last->next = NULL((void*)0);
1107 } else {
1108 q->first = NULL((void*)0);
1109 q->last = NULL((void*)0);
1110 }
1111 } else if (curr->prev == NULL((void*)0)) {
1112 q->first = curr->next;
1113 q->first->prev = NULL((void*)0);
1114 } else {
1115 curr->prev->next = curr->next;
1116 if (curr->next) {
1117 curr->next->prev = curr->prev;
1118 }
1119 }
1120 wake_ctx->next = NULL((void*)0);
1121 wake_ctx->prev = NULL((void*)0);
1122 if (curr->state == LBM_THREAD_STATE_TIMEOUT(uint32_t)2) {
1123 mailbox_add_mail(wake_ctx, ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u));
1124 wake_ctx->r = ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u);
1125 }
1126 wake_ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1127 enqueue_ctx_nm(&queue, wake_ctx);
1128 }
1129 }
1130 curr = next;
1131 }
1132}
1133
1134static void yield_ctx(lbm_uint sleep_us) {
1135 if (timestamp_us_callback) {
1136 ctx_running->timestamp = timestamp_us_callback();
1137 ctx_running->sleep_us = sleep_us;
1138 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1139 } else {
1140 ctx_running->timestamp = 0;
1141 ctx_running->sleep_us = 0;
1142 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1143 }
1144 ctx_running->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1145 ctx_running->app_cont = true1;
1146 enqueue_ctx(&blocked,ctx_running);
1147 ctx_running = NULL((void*)0);
1148}
1149
1150static lbm_cid lbm_create_ctx_parent(lbm_value program, lbm_value env, lbm_uint stack_size, lbm_cid parent, uint32_t context_flags, char *name) {
1151
1152 if (!lbm_is_cons(program)) return -1;
1153
1154 eval_context_t *ctx = NULL((void*)0);
1155
1156 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1157 if (ctx == NULL((void*)0)) {
1158 lbm_uint roots[2] = {program, env};
1159 lbm_gc_mark_roots(roots, 2);
1160 gc();
1161 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1162 }
1163 if (ctx == NULL((void*)0)) return -1;
1164
1165 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1166 lbm_uint roots[2] = {program, env};
1167 lbm_gc_mark_roots(roots, 2);
1168 gc();
1169 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1170 lbm_memory_free((lbm_uint*)ctx);
1171 return -1;
1172 }
1173 }
1174
1175 lbm_value *mailbox = NULL((void*)0);
1176 mailbox = (lbm_value*)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1177 if (mailbox == NULL((void*)0)) {
1178 lbm_value roots[2] = {program, env};
1179 lbm_gc_mark_roots(roots,2);
1180 gc();
1181 mailbox = (lbm_value *)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1182 }
1183 if (mailbox == NULL((void*)0)) {
1184 lbm_stack_free(&ctx->K);
1185 lbm_memory_free((lbm_uint*)ctx);
1186 return -1;
1187 }
1188
1189 // TODO: Limit names to 19 chars + 1 char for 0? (or something similar).
1190 if (name) {
1191 lbm_uint name_len = strlen(name) + 1;
1192 ctx->name = lbm_malloc(strlen(name) + 1);
1193 if (ctx->name == NULL((void*)0)) {
1194 lbm_value roots[2] = {program, env};
1195 lbm_gc_mark_roots(roots, 2);
1196 gc();
1197 ctx->name = lbm_malloc(strlen(name) + 1);
1198 }
1199 if (ctx->name == NULL((void*)0)) {
1200 lbm_stack_free(&ctx->K);
1201 lbm_memory_free((lbm_uint*)mailbox);
1202 lbm_memory_free((lbm_uint*)ctx);
1203 return -1;
1204 }
1205 memcpy(ctx->name, name, name_len+1);
1206 } else {
1207 ctx->name = NULL((void*)0);
1208 }
1209
1210 lbm_int cid = lbm_memory_address_to_ix((lbm_uint*)ctx);
1211
1212 ctx->program = lbm_cdr(program);
1213 ctx->curr_exp = lbm_car(program);
1214 ctx->curr_env = env;
1215 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1216 ctx->error_reason = NULL((void*)0);
1217 ctx->mailbox = mailbox;
1218 ctx->mailbox_size = EVAL_CPS_DEFAULT_MAILBOX_SIZE10;
1219 ctx->flags = context_flags;
1220 ctx->num_mail = 0;
1221 ctx->app_cont = false0;
1222 ctx->timestamp = 0;
1223 ctx->sleep_us = 0;
1224 ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1225 ctx->prev = NULL((void*)0);
1226 ctx->next = NULL((void*)0);
1227
1228 ctx->row0 = -1;
1229 ctx->row1 = -1;
1230
1231 ctx->id = cid;
1232 ctx->parent = parent;
1233
1234 if (!lbm_push(&ctx->K, DONE(((0) << 2) | 0xF8000001u))) {
1235 lbm_memory_free((lbm_uint*)ctx->mailbox);
1236 lbm_stack_free(&ctx->K);
1237 lbm_memory_free((lbm_uint*)ctx);
1238 return -1;
1239 }
1240
1241 enqueue_ctx(&queue,ctx);
1242
1243 return ctx->id;
1244}
1245
1246lbm_cid lbm_create_ctx(lbm_value program, lbm_value env, lbm_uint stack_size, char *name) {
1247 // Creates a parentless context.
1248 return lbm_create_ctx_parent(program,
1249 env,
1250 stack_size,
1251 -1,
1252 EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00,
1253 name);
1254}
1255
1256bool_Bool lbm_mailbox_change_size(eval_context_t *ctx, lbm_uint new_size) {
1257
1258 lbm_value *mailbox = NULL((void*)0);
1259 mailbox = (lbm_value*)lbm_memory_allocate(new_size);
1260 if (mailbox == NULL((void*)0)) {
1261 gc();
1262 mailbox = (lbm_value *)lbm_memory_allocate(new_size);
1263 }
1264 if (mailbox == NULL((void*)0)) {
1265 return false0;
1266 }
1267
1268 for (lbm_uint i = 0; i < ctx->num_mail; i ++ ) {
1269 mailbox[i] = ctx->mailbox[i];
1270 }
1271 lbm_memory_free(ctx->mailbox);
1272 ctx->mailbox = mailbox;
1273 ctx->mailbox_size = (uint32_t)new_size;
1274 return true1;
1275}
1276
1277static void mailbox_remove_mail(eval_context_t *ctx, lbm_uint ix) {
1278
1279 for (lbm_uint i = ix; i < ctx->num_mail-1; i ++) {
1280 ctx->mailbox[i] = ctx->mailbox[i+1];
1281 }
1282 ctx->num_mail --;
1283}
1284
1285static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail) {
1286
1287 if (ctx->num_mail >= ctx->mailbox_size) {
1288 mailbox_remove_mail(ctx, 0);
1289 }
1290
1291 ctx->mailbox[ctx->num_mail] = mail;
1292 ctx->num_mail ++;
1293 return true1;
1294}
1295
1296/* Advance execution to the next expression in the program */
1297static void advance_ctx(eval_context_t *ctx) {
1298 if (lbm_is_cons(ctx->program)) {
1299 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);;
1300 get_car_and_cdr(ctx->program, &ctx->curr_exp, &ctx->program);
1301 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1302 } else {
1303 if (ctx_running == ctx) { // This should always be the case because of odd historical reasons.
1304 ok_ctx();
1305 }
1306 }
1307}
1308
1309bool_Bool lbm_unblock_ctx(lbm_cid cid, lbm_flat_value_t *fv) {
1310 return event_internal(LBM_EVENT_UNBLOCK_CTX, (lbm_uint)cid, (lbm_uint)fv->buf, fv->buf_size);
1311}
1312
1313bool_Bool lbm_unblock_ctx_r(lbm_cid cid) {
1314 mutex_lock(&blocking_extension_mutex);
1315 bool_Bool r = false0;
1316 eval_context_t *found = NULL((void*)0);
1317 mutex_lock(&qmutex);
1318 found = lookup_ctx_nm(&blocked, cid);
1319 if (found) {
1320 drop_ctx_nm(&blocked,found);
1321 enqueue_ctx_nm(&queue,found);
1322 r = true1;
1323 }
1324 mutex_unlock(&qmutex);
1325 mutex_unlock(&blocking_extension_mutex);
1326 return r;
1327}
1328
1329// unblock unboxed is also safe for rmbr:ed things.
1330bool_Bool lbm_unblock_ctx_unboxed(lbm_cid cid, lbm_value unboxed) {
1331 mutex_lock(&blocking_extension_mutex);
1332 bool_Bool r = false0;
1333 eval_context_t *found = NULL((void*)0);
1334 mutex_lock(&qmutex);
1335 found = lookup_ctx_nm(&blocked, cid);
1336 if (found) {
1337 drop_ctx_nm(&blocked,found);
1338 found->r = unboxed;
1339 if (lbm_is_error(unboxed)) {
1340 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
1341 found->app_cont = true1;
1342 }
1343 enqueue_ctx_nm(&queue,found);
1344 r = true1;
1345 }
1346 mutex_unlock(&qmutex);
1347 mutex_unlock(&blocking_extension_mutex);
1348 return r;
1349}
1350
1351static bool_Bool lbm_block_ctx_base(bool_Bool timeout, float t_s) {
1352 mutex_lock(&blocking_extension_mutex);
1353 blocking_extension = true1;
1354 if (timeout) {
1355 blocking_extension_timeout_us = S_TO_US(t_s)(lbm_uint)((t_s) * 1000000);
1356 blocking_extension_timeout = true1;
1357 } else {
1358 blocking_extension_timeout = false0;
1359 }
1360 return true1;
1361}
1362
1363void lbm_block_ctx_from_extension_timeout(float s) {
1364 lbm_block_ctx_base(true1, s);
1365}
1366
1367void lbm_block_ctx_from_extension(void) {
1368 lbm_block_ctx_base(false0, 0);
1369}
1370
1371// todo: May need to pop rmbrs from stack, if present.
1372// Suspect that the letting the discard cont run is really not a problem.
1373// Either way will be quite confusing what happens to allocated things when undoing block.
1374void lbm_undo_block_ctx_from_extension(void) {
1375 blocking_extension = false0;
1376 blocking_extension_timeout_us = 0;
1377 blocking_extension_timeout = false0;
1378 mutex_unlock(&blocking_extension_mutex);
1379}
1380
1381lbm_value lbm_find_receiver_and_send(lbm_cid cid, lbm_value msg) {
1382 mutex_lock(&qmutex);
1383 eval_context_t *found = NULL((void*)0);
1384 bool_Bool found_blocked = false0;
1385
1386 found = lookup_ctx_nm(&blocked, cid);
1387 if (found) found_blocked = true1;
1388
1389 if (found == NULL((void*)0)) {
1390 found = lookup_ctx_nm(&queue, cid);
1391 }
1392
1393 if (found) {
1394 if (!mailbox_add_mail(found, msg)) {
1395 mutex_unlock(&qmutex);
1396 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1397 }
1398
1399 if (found_blocked){
1400 drop_ctx_nm(&blocked,found);
1401 enqueue_ctx_nm(&queue,found);
1402 }
1403 mutex_unlock(&qmutex);
1404 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1405 }
1406
1407 /* check the current context */
1408 if (ctx_running && ctx_running->id == cid) {
1409 if (!mailbox_add_mail(ctx_running, msg)) {
1410 mutex_unlock(&qmutex);
1411 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1412 }
1413 mutex_unlock(&qmutex);
1414 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1415 }
1416 mutex_unlock(&qmutex);
1417 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1418}
1419
1420/* Pattern matching is currently implemented as a recursive
1421 function and make use of stack relative to the size of
1422 expressions that are being matched. */
1423static bool_Bool match(lbm_value p, lbm_value e, lbm_value *env, bool_Bool *gc) {
1424
1425 lbm_value binding;
1426
1427 if (lbm_is_match_binder(p)) {
1428 lbm_value var = get_cadr(p);
1429 lbm_value bindertype = get_car(p);
1430
1431 if (!lbm_is_symbol(var)) return false0;
1432
1433 switch (bindertype) {
1434 case ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u):
1435 if ( var == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) {
1436 return true1;
1437 }
1438 break;
1439 default: /* this should be an error case */
1440 return false0;
1441 }
1442 binding = lbm_cons(var, e);
1443 if ( lbm_type_of(binding) == LBM_TYPE_SYMBOL0x00000000u ) {
1444 *gc = true1;
1445 return false0;
1446 }
1447 *env = lbm_cons(binding, *env);
1448 if ( lbm_type_of(*env) == LBM_TYPE_SYMBOL0x00000000u ) {
1449 *gc = true1;
1450 return false0;
1451 }
1452 return true1;
1453 }
1454
1455 if (lbm_is_symbol(p)) {
1456 if (p == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return true1;
1457 return (p == e);
1458 }
1459 if (lbm_is_cons(p) &&
1460 lbm_is_cons(e) ) {
1461
1462 lbm_value headp, tailp;
1463 lbm_value heade, taile;
1464 get_car_and_cdr(p, &headp, &tailp);
1465 get_car_and_cdr(e, &heade, &taile); // Static analysis warns, but execution does not
1466 // past this point unless head and tail get initialized.
1467 if (!match(headp, heade, env, gc)) {
1468 return false0;
1469 }
1470 return match (tailp, taile, env, gc);
1471 }
1472 return struct_eq(p, e);
1473}
1474
1475// Find match is not very picky about syntax.
1476// A completely malformed recv form is most likely to
1477// just return no_match.
1478static int find_match(lbm_value plist, lbm_value *earr, lbm_uint num, lbm_value *e, lbm_value *env) {
1479
1480 // A pattern list is a list of pattern, expression lists.
1481 // ( (p1 e1) (p2 e2) ... (pn en))
1482 lbm_value curr_p = plist;
1483 int n = 0;
1484 bool_Bool gc = false0;
1485 for (int i = 0; i < (int)num; i ++ ) {
1486 lbm_value curr_e = earr[i];
1487 while (!lbm_is_symbol_nil(curr_p)) {
1488 lbm_value me = get_car(curr_p);
1489 if (match(get_car(me), curr_e, env, &gc)) {
1490 if (gc) return FM_NEED_GC-1;
1491 *e = get_cadr(me);
1492
1493 if (!lbm_is_symbol_nil(get_cadr(get_cdr(me)))) {
1494 return FM_PATTERN_ERROR-3;
1495 }
1496 return n;
1497 }
1498 curr_p = get_cdr(curr_p);
1499 }
1500 curr_p = plist; /* search all patterns against next exp */
1501 n ++;
1502 }
1503
1504 return FM_NO_MATCH-2;
1505}
1506
1507/****************************************************/
1508/* Garbage collection */
1509
1510static void mark_context(eval_context_t *ctx, void *arg1, void *arg2) {
1511 (void) arg1;
1512 (void) arg2;
1513 lbm_value roots[3] = {ctx->curr_exp, ctx->program, ctx->r };
1514 lbm_gc_mark_env(ctx->curr_env);
1515 lbm_gc_mark_roots(roots, 3);
1516 lbm_gc_mark_roots(ctx->mailbox, ctx->num_mail);
1517 lbm_gc_mark_aux(ctx->K.data, ctx->K.sp);
1518}
1519
1520static int gc(void) {
1521 if (ctx_running) {
1522 ctx_running->state = ctx_running->state | LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1523 }
1524
1525 gc_requested = false0;
1526 lbm_gc_state_inc();
1527
1528 // The freelist should generally be NIL when GC runs.
1529 lbm_nil_freelist();
1530 lbm_value *env = lbm_get_global_env();
1531 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
1532 lbm_gc_mark_env(env[i]);
1533 }
1534
1535 mutex_lock(&qmutex); // Lock the queues.
1536 // Any concurrent messing with the queues
1537 // while doing GC cannot possibly be good.
1538 queue_iterator_nm(&queue, mark_context, NULL((void*)0), NULL((void*)0));
1539 queue_iterator_nm(&blocked, mark_context, NULL((void*)0), NULL((void*)0));
1540
1541 if (ctx_running) {
1542 mark_context(ctx_running, NULL((void*)0), NULL((void*)0));
1543 }
1544 mutex_unlock(&qmutex);
1545
1546#ifdef VISUALIZE_HEAP
1547 heap_vis_gen_image();
1548#endif
1549
1550 int r = lbm_gc_sweep_phase();
1551 lbm_heap_new_freelist_length();
1552
1553 if (ctx_running) {
1554 ctx_running->state = ctx_running->state & ~LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1555 }
1556 return r;
1557}
1558
1559int lbm_perform_gc(void) {
1560 return gc();
1561}
1562
1563/****************************************************/
1564/* Evaluation functions */
1565
1566
1567static void eval_symbol(eval_context_t *ctx) {
1568 lbm_uint s = lbm_dec_sym(ctx->curr_exp);
1569 if (s >= RUNTIME_SYMBOLS_START0x40000) {
1570 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1571 if (lbm_env_lookup_b(&res, ctx->curr_exp, ctx->curr_env) ||
1572 lbm_global_env_lookup(&res, ctx->curr_exp)) {
1573 ctx->r = res;
1574 ctx->app_cont = true1;
1575 return;
1576 }
1577 // Dynamic load attempt
1578 // Only symbols of kind RUNTIME can be dynamically loaded.
1579 const char *sym_str = lbm_get_name_by_symbol(s);
1580 const char *code_str = NULL((void*)0);
1581 if (!dynamic_load_callback(sym_str, &code_str)) {
1582 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), ctx->curr_exp);
1583 }
1584 lbm_value *sptr = stack_reserve(ctx, 3);
1585 sptr[0] = ctx->curr_exp;
1586 sptr[1] = ctx->curr_env;
1587 sptr[2] = RESUME(((12) << 2) | 0xF8000001u);
1588
1589 lbm_value chan;
1590 if (!create_string_channel((char *)code_str, &chan)) {
1591 gc();
1592 if (!create_string_channel((char *)code_str, &chan)) {
1593 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1594 }
1595 }
1596
1597 lbm_value loader;
1598 WITH_GC_RMBR_1(loader, lbm_heap_allocate_list_init(2,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1599 ENC_SYM_READ,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1600 chan), chan)(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} };
1601 lbm_value evaluator;
1602 WITH_GC_RMBR_1(evaluator, lbm_heap_allocate_list_init(2,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1603 ENC_SYM_EVAL,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1604 loader), loader)(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } };
1605 ctx->curr_exp = evaluator;
1606 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // dynamics should be evaluable in empty local env
1607 } else {
1608 //special symbols and extensions can be handled the same way.
1609 ctx->r = ctx->curr_exp;
1610 ctx->app_cont = true1;
1611 }
1612}
1613
1614static void eval_quote(eval_context_t *ctx) {
1615 ctx->r = get_cadr(ctx->curr_exp);
1616 ctx->app_cont = true1;
1617}
1618
1619static void eval_selfevaluating(eval_context_t *ctx) {
1620 ctx->r = ctx->curr_exp;
1621 ctx->app_cont = true1;
1622}
1623
1624static void eval_progn(eval_context_t *ctx) {
1625 lbm_value exps = get_cdr(ctx->curr_exp);
1626
1627 if (lbm_is_cons(exps)) {
1628 lbm_uint *sptr = stack_reserve(ctx, 4);
1629 sptr[0] = ctx->curr_env; // env to restore between expressions in progn
1630 sptr[1] = lbm_enc_u(0); // Has env been copied (needed for progn local bindings)
1631 sptr[3] = PROGN_REST(((4) << 2) | 0xF8000001u);
1632 get_car_and_cdr(exps, &ctx->curr_exp, &sptr[2]);
1633 if (lbm_is_symbol(sptr[2])) /* The only symbol it can be is nil */
1634 lbm_stack_drop(&ctx->K, 4);
1635 } else if (lbm_is_symbol_nil(exps)) {
1636 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1637 ctx->app_cont = true1;
1638 } else {
1639 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1640 }
1641}
1642
1643static void eval_atomic(eval_context_t *ctx) {
1644 if (is_atomic) {
1645 lbm_set_error_reason("Atomic blocks cannot be nested!");
1646 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1647 }
1648 stack_reserve(ctx, 1)[0] = EXIT_ATOMIC(((14) << 2) | 0xF8000001u);
1649 is_atomic ++;
1650 eval_progn(ctx);
1651}
1652
1653/* (call-cc (lambda (k) .... )) */
1654static void eval_callcc(eval_context_t *ctx) {
1655 lbm_value cont_array;
1656 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1657 gc();
1658 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1659 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1660 return; // dead return but static analysis doesn't know :)
1661 }
1662 }
1663 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(cont_array);
1664 memcpy(arr->data, ctx->K.data, ctx->K.sp * sizeof(lbm_uint));
1665
1666 lbm_value acont = cons_with_gc(ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u), cont_array, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1667 lbm_value arg_list = cons_with_gc(acont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1668 // Go directly into application evaluation without passing go
1669 lbm_uint *sptr = stack_reserve(ctx, 3);
1670 sptr[0] = ctx->curr_env;
1671 sptr[1] = arg_list;
1672 sptr[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
1673 ctx->curr_exp = get_cadr(ctx->curr_exp);
1674}
1675
1676// (define sym exp)
1677#define KEY1 1
1678#define VAL2 2
1679static void eval_define(eval_context_t *ctx) {
1680 lbm_value parts[3];
1681 lbm_value rest = extract_n(ctx->curr_exp, parts, 3);
1682 lbm_uint *sptr = stack_reserve(ctx, 2);
1683 if (lbm_is_symbol(parts[KEY1]) && lbm_is_symbol_nil(rest)) {
1684 lbm_uint sym_val = lbm_dec_sym(parts[KEY1]);
1685 sptr[0] = parts[KEY1];
1686 if (sym_val >= RUNTIME_SYMBOLS_START0x40000) {
1687 sptr[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
1688 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02) {
1689 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
1690 }
1691 ctx->curr_exp = parts[VAL2];
1692 return;
1693 }
1694 }
1695 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
1696}
1697
1698
1699/* Eval lambda is cheating, a lot! It does this
1700 for performance reasons. The cheats are that
1701 1. When closure is created, a reference to the local env
1702 in which the lambda was evaluated is added to the closure.
1703 Ideally it should have created a list of free variables in the function
1704 and then looked up the values of these creating a new environment.
1705 2. The global env is considered global constant. As there is no copying
1706 of environment bindings into the closure, undefine may break closures.
1707
1708 Correct closure creation is a lot more expensive than what happens here.
1709 However, one can try to write programs in such a way that closures are created
1710 seldomly. If one does that the space-usage benefits of "correct" closures
1711 may outweigh the performance gain of "incorrect" ones.
1712
1713 some obscure programs such as test_setq_local_closure.lisp does not
1714 work properly due to this cheating.
1715 */
1716// (lambda param-list body-exp) -> (closure param-list body-exp env)
1717static void eval_lambda(eval_context_t *ctx) {
1718 lbm_value vals[3];
1719 extract_n(ctx->curr_exp, vals, 3);
1720 ctx->r = allocate_closure(vals[1],vals[2], ctx->curr_env);
1721#ifdef CLEAN_UP_CLOSURES
1722 lbm_uint sym_id = 0;
1723 if (clean_cl_env_symbol) {
1724 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1725 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1726 ctx->curr_exp = app;
1727 } else if (lbm_get_symbol_by_name("clean-cl-env", &sym_id)) {
1728 clean_cl_env_symbol = lbm_enc_sym(sym_id);
1729 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1730 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1731 ctx->curr_exp = app;
1732 } else {
1733 ctx->app_cont = true1;
1734 }
1735#else
1736 ctx->app_cont = true1;
1737#endif
1738}
1739
1740// (if cond-expr then-expr else-expr)
1741static void eval_if(eval_context_t *ctx) {
1742 lbm_value cdr = get_cdr(ctx->curr_exp);
1743 lbm_value *sptr = stack_reserve(ctx, 3);
1744 sptr[0] = get_cdr(cdr);
1745 sptr[1] = ctx->curr_env;
1746 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1747 ctx->curr_exp = get_car(cdr);
1748}
1749
1750// (cond (cond-expr-1 expr-1)
1751// ...
1752// (cond-expr-N expr-N))
1753static void eval_cond(eval_context_t *ctx) {
1754 lbm_value cond1[2];
1755 lbm_value rest_conds = extract_n(ctx->curr_exp, cond1, 2);
1756
1757 // end recursion at (cond )
1758 if (lbm_is_symbol_nil(cond1[1])) {
1759 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1760 ctx->app_cont = true1;
1761 } else {
1762 // Cond is one of the few places where a bit of syntax checking takes place at runtime..
1763 // Maybe dont bother?
1764 lbm_uint len = lbm_list_length(cond1[1]);
1765 if (len != 2) {
1766 lbm_set_error_reason("Incorrect syntax in cond");
1767 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1768 }
1769 lbm_value cond_expr[2];
1770 extract_n(cond1[1], cond_expr, 2);
1771 lbm_value rest;
1772 WITH_GC(rest, lbm_heap_allocate_list_init(2,(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1773 cond_expr[1], // Then branch(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1774 cons_with_gc(ENC_SYM_COND, rest_conds , ENC_SYM_NIL)))(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
1775 lbm_value *sptr = stack_reserve(ctx, 3);
1776 sptr[0] = rest;
1777 sptr[1] = ctx->curr_env;
1778 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1779 ctx->curr_exp = cond_expr[0]; //condition;
1780 }
1781}
1782
1783static void eval_app_cont(eval_context_t *ctx) {
1784 lbm_stack_drop(&ctx->K, 1);
1785 ctx->app_cont = true1;
1786}
1787
1788// Create a named location in an environment to later receive a value.
1789static binding_location_status create_binding_location_internal(lbm_value key, lbm_value *env) {
1790
1791 if (lbm_is_symbol(key) &&
1792 (key == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u) ||
1793 key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)))
1794 return BL_OK;
1795
1796 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) { // default case
1797 lbm_value binding;
1798 lbm_value new_env_tmp;
1799 binding = lbm_cons(key, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1800 new_env_tmp = lbm_cons(binding, *env);
1801 if (lbm_is_symbol(binding) || lbm_is_symbol(new_env_tmp)) {
1802 return BL_NO_MEMORY;
1803 }
1804 *env = new_env_tmp;
1805 } else if (lbm_is_cons(key)) { // deconstruct case
1806 int r = create_binding_location_internal(get_car(key), env);
1807 if (r == BL_OK) {
1808 r = create_binding_location_internal(get_cdr(key), env);
1809 }
1810 return r;
1811 }
1812 return BL_OK;
1813}
1814
1815static void create_binding_location(lbm_value key, lbm_value *env) {
1816
1817 lbm_value env_tmp = *env;
1818 binding_location_status r = create_binding_location_internal(key, &env_tmp);
1819 if (r != BL_OK) {
1820 if (r == BL_NO_MEMORY) {
1821 env_tmp = *env;
1822 lbm_gc_mark_phase(env_tmp);
1823 gc();
1824 r = create_binding_location_internal(key, &env_tmp);
1825 }
1826 switch(r) {
1827 case BL_OK:
1828 break;
1829 case BL_NO_MEMORY:
1830 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1831 break;
1832 case BL_INCORRECT_KEY:
1833 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
1834 break;
1835 }
1836 }
1837 *env = env_tmp;
1838}
1839
1840static void let_bind_values_eval(lbm_value binds, lbm_value exp, lbm_value env, eval_context_t *ctx) {
1841
1842 if (!lbm_is_cons(binds)) {
1843 // binds better be nil or there is a programmer error.
1844 ctx->curr_exp = exp;
1845 return;
1846 }
1847
1848 // Preallocate binding locations.
1849 lbm_value curr = binds;
1850 while (lbm_is_cons(curr)) {
1851 lbm_value new_env_tmp = env;
1852 lbm_value car_curr, cdr_curr;
1853 get_car_and_cdr(curr, &car_curr, &cdr_curr);
1854 lbm_value key = get_car(car_curr);
1855 create_binding_location(key, &new_env_tmp);
1856 env = new_env_tmp;
1857 curr = cdr_curr;
1858 }
1859
1860 lbm_value car_binds;
1861 lbm_value cdr_binds;
1862 get_car_and_cdr(binds, &car_binds, &cdr_binds);
1863 lbm_value key_val[2];
1864 extract_n(car_binds, key_val, 2);
1865
1866 lbm_uint *sptr = stack_reserve(ctx, 5);
1867 sptr[0] = exp;
1868 sptr[1] = cdr_binds;
1869 sptr[2] = env;
1870 sptr[3] = key_val[0];
1871 sptr[4] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
1872 ctx->curr_exp = key_val[1];
1873 ctx->curr_env = env;
1874}
1875
1876// (var x (...)) - local binding inside of an progn
1877// var has to take, place root-level nesting within progn.
1878// (progn ... (var a 10) ...) OK!
1879// (progn ... (something (var a 10)) ... ) NOT OK!
1880/* progn stack
1881 sp-4 : env
1882 sp-3 : 0
1883 sp-2 : rest
1884 sp-1 : PROGN_REST
1885*/
1886static void eval_var(eval_context_t *ctx) {
1887
1888 if (ctx->K.sp >= 4) { // Possibly in progn
1889 lbm_value sv = ctx->K.data[ctx->K.sp - 1];
1890 if (IS_CONTINUATION(sv)(((sv) & 0xF8000001u) == 0xF8000001u) && (sv == PROGN_REST(((4) << 2) | 0xF8000001u))) {
1891 lbm_uint sp = ctx->K.sp;
1892 uint32_t is_copied = lbm_dec_as_u32(ctx->K.data[sp-3]);
1893 if (is_copied == 0) {
1894 lbm_value env;
1895 WITH_GC(env, lbm_env_copy_spine(ctx->K.data[sp-4]))(env) = (lbm_env_copy_spine(ctx->K.data[sp-4])); if (lbm_is_symbol_merror
((env))) { gc(); (env) = (lbm_env_copy_spine(ctx->K.data[sp
-4])); if (lbm_is_symbol_merror((env))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1896 ctx->K.data[sp-3] = lbm_enc_u(1);
1897 ctx->K.data[sp-4] = env;
1898 }
1899 lbm_value new_env = ctx->K.data[sp-4];
1900 lbm_value args = get_cdr(ctx->curr_exp);
1901 lbm_value key = get_car(args);
1902 create_binding_location(key, &new_env);
1903 ctx->K.data[sp-4] = new_env;
1904
1905 lbm_value v_exp = get_cadr(args);
1906 lbm_value *sptr = stack_reserve(ctx, 3);
1907 sptr[0] = new_env;
1908 sptr[1] = key;
1909 sptr[2] = PROGN_VAR(((29) << 2) | 0xF8000001u);
1910 // Activating the new environment before the evaluation of the value to be bound,
1911 // means that other variables with same name will be shadowed already in the value
1912 // body.
1913 // The way closures work, the var-variable needs to be in scope during val evaluation
1914 // for a recursive closure to be possible.
1915 ctx->curr_env = new_env;
1916 ctx->curr_exp = v_exp;
1917 return;
1918 }
1919 }
1920 lbm_set_error_reason((char*)lbm_error_str_var_outside_progn);
1921 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1922}
1923
1924// (setq x (...)) - same as (set 'x (...)) or (setvar 'x (...))
1925static void eval_setq(eval_context_t *ctx) {
1926 lbm_value parts[3];
1927 extract_n(ctx->curr_exp, parts, 3);
1928 lbm_value *sptr = stack_reserve(ctx, 3);
1929 sptr[0] = ctx->curr_env;
1930 sptr[1] = parts[1];
1931 sptr[2] = SETQ(((30) << 2) | 0xF8000001u);
1932 ctx->curr_exp = parts[2];
1933}
1934
1935static void eval_move_to_flash(eval_context_t *ctx) {
1936 lbm_value args = get_cdr(ctx->curr_exp);
1937 lbm_value *sptr = stack_reserve(ctx,2);
1938 sptr[0] = args;
1939 sptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
1940 ctx->app_cont = true1;
1941}
1942
1943// (loop list-of-local-bindings
1944// condition-exp
1945// body-exp)
1946static void eval_loop(eval_context_t *ctx) {
1947 lbm_value env = ctx->curr_env;
1948 lbm_value parts[3];
1949 extract_n(get_cdr(ctx->curr_exp), parts, 3);
1950 lbm_value *sptr = stack_reserve(ctx, 3);
1951 sptr[0] = parts[LOOP_BODY2];
1952 sptr[1] = parts[LOOP_COND1];
1953 sptr[2] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
1954 let_bind_values_eval(parts[LOOP_BINDS0], parts[LOOP_COND1], env, ctx);
1955}
1956
1957/* (trap expression)
1958 *
1959 * suggested use:
1960 * (match (trap expression)
1961 * ((exit-error (? err)) (error-handler err))
1962 * ((exit-ok (? v)) (value-handler v)))
1963 */
1964static void eval_trap(eval_context_t *ctx) {
1965
1966 lbm_value expr = get_cadr(ctx->curr_exp);
1967 lbm_value retval;
1968 WITH_GC(retval, lbm_heap_allocate_list(2))(retval) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((retval))) { gc(); (retval) = (lbm_heap_allocate_list(2)); if
(lbm_is_symbol_merror((retval))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1969 lbm_set_car(retval, ENC_SYM_EXIT_OK(((0x3000B) << 4) | 0x00000000u)); // Assume things will go well.
1970 lbm_uint *sptr = stack_reserve(ctx,3);
1971 sptr[0] = retval;
1972 sptr[1] = ctx->flags;
1973 sptr[2] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1974 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10;
1975 ctx->curr_exp = expr;
1976}
1977
1978// (let list-of-binding s
1979// body-exp)
1980static void eval_let(eval_context_t *ctx) {
1981 lbm_value env = ctx->curr_env;
1982 lbm_value parts[3];
1983 extract_n(ctx->curr_exp, parts, 3);
1984 let_bind_values_eval(parts[1], parts[2], env, ctx);
1985}
1986
1987// (and exp0 ... expN)
1988static void eval_and(eval_context_t *ctx) {
1989 lbm_value rest = get_cdr(ctx->curr_exp);
1990 if (lbm_is_symbol_nil(rest)) {
1991 ctx->app_cont = true1;
1992 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1993 } else {
1994 lbm_value *sptr = stack_reserve(ctx, 3);
1995 sptr[0] = ctx->curr_env;
1996 sptr[1] = get_cdr(rest);
1997 sptr[2] = AND(((6) << 2) | 0xF8000001u);
1998 ctx->curr_exp = get_car(rest);
1999 }
2000}
2001
2002// (or exp0 ... expN)
2003static void eval_or(eval_context_t *ctx) {
2004 lbm_value rest = get_cdr(ctx->curr_exp);
2005 if (lbm_is_symbol_nil(rest)) {
2006 ctx->app_cont = true1;
2007 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2008 } else {
2009 lbm_value *sptr = stack_reserve(ctx, 3);
2010 sptr[0] = ctx->curr_env;
2011 sptr[1] = get_cdr(rest);
2012 sptr[2] = OR(((7) << 2) | 0xF8000001u);
2013 ctx->curr_exp = get_car(rest);
2014 }
2015}
2016
2017// Pattern matching
2018// format:
2019// (match e (pattern body)
2020// (pattern body)
2021// ... )
2022//
2023// There can be an optional pattern guard:
2024// (match e (pattern guard body)
2025// ... )
2026// a guard is a boolean expression.
2027// Guards make match, pattern matching more complicated
2028// than the recv pattern matching and requires staged execution
2029// via the continuation system rather than a while loop over a list.
2030static void eval_match(eval_context_t *ctx) {
2031
2032 lbm_value rest = get_cdr(ctx->curr_exp);
2033 if (lbm_type_of(rest) == LBM_TYPE_SYMBOL0x00000000u &&
2034 rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
2035 // Someone wrote the program (match)
2036 ctx->app_cont = true1;
2037 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2038 } else {
2039 lbm_value cdr_rest;
2040 get_car_and_cdr(rest, &ctx->curr_exp, &cdr_rest);
2041 lbm_value *sptr = stack_reserve(ctx, 3);
2042 sptr[0] = cdr_rest;
2043 sptr[1] = ctx->curr_env;
2044 sptr[2] = MATCH(((9) << 2) | 0xF8000001u);
2045 }
2046}
2047
2048static void receive_base(eval_context_t *ctx, lbm_value pats, float timeout_time, bool_Bool timeout) {
2049 if (ctx->num_mail == 0) {
2050 if (timeout) {
2051 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000), false0);
2052 } else {
2053 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1,0,false0);
2054 }
2055 } else {
2056 lbm_value *msgs = ctx->mailbox;
2057 lbm_uint num = ctx->num_mail;
2058
2059 if (lbm_is_symbol_nil(pats)) {
2060 /* A receive statement without any patterns */
2061 ctx->app_cont = true1;
2062 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2063 } else {
2064 /* The common case */
2065 lbm_value e;
2066 lbm_value new_env = ctx->curr_env;
2067 int n = find_match(pats, msgs, num, &e, &new_env);
2068 if (n == FM_NEED_GC-1) {
2069 gc();
2070 new_env = ctx->curr_env;
2071 n = find_match(pats, msgs, num, &e, &new_env);
2072 if (n == FM_NEED_GC-1) {
2073 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2074 }
2075 }
2076 if (n == FM_PATTERN_ERROR-3) {
2077 lbm_set_error_reason("Incorrect pattern format for recv");
2078 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),pats);
2079 } else if (n >= 0 ) { /* Match */
2080 mailbox_remove_mail(ctx, (lbm_uint)n);
2081 ctx->curr_env = new_env;
2082 ctx->curr_exp = e;
2083 } else { /* No match go back to sleep */
2084 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
2085 if (timeout) {
2086 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2,S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000),false0);
2087 } else {
2088 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,false0);
2089 }
2090 }
2091 }
2092 }
2093 return;
2094}
2095
2096static void eval_receive_timeout(eval_context_t *ctx) {
2097 if (is_atomic) {
2098 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2099 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2100 }
2101 lbm_value timeout_val = get_cadr(ctx->curr_exp);
2102 if (!lbm_is_number(timeout_val)) {
2103 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2104 }
2105 float timeout_time = lbm_dec_as_float(timeout_val);
2106 lbm_value pats = get_cdr(get_cdr(ctx->curr_exp));
2107 receive_base(ctx, pats, timeout_time, true1);
2108}
2109
2110// Receive
2111// (recv (pattern expr)
2112// (pattern expr))
2113static void eval_receive(eval_context_t *ctx) {
2114
2115 if (is_atomic) {
2116 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2117 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
2118 }
2119 lbm_value pats = get_cdr(ctx->curr_exp);
2120 receive_base(ctx, pats, 0, false0);
2121}
2122
2123/*********************************************************/
2124/* Continuation functions */
2125
2126/* cont_set_global_env
2127 sp-1 : Key-symbol
2128 */
2129static void cont_set_global_env(eval_context_t *ctx){
2130
2131 lbm_value key;
2132 lbm_value val = ctx->r;
2133
2134 lbm_pop(&ctx->K, &key);
2135 lbm_uint dec_key = lbm_dec_sym(key);
2136 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
2137 lbm_value *global_env = lbm_get_global_env();
2138 lbm_uint orig_env = global_env[ix_key];
2139 lbm_value new_env;
2140 // A key is a symbol and should not need to be remembered.
2141 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2142
2143 global_env[ix_key] = new_env;
2144 ctx->r = val;
2145
2146 ctx->app_cont = true1;
2147
2148 return;
2149}
2150
2151static void cont_resume(eval_context_t *ctx) {
2152 lbm_pop_2(&ctx->K, &ctx->curr_env, &ctx->curr_exp);
2153}
2154
2155static void cont_progn_rest(eval_context_t *ctx) {
2156 lbm_value *sptr = get_stack_ptr(ctx, 3);
2157
2158 lbm_value rest = sptr[2];
2159 lbm_value env = sptr[0];
2160
2161 lbm_value rest_car, rest_cdr;
2162 get_car_and_cdr(rest, &rest_car, &rest_cdr);
2163 ctx->curr_exp = rest_car;
2164 ctx->curr_env = env;
2165 if (lbm_is_symbol_nil(rest_cdr)) {
2166 // allow for tail recursion
2167 lbm_stack_drop(&ctx->K, 3);
2168 } else {
2169 sptr[2] = rest_cdr;
2170 stack_reserve(ctx, 1)[0] = PROGN_REST(((4) << 2) | 0xF8000001u);
2171 }
2172}
2173
2174static void cont_wait(eval_context_t *ctx) {
2175
2176 lbm_value cid_val;
2177 lbm_pop(&ctx->K, &cid_val);
2178 lbm_cid cid = (lbm_cid)lbm_dec_i(cid_val);
2179
2180 bool_Bool exists = false0;
2181
2182 lbm_blocked_iterator(context_exists, &cid, &exists);
2183 lbm_running_iterator(context_exists, &cid, &exists);
2184
2185 if (ctx_running->id == cid) {
2186 exists = true1;
2187 }
2188
2189 if (exists) {
2190 lbm_value *sptr = stack_reserve(ctx, 2);
2191 sptr[0] = lbm_enc_i(cid);
2192 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2193 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2194 ctx->app_cont = true1;
2195 yield_ctx(50000);
2196 } else {
2197 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2198 ctx->app_cont = true1;
2199 }
2200}
2201
2202static lbm_value perform_setvar(lbm_value key, lbm_value val, lbm_value env) {
2203
2204 lbm_uint s = lbm_dec_sym(key);
2205 if (s >= RUNTIME_SYMBOLS_START0x40000) {
2206 lbm_value new_env = lbm_env_modify_binding(env, key, val);
2207 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2208 lbm_uint ix_key = lbm_dec_sym(key) & GLOBAL_ENV_MASK0x1F;
2209 lbm_value *glob_env = lbm_get_global_env();
2210 new_env = lbm_env_modify_binding(glob_env[ix_key], key, val);
2211 glob_env[ix_key] = new_env;
2212 }
2213 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2214 lbm_set_error_reason((char*)lbm_error_str_variable_not_bound);
2215 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), key);
2216 }
2217 return val;
2218 }
2219 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2220 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // unreachable
2221}
2222
2223static void apply_setvar(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2224 if (nargs == 2 && lbm_is_symbol(args[0])) {
2225 lbm_value res;
2226 WITH_GC(res, perform_setvar(args[0], args[1], ctx->curr_env))(res) = (perform_setvar(args[0], args[1], ctx->curr_env));
if (lbm_is_symbol_merror((res))) { gc(); (res) = (perform_setvar
(args[0], args[1], ctx->curr_env)); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2227 ctx->r = args[1];
2228 lbm_stack_drop(&ctx->K, nargs+1);
2229 ctx->app_cont = true1;
2230 } else {
2231 if (nargs == 2) lbm_set_error_reason((char*)lbm_error_str_incorrect_arg);
2232 else lbm_set_error_reason((char*)lbm_error_str_num_args);
2233 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2234 }
2235}
2236
2237static void apply_read_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, bool_Bool program, bool_Bool incremental) {
2238 if (nargs == 1) {
2239 lbm_value chan = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2240 if (lbm_type_of_functional(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2241 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2242 gc();
2243 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2244 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2245 }
2246 }
2247 } else if (lbm_type_of(args[0]) == LBM_TYPE_CHANNEL0x90000000u) {
2248 chan = args[0];
2249 } else {
2250 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2251 }
2252 lbm_value *sptr = get_stack_ptr(ctx, 2);
2253
2254 // If we are inside a reader, its settings are stored.
2255 sptr[0] = lbm_enc_u(ctx->flags); // flags stored.
2256 sptr[1] = chan;
2257 lbm_value *rptr = stack_reserve(ctx,1);
2258 rptr[0] = READ_DONE(((20) << 2) | 0xF8000001u);
2259
2260 // Each reader starts in a fresh situation
2261 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
2262
2263 if (program) {
2264 if (incremental) {
2265 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2266 lbm_value *rptr1 = stack_reserve(ctx,3);
2267 rptr1[0] = chan;
2268 rptr1[1] = ctx->curr_env;
2269 rptr1[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
2270 } else {
2271 ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2272 lbm_value *rptr1 = stack_reserve(ctx,4);
2273 rptr1[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2274 rptr1[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2275 rptr1[2] = chan;
2276 rptr1[3] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
2277 }
2278 }
2279 rptr = stack_reserve(ctx,3); // reuse of variable rptr
2280 rptr[0] = chan;
2281 rptr[1] = lbm_enc_u(1);
2282 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
2283 ctx->app_cont = true1;
2284 } else {
2285 lbm_set_error_reason((char*)lbm_error_str_num_args);
2286 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2287 }
2288}
2289
2290static void apply_read_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2291 apply_read_base(args,nargs,ctx,true1,false0);
2292}
2293
2294static void apply_read_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2295 apply_read_base(args,nargs,ctx,true1,true1);
2296}
2297
2298static void apply_read(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2299 apply_read_base(args,nargs,ctx,false0,false0);
2300}
2301
2302static void apply_spawn_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, uint32_t context_flags) {
2303
2304 lbm_uint stack_size = EVAL_CPS_DEFAULT_STACK_SIZE256;
2305 lbm_uint closure_pos = 0;
2306 char *name = NULL((void*)0);
2307
2308 if (nargs >= 1 &&
2309 lbm_is_closure(args[0])) {
2310 closure_pos = 0;
2311 } else if (nargs >= 2 &&
2312 lbm_is_number(args[0]) &&
2313 lbm_is_closure(args[1])) {
2314 stack_size = lbm_dec_as_u32(args[0]);
2315 closure_pos = 1;
2316 } else if (nargs >= 2 &&
2317 lbm_is_array_r(args[0]) &&
2318 lbm_is_closure(args[1])) {
2319 name = lbm_dec_str(args[0]);
2320 closure_pos = 1;
2321 }else if (nargs >= 3 &&
2322 lbm_is_array_r(args[0]) &&
2323 lbm_is_number(args[1]) &&
2324 lbm_is_closure(args[2])) {
2325 stack_size = lbm_dec_as_u32(args[1]);
2326 closure_pos = 2;
2327 name = lbm_dec_str(args[0]);
2328 } else {
2329 if (context_flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01)
2330 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN_TRAP(((0x30005) << 4) | 0x00000000u));
2331 else
2332 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN(((0x30004) << 4) | 0x00000000u));
2333 }
2334
2335 lbm_value cl[3];
2336 extract_n(get_cdr(args[closure_pos]), cl, 3);
2337 lbm_value curr_param = cl[CLO_PARAMS0];
2338 lbm_value clo_env = cl[CLO_ENV2];
2339 lbm_uint i = closure_pos + 1;
2340 while (lbm_is_cons(curr_param) && i <= nargs) {
2341 lbm_value entry = cons_with_gc(get_car(curr_param), args[i], clo_env);
2342 lbm_value aug_env = cons_with_gc(entry, clo_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2343 clo_env = aug_env;
2344 curr_param = get_cdr(curr_param);
2345 i ++;
2346 }
2347
2348 lbm_stack_drop(&ctx->K, nargs+1);
2349
2350 lbm_value program = cons_with_gc(cl[CLO_BODY1], ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), clo_env);
2351
2352 lbm_cid cid = lbm_create_ctx_parent(program,
2353 clo_env,
2354 stack_size,
2355 lbm_get_current_cid(),
2356 context_flags,
2357 name);
2358 ctx->r = lbm_enc_i(cid);
2359 ctx->app_cont = true1;
2360}
2361
2362static void apply_spawn(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2363 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00);
2364}
2365
2366static void apply_spawn_trap(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2367 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01);
2368}
2369
2370static void apply_yield(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2371 if (is_atomic) {
2372 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2373 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2374 }
2375 if (nargs == 1 && lbm_is_number(args[0])) {
2376 lbm_uint ts = lbm_dec_as_u32(args[0]);
2377 lbm_stack_drop(&ctx->K, nargs+1);
2378 yield_ctx(ts);
2379 } else {
2380 lbm_set_error_reason((char*)lbm_error_str_no_number);
2381 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2382 }
2383}
2384
2385static void apply_sleep(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2386 if (is_atomic) {
2387 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2388 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2389 }
2390 if (nargs == 1 && lbm_is_number(args[0])) {
2391 lbm_uint ts = (lbm_uint)(1000000.0f * lbm_dec_as_float(args[0]));
2392 lbm_stack_drop(&ctx->K, nargs+1);
2393 yield_ctx(ts);
2394 } else {
2395 lbm_set_error_reason((char*)lbm_error_str_no_number);
2396 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2397 }
2398}
2399
2400static void apply_wait(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2401 if (nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2402 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2403 lbm_value *sptr = get_stack_ptr(ctx, 2);
2404 sptr[0] = lbm_enc_i(cid);
2405 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2406 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2407 ctx->app_cont = true1;
2408 yield_ctx(50000);
2409 } else {
2410 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_WAIT(((0x30007) << 4) | 0x00000000u));
2411 }
2412}
2413
2414/* (eval expr)
2415 (eval env expr) */
2416static void apply_eval(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2417 if ( nargs == 1) {
2418 ctx->curr_exp = args[0];
2419 } else if (nargs == 2) {
2420 ctx->curr_exp = args[1];
2421 ctx->curr_env = args[0];
2422 } else {
2423 lbm_set_error_reason((char*)lbm_error_str_num_args);
2424 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL(((0x30008) << 4) | 0x00000000u));
2425 }
2426 lbm_stack_drop(&ctx->K, nargs+1);
2427}
2428
2429static void apply_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2430 int prg_pos = 0;
2431 if (nargs == 2) {
2432 prg_pos = 1;
2433 ctx->curr_env = args[0];
2434 }
2435 if (nargs == 1 || nargs == 2) {
2436 lbm_value prg = args[prg_pos];
2437 lbm_value app_cont;
2438 lbm_value app_cont_prg;
2439 lbm_value new_prg;
2440 lbm_value prg_copy;
2441
2442 int len = -1;
2443 WITH_GC(prg_copy, lbm_list_copy(&len, prg))(prg_copy) = (lbm_list_copy(&len, prg)); if (lbm_is_symbol_merror
((prg_copy))) { gc(); (prg_copy) = (lbm_list_copy(&len, prg
)); if (lbm_is_symbol_merror((prg_copy))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2444 lbm_stack_drop(&ctx->K, nargs+1);
2445
2446 if (ctx->K.sp > nargs+2) { // if there is a continuation
2447 app_cont = cons_with_gc(ENC_SYM_APP_CONT(((0x111) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2448 app_cont_prg = cons_with_gc(app_cont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2449 new_prg = lbm_list_append(app_cont_prg, ctx->program);
2450 new_prg = lbm_list_append(prg_copy, new_prg);
2451 } else {
2452 new_prg = lbm_list_append(prg_copy, ctx->program);
2453 }
2454 if (!lbm_is_list(new_prg)) {
2455 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2456 }
2457 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);
2458 ctx->program = get_cdr(new_prg);
2459 ctx->curr_exp = get_car(new_prg);
2460 } else {
2461 lbm_set_error_reason((char*)lbm_error_str_num_args);
2462 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2463 }
2464}
2465
2466static void apply_send(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2467 if (nargs == 2) {
2468 if (lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2469 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2470 lbm_value msg = args[1];
2471 lbm_value status = lbm_find_receiver_and_send(cid, msg);
2472 /* return the status */
2473 lbm_stack_drop(&ctx->K, nargs+1);
2474 ctx->r = status;
2475 ctx->app_cont = true1;
2476 } else {
2477 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2478 }
2479 } else {
2480 lbm_set_error_reason((char*)lbm_error_str_num_args);
2481 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2482 }
2483}
2484
2485static void apply_ok(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2486 lbm_value ok_val = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2487 if (nargs >= 1) {
2488 ok_val = args[0];
2489 }
2490 ctx->r = ok_val;
2491 ok_ctx();
2492}
2493
2494static void apply_error(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2495 (void) ctx;
2496 lbm_value err_val = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
2497 if (nargs >= 1) {
2498 err_val = args[0];
2499 }
2500 error_at_ctx(err_val, ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
2501}
2502
2503// (map f arg-list)
2504static void apply_map(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2505 if (nargs == 2 && lbm_is_cons(args[1])) {
2506 lbm_value *sptr = get_stack_ptr(ctx, 3);
2507
2508 lbm_value f = args[0];
2509 lbm_value h = get_car(args[1]);
2510 lbm_value t = get_cdr(args[1]);
2511
2512 lbm_value appli_1;
2513 lbm_value appli;
2514 WITH_GC(appli_1, lbm_heap_allocate_list(2))(appli_1) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli_1))) { gc(); (appli_1) = (lbm_heap_allocate_list(2));
if (lbm_is_symbol_merror((appli_1))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2515 WITH_GC_RMBR_1(appli, lbm_heap_allocate_list(2), appli_1)(appli) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli))) { lbm_gc_mark_phase(appli_1); gc(); (appli) = (lbm_heap_allocate_list
(2)); if (lbm_is_symbol_merror((appli))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2516
2517 lbm_value appli_0 = get_cdr(appli_1);
2518
2519 lbm_set_car_and_cdr(appli_0, h, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2520 lbm_set_car(appli_1, ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u));
2521
2522 lbm_set_car_and_cdr(get_cdr(appli), appli_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2523 lbm_set_car(appli, f);
2524
2525 lbm_value elt = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), appli);
2526 sptr[0] = t; // reuse stack space
2527 sptr[1] = ctx->curr_env;
2528 sptr[2] = elt;
2529 lbm_value *rptr = stack_reserve(ctx,4);
2530 rptr[0] = elt;
2531 rptr[1] = appli;
2532 rptr[2] = appli_0;
2533 rptr[3] = MAP(((26) << 2) | 0xF8000001u);
2534 ctx->curr_exp = appli;
2535 } else if (nargs == 2 && lbm_is_symbol_nil(args[1])) {
2536 lbm_stack_drop(&ctx->K, 3);
2537 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2538 ctx->app_cont = true1;
2539 return;
2540 } else {
2541 lbm_set_error_reason((char*)lbm_error_str_num_args);
2542 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_MAP(((0x3000D) << 4) | 0x00000000u));
2543 }
2544}
2545
2546static void apply_reverse(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2547 if (nargs == 1 && lbm_is_list(args[0])) {
2548 lbm_value curr = args[0];
2549
2550 lbm_value new_list = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2551 while (lbm_is_cons(curr)) {
2552 lbm_value tmp = cons_with_gc(get_car(curr), new_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2553 new_list = tmp;
2554 curr = get_cdr(curr);
2555 }
2556 lbm_stack_drop(&ctx->K, 2);
2557 ctx->r = new_list;
2558 ctx->app_cont = true1;
2559 } else {
2560 lbm_set_error_reason("Reverse requires a list argument");
2561 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_REVERSE(((0x3000E) << 4) | 0x00000000u));
2562 }
2563}
2564
2565static void apply_flatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2566 if (nargs == 1) {
2567
2568 lbm_value v = flatten_value(args[0]);
2569 if ( v == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)) {
2570 gc();
2571 v = flatten_value(args[0]);
2572 }
2573
2574 if (lbm_is_symbol(v)) {
2575 error_at_ctx(v, ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2576 } else {
2577 lbm_stack_drop(&ctx->K, 2);
2578 ctx->r = v;
2579 ctx->app_cont = true1;
2580 }
2581 return;
2582 }
2583 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2584}
2585
2586static void apply_unflatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2587 if(nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2588 lbm_array_header_t *array;
2589 array = (lbm_array_header_t *)get_car(args[0]);
2590
2591 lbm_flat_value_t fv;
2592 fv.buf = (uint8_t*)array->data;
2593 fv.buf_size = array->size;
2594 fv.buf_pos = 0;
2595
2596 lbm_value res;
2597
2598 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2599 if (lbm_unflatten_value(&fv, &res)) {
2600 ctx->r = res;
2601 }
2602 lbm_stack_drop(&ctx->K, 2);
2603 ctx->app_cont = true1;
2604 return;
2605 }
2606 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_UNFLATTEN(((0x30010) << 4) | 0x00000000u));
2607}
2608
2609static void apply_kill(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2610 if (nargs == 2 && lbm_is_number(args[0])) {
2611 lbm_cid cid = lbm_dec_as_i32(args[0]);
2612
2613 if (ctx->id == cid) {
2614 ctx->r = args[1];
2615 finish_ctx();
2616 return;
2617 }
2618 mutex_lock(&qmutex);
2619 eval_context_t *found = NULL((void*)0);
2620 found = lookup_ctx_nm(&blocked, cid);
2621 if (found)
2622 drop_ctx_nm(&blocked, found);
2623 else
2624 found = lookup_ctx_nm(&queue, cid);
2625 if (found)
2626 drop_ctx_nm(&queue, found);
2627
2628 if (found) {
2629 found->K.data[found->K.sp - 1] = KILL(((40) << 2) | 0xF8000001u);
2630 found->r = args[1];
2631 found->app_cont = true1;
2632 enqueue_ctx_nm(&queue,found);
2633 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2634 } else {
2635 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2636 }
2637 lbm_stack_drop(&ctx->K, 3);
2638 ctx->app_cont = true1;
2639 mutex_unlock(&qmutex);
2640 return;
2641 }
2642 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_KILL(((0x30011) << 4) | 0x00000000u));
2643}
2644
2645// (merge comparator list1 list2)
2646static void apply_merge(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2647 if (nargs == 3 && lbm_is_list(args[1]) && lbm_is_list(args[2])) {
2648
2649 if (!lbm_is_closure(args[0])) {
2650 lbm_value closure;
2651 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2652 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2653 lbm_value cl1 = lbm_cdr(closure);
2654 lbm_value par;
2655 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2656 lbm_set_car(cl1, par);
2657 lbm_value cl2 = lbm_cdr(cl1);
2658 lbm_value body;
2659 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2660 lbm_set_car(cl2, body);
2661 lbm_value cl3 = lbm_cdr(cl2);
2662 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2663
2664 // Replace operator on stack with closure and rest of the code is
2665 // compatible.
2666 args[0] = closure;
2667 }
2668
2669 // Copy input lists for functional behaviour at top-level
2670 // merge itself is in-place in the copied lists.
2671 lbm_value a;
2672 lbm_value b;
2673 int len_a = -1;
2674 int len_b = -1;
2675 WITH_GC(a, lbm_list_copy(&len_a, args[1]))(a) = (lbm_list_copy(&len_a, args[1])); if (lbm_is_symbol_merror
((a))) { gc(); (a) = (lbm_list_copy(&len_a, args[1])); if
(lbm_is_symbol_merror((a))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } };
2676 WITH_GC_RMBR_1(b, lbm_list_copy(&len_b, args[2]), a)(b) = (lbm_list_copy(&len_b, args[2])); if (lbm_is_symbol_merror
((b))) { lbm_gc_mark_phase(a); gc(); (b) = (lbm_list_copy(&
len_b, args[2])); if (lbm_is_symbol_merror((b))) { error_ctx(
(((0x23) << 4) | 0x00000000u)); } };
2677
2678 if (len_a == 0) {
2679 ctx->r = b;
2680 lbm_stack_drop(&ctx->K, 4);
2681 ctx->app_cont = true1;
2682 return;
2683 }
2684 if (len_b == 0) {
2685 ctx->r = a;
2686 lbm_stack_drop(&ctx->K, 4);
2687 ctx->app_cont = true1;
2688 return;
2689 }
2690
2691 args[1] = a; // keep safe by replacing the original on stack.
2692 args[2] = b;
2693
2694 lbm_value a_1 = a;
2695 lbm_value a_rest = lbm_cdr(a);
2696 lbm_value b_1 = b;
2697 lbm_value b_rest = lbm_cdr(b);
2698
2699 lbm_value cl[3]; // Comparator closure
2700 extract_n(lbm_cdr(args[0]), cl, 3);
2701 lbm_value cmp_env = cl[CLO_ENV2];
2702 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2703 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2704 lbm_uint len = lbm_list_length(cl[CLO_PARAMS0]);
2705 if (len == 2) {
2706 par1 = get_car(cl[CLO_PARAMS0]);
2707 par2 = get_cadr(cl[CLO_PARAMS0]);
2708 lbm_value new_env0;
2709 lbm_value new_env;
2710 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a_1)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a_1))); if (
lbm_is_symbol_merror((new_env0))) { gc(); (new_env0) = (lbm_env_set
(cmp_env, par1, lbm_car(a_1))); if (lbm_is_symbol_merror((new_env0
))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2711 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b_1)),new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1))); if (
lbm_is_symbol_merror((new_env))) { lbm_gc_mark_phase(new_env0
); gc(); (new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1
))); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2712 cmp_env = new_env;
2713 } else {
2714 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2715 }
2716 lbm_set_cdr(a_1, b_1);
2717 lbm_set_cdr(b_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2718 lbm_value cmp = cl[CLO_BODY1];
2719
2720 lbm_stack_drop(&ctx->K, 4); // TODO: Optimize drop 4 alloc 10 into alloc 6
2721 lbm_uint *sptr = stack_reserve(ctx, 10);
2722 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged list
2723 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged list
2724 sptr[2] = a_1;
2725 sptr[3] = a_rest;
2726 sptr[4] = b_rest;
2727 sptr[5] = cmp;
2728 sptr[6] = cmp_env;
2729 sptr[7] = par1;
2730 sptr[8] = par2;
2731 sptr[9] = MERGE_REST(((43) << 2) | 0xF8000001u);
2732 ctx->curr_exp = cl[CLO_BODY1];
2733 ctx->curr_env = cmp_env;
2734 return;
2735 }
2736 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MERGE(((0x30013) << 4) | 0x00000000u));
2737}
2738
2739// (sort comparator list)
2740static void apply_sort(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2741 if (nargs == 2 && lbm_is_list(args[1])) {
2742
2743 if (!lbm_is_closure(args[0])) {
2744 lbm_value closure;
2745 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2746 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2747 lbm_value cl1 = lbm_cdr(closure);
2748 lbm_value par;
2749 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2750 lbm_set_car(cl1, par);
2751 lbm_value cl2 = lbm_cdr(cl1);
2752 lbm_value body;
2753 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2754 lbm_set_car(cl2, body);
2755 lbm_value cl3 = lbm_cdr(cl2);
2756 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2757
2758 // Replace operator on stack with closure and rest of the code is
2759 // compatible.
2760 args[0] = closure;
2761 }
2762
2763 int len = -1;
2764 lbm_value list_copy;
2765 WITH_GC(list_copy, lbm_list_copy(&len, args[1]))(list_copy) = (lbm_list_copy(&len, args[1])); if (lbm_is_symbol_merror
((list_copy))) { gc(); (list_copy) = (lbm_list_copy(&len,
args[1])); if (lbm_is_symbol_merror((list_copy))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2766 if (len <= 1) {
2767 lbm_stack_drop(&ctx->K, 3);
2768 ctx->r = list_copy;
2769 ctx->app_cont = true1;
2770 return;
2771 }
2772
2773 args[1] = list_copy; // Keep safe, original replaced on stack.
2774
2775 // Take the headmost 2, 1-element sublists.
2776 lbm_value a = list_copy;
2777 lbm_value b = lbm_cdr(a);
2778 lbm_value rest = lbm_cdr(b);
2779 // Do not terminate b. keep rest of list safe from GC in the following
2780 // closure extraction.
2781 //lbm_set_cdr(a, b); // This is void
2782
2783 lbm_value cl[3]; // Comparator closure
2784 extract_n(lbm_cdr(args[0]), cl, 3);
2785 lbm_value cmp_env = cl[CLO_ENV2];
2786 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2787 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2788 lbm_uint cl_len = lbm_list_length(cl[CLO_PARAMS0]);
2789 if (cl_len == 2) {
2790 par1 = get_car(cl[CLO_PARAMS0]);
2791 par2 = get_cadr(cl[CLO_PARAMS0]);
2792 lbm_value new_env0;
2793 lbm_value new_env;
2794 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a))); if (lbm_is_symbol_merror
((new_env0))) { gc(); (new_env0) = (lbm_env_set(cmp_env, par1
, lbm_car(a))); if (lbm_is_symbol_merror((new_env0))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2795 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b)), new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { lbm_gc_mark_phase(new_env0); gc(); (new_env) =
(lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { error_ctx((((0x23) << 4) | 0x00000000u))
; } };
2796 cmp_env = new_env;
2797 } else {
2798 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2799 }
2800 lbm_value cmp = cl[CLO_BODY1];
2801
2802 // Terminate the comparator argument list.
2803 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2804
2805 lbm_stack_drop(&ctx->K, 3); //TODO: optimize drop 3, alloc 20 into alloc 17
2806 lbm_uint *sptr = stack_reserve(ctx, 20);
2807 sptr[0] = cmp;
2808 sptr[1] = cmp_env;
2809 sptr[2] = par1;
2810 sptr[3] = par2;
2811 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged accumulation of sublists
2812 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged accumulation of sublists
2813 sptr[6] = rest;
2814 sptr[7] = lbm_enc_i(1);
2815 sptr[8] = lbm_enc_i(len); //TODO: 28 bit i vs 32 bit i
2816 sptr[9] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
2817 sptr[10] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged sublist
2818 sptr[11] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged sublist
2819 sptr[12] = a;
2820 sptr[13] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no a_rest, 1 element lists in layer 1.
2821 sptr[14] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no b_rest, 1 element lists in layer 1.
2822 sptr[15] = cmp;
2823 sptr[16] = cmp_env;
2824 sptr[17] = par1;
2825 sptr[18] = par2;
2826 sptr[19] = MERGE_REST(((43) << 2) | 0xF8000001u);
2827 ctx->curr_exp = cmp;
2828 ctx->curr_env = cmp_env;
2829 return;
2830 }
2831 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
2832}
2833
2834static void apply_rest_args(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2835 lbm_value res;
2836 if (lbm_env_lookup_b(&res, ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ctx->curr_env)) {
2837 if (nargs == 1 && lbm_is_number(args[0])) {
2838 int32_t ix = lbm_dec_as_i32(args[0]);
2839 res = lbm_index_list(res, ix);
2840 }
2841 ctx->r = res;
2842 } else {
2843 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2844 }
2845 lbm_stack_drop(&ctx->K, nargs+1);
2846 ctx->app_cont = true1;
2847}
2848
2849/* (rotate list-expr dist/dir-expr) */
2850static void apply_rotate(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2851 if (nargs == 2 && lbm_is_list(args[0]) && lbm_is_number(args[1])) {
2852 int len = -1;
2853 lbm_value ls = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2854 WITH_GC(ls, lbm_list_copy(&len, args[0]))(ls) = (lbm_list_copy(&len, args[0])); if (lbm_is_symbol_merror
((ls))) { gc(); (ls) = (lbm_list_copy(&len, args[0])); if
(lbm_is_symbol_merror((ls))) { error_ctx((((0x23) << 4
) | 0x00000000u)); } };
2855 int dist = lbm_dec_as_i32(args[1]);
2856 if (len > 0 && dist != 0) {
2857 int d = dist;
2858 if (dist > 0) {
2859 ls = lbm_list_destructive_reverse(ls);
2860 } else {
2861 d = -dist;
2862 }
2863
2864 lbm_value start = ls;
2865 lbm_value end = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2866 lbm_value curr = start;
2867 while (lbm_is_cons(curr)) {
2868 end = curr;
2869 curr = get_cdr(curr);
2870 }
2871
2872 for (int i = 0; i < d; i ++) {
2873 lbm_value a = start;
2874 start = lbm_cdr(start);
2875 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2876 lbm_set_cdr(end, a);
2877 end = a;
2878 }
2879 ls = start;
2880 if (dist > 0) {
2881 ls = lbm_list_destructive_reverse(ls);
2882 }
2883 }
2884 lbm_stack_drop(&ctx->K, nargs+1);
2885 ctx->app_cont = true1;
2886 ctx->r = ls;
2887 return;
2888 }
2889 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2890}
2891
2892/***************************************************/
2893/* Application lookup table */
2894
2895typedef void (*apply_fun)(lbm_value *, lbm_uint, eval_context_t *);
2896static const apply_fun fun_table[] =
2897 {
2898 apply_setvar,
2899 apply_read,
2900 apply_read_program,
2901 apply_read_eval_program,
2902 apply_spawn,
2903 apply_spawn_trap,
2904 apply_yield,
2905 apply_wait,
2906 apply_eval,
2907 apply_eval_program,
2908 apply_send,
2909 apply_ok,
2910 apply_error,
2911 apply_map,
2912 apply_reverse,
2913 apply_flatten,
2914 apply_unflatten,
2915 apply_kill,
2916 apply_sleep,
2917 apply_merge,
2918 apply_sort,
2919 apply_rest_args,
2920 apply_rotate,
2921 };
2922
2923/***************************************************/
2924/* Application of function that takes arguments */
2925/* passed over the stack. */
2926
2927static void application(eval_context_t *ctx, lbm_value *fun_args, lbm_uint arg_count) {
2928 /* If arriving here, we know that the fun is a symbol.
2929 * and can be a built in operation or an extension.
2930 */
2931 lbm_value fun = fun_args[0];
2932
2933 lbm_uint fun_val = lbm_dec_sym(fun);
2934 lbm_uint fun_kind = SYMBOL_KIND(fun_val)((fun_val) >> 16);
2935
2936 switch (fun_kind) {
2937 case SYMBOL_KIND_EXTENSION1: {
2938 extension_fptr f = extension_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)].fptr;
2939
2940 lbm_value ext_res;
2941 WITH_GC(ext_res, f(&fun_args[1], arg_count))(ext_res) = (f(&fun_args[1], arg_count)); if (lbm_is_symbol_merror
((ext_res))) { gc(); (ext_res) = (f(&fun_args[1], arg_count
)); if (lbm_is_symbol_merror((ext_res))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2942 if (lbm_is_error(ext_res)) { //Error other than merror
2943 error_at_ctx(ext_res, fun);
2944 }
2945 lbm_stack_drop(&ctx->K, arg_count + 1);
2946
2947 ctx->app_cont = true1;
2948 ctx->r = ext_res;
2949
2950 if (blocking_extension) {
2951 blocking_extension = false0;
2952 if (blocking_extension_timeout) {
2953 blocking_extension_timeout = false0;
2954 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, blocking_extension_timeout_us,true1);
2955 } else {
2956 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,true1);
2957 }
2958 mutex_unlock(&blocking_extension_mutex);
2959 }
2960 } break;
2961 case SYMBOL_KIND_FUNDAMENTAL2:
2962 call_fundamental(SYMBOL_IX(fun_val)((fun_val) & 0xFFFF), &fun_args[1], arg_count, ctx);
2963 break;
2964 case SYMBOL_KIND_APPFUN3:
2965 fun_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)](&fun_args[1], arg_count, ctx);
2966 break;
2967 default:
2968 // Symbols that are "special" but not in the way caught above
2969 // ends up here.
2970 lbm_set_error_reason("Symbol does not represent a function");
2971 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),fun_args[0]);
2972 break;
2973 }
2974}
2975
2976static void cont_closure_application_args(eval_context_t *ctx) {
2977 lbm_uint* sptr = get_stack_ptr(ctx, 5);
2978
2979 lbm_value arg_env = (lbm_value)sptr[0];
2980 lbm_value exp = (lbm_value)sptr[1];
2981 lbm_value clo_env = (lbm_value)sptr[2];
2982 lbm_value params = (lbm_value)sptr[3];
2983 lbm_value args = (lbm_value)sptr[4];
2984
2985 lbm_value car_params, cdr_params;
2986 get_car_and_cdr(params, &car_params, &cdr_params);
2987
2988 bool_Bool a_nil = lbm_is_symbol_nil(args);
2989 bool_Bool p_nil = lbm_is_symbol_nil(cdr_params);
2990
2991 lbm_value binder = allocate_binding(car_params, ctx->r, clo_env);
2992
2993 if (!a_nil && !p_nil) {
2994 lbm_value car_args, cdr_args;
2995 get_car_and_cdr(args, &car_args, &cdr_args);
2996 sptr[2] = binder;
2997 sptr[3] = cdr_params;
2998 sptr[4] = cdr_args;
2999 stack_reserve(ctx,1)[0] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
3000 ctx->curr_exp = car_args;
3001 ctx->curr_env = arg_env;
3002 } else if (a_nil && p_nil) {
3003 // Arguments and parameters match up in number
3004 lbm_stack_drop(&ctx->K, 5);
3005 ctx->curr_env = binder;
3006 ctx->curr_exp = exp;
3007 } else if (p_nil) {
3008 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), binder);
3009 sptr[2] = rest_binder;
3010 sptr[3] = get_cdr(args);
3011 sptr[4] = get_car(rest_binder); // last element of rest_args so far
3012 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3013 ctx->curr_exp = get_car(args);
3014 ctx->curr_env = arg_env;
3015 } else {
3016 lbm_set_error_reason((char*)lbm_error_str_num_args);
3017 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
3018 }
3019}
3020
3021
3022static void cont_closure_args_rest(eval_context_t *ctx) {
3023 lbm_uint* sptr = get_stack_ptr(ctx, 5);
3024 lbm_value arg_env = (lbm_value)sptr[0];
3025 lbm_value exp = (lbm_value)sptr[1];
3026 lbm_value clo_env = (lbm_value)sptr[2];
3027 lbm_value args = (lbm_value)sptr[3];
3028 lbm_value last = (lbm_value)sptr[4];
3029 lbm_cons_t* heap = lbm_heap_state.heap;
3030
3031 lbm_value binding = lbm_heap_state.freelist;
3032 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3033 gc();
3034 binding = lbm_heap_state.freelist;
3035 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3036 }
3037 lbm_uint binding_ix = lbm_dec_ptr(binding);
3038 lbm_heap_state.freelist = heap[binding_ix].cdr;
3039 lbm_heap_state.num_alloc += 1;
3040 heap[binding_ix].car = ctx->r;
3041 heap[binding_ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3042
3043
3044 lbm_set_cdr(last, binding);
3045 sptr[4] = binding;
3046
3047 if (args == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3048 lbm_stack_drop(&ctx->K, 5);
3049 ctx->curr_env = clo_env;
3050 ctx->curr_exp = exp;
3051 } else {
3052 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3053 sptr[3] = get_cdr(args);
3054 ctx->curr_exp = get_car(args);
3055 ctx->curr_env = arg_env;
3056 }
3057}
3058
3059static void cont_application_args(eval_context_t *ctx) {
3060 lbm_uint *sptr = get_stack_ptr(ctx, 3);
3061
3062 lbm_value env = sptr[0];
3063 lbm_value rest = sptr[1];
3064 lbm_value count = sptr[2];
3065
3066 ctx->curr_env = env;
3067 sptr[0] = ctx->r; // Function 1st then Arguments
3068 if (lbm_is_cons(rest)) {
3069 lbm_cons_t *cell = lbm_ref_cell(rest);
3070 sptr[1] = env;
3071 sptr[2] = cell->cdr;
3072 lbm_value *rptr = stack_reserve(ctx,2);
3073 rptr[0] = count + (1 << LBM_VAL_SHIFT4);
3074 rptr[1] = APPLICATION_ARGS(((5) << 2) | 0xF8000001u);
3075 ctx->curr_exp = cell->car;
3076 } else {
3077 // No more arguments
3078 lbm_stack_drop(&ctx->K, 2);
3079 lbm_uint nargs = lbm_dec_u(count);
3080 lbm_value *args = get_stack_ptr(ctx, (uint32_t)(nargs + 1));
3081 application(ctx,args, nargs);
3082 }
3083}
3084
3085static void cont_and(eval_context_t *ctx) {
3086 lbm_value env;
3087 lbm_value rest;
3088 lbm_value arg = ctx->r;
3089 lbm_pop_2(&ctx->K, &rest, &env);
3090 if (lbm_is_symbol_nil(arg)) {
3091 ctx->app_cont = true1;
3092 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3093 } else if (lbm_is_symbol_nil(rest)) {
3094 ctx->app_cont = true1;
3095 } else {
3096 lbm_value *sptr = stack_reserve(ctx, 3);
3097 sptr[0] = env;
3098 sptr[1] = get_cdr(rest);
3099 sptr[2] = AND(((6) << 2) | 0xF8000001u);
3100 ctx->curr_env = env;
3101 ctx->curr_exp = get_car(rest);
3102 }
3103}
3104
3105static void cont_or(eval_context_t *ctx) {
3106 lbm_value env;
3107 lbm_value rest;
3108 lbm_value arg = ctx->r;
3109 lbm_pop_2(&ctx->K, &rest, &env);
3110 if (!lbm_is_symbol_nil(arg)) {
3111 ctx->app_cont = true1;
3112 } else if (lbm_is_symbol_nil(rest)) {
3113 ctx->app_cont = true1;
3114 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3115 } else {
3116 lbm_value *sptr = stack_reserve(ctx, 3);
3117 sptr[0] = env;
3118 sptr[1] = get_cdr(rest);
3119 sptr[2] = OR(((7) << 2) | 0xF8000001u);
3120 ctx->curr_exp = get_car(rest);
3121 ctx->curr_env = env;
3122 }
3123}
3124
3125static int fill_binding_location(lbm_value key, lbm_value value, lbm_value env) {
3126 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) {
3127 if (key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return FB_OK0;
3128 lbm_env_modify_binding(env,key,value);
3129 return FB_OK0;
3130 } else if (lbm_is_cons(key) &&
3131 lbm_is_cons(value)) {
3132 int r = fill_binding_location(get_car(key), get_car(value), env);
3133 if (r == FB_OK0) {
3134 r = fill_binding_location(get_cdr(key), get_cdr(value), env);
3135 }
3136 return r;
3137 }
3138 return FB_TYPE_ERROR-1;
3139}
3140
3141static void cont_bind_to_key_rest(eval_context_t *ctx) {
3142
3143 lbm_value *sptr = get_stack_ptr(ctx, 4);
3144
3145 lbm_value rest = sptr[1];
3146 lbm_value env = sptr[2];
3147 lbm_value key = sptr[3];
3148
3149 if (fill_binding_location(key, ctx->r, env) < 0) {
3150 lbm_set_error_reason("Incorrect type of name/key in let-binding");
3151 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
3152 }
3153
3154 if (lbm_is_cons(rest)) {
3155 lbm_value car_rest = get_car(rest);
3156 lbm_value key_val[2];
3157 extract_n(car_rest, key_val, 2);
3158
3159 sptr[1] = get_cdr(rest);
3160 sptr[3] = key_val[0];
3161 stack_reserve(ctx,1)[0] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
3162 ctx->curr_exp = key_val[1];
3163 ctx->curr_env = env;
3164 } else {
3165 // Otherwise evaluate the expression in the populated env
3166 ctx->curr_exp = sptr[0];
3167 ctx->curr_env = env;
3168 lbm_stack_drop(&ctx->K, 4);
3169 }
3170}
3171
3172static void cont_if(eval_context_t *ctx) {
3173
3174 lbm_value arg = ctx->r;
3175
3176 lbm_value *sptr = pop_stack_ptr(ctx, 2);
3177
3178 ctx->curr_env = sptr[1];
3179 if (lbm_is_symbol_nil(arg)) {
3180 ctx->curr_exp = get_cadr(sptr[0]); // else branch
3181 } else {
3182 ctx->curr_exp = get_car(sptr[0]); // then branch
3183 }
3184}
3185
3186static void cont_match(eval_context_t *ctx) {
3187 lbm_value e = ctx->r;
3188 bool_Bool do_gc = false0;
3189
3190 lbm_uint *sptr = get_stack_ptr(ctx, 2);
3191 lbm_value patterns = (lbm_value)sptr[0];
3192 lbm_value orig_env = (lbm_value)sptr[1]; // restore enclosing environment.
3193 lbm_value new_env = orig_env;
3194
3195 if (lbm_is_symbol_nil(patterns)) {
3196 // no more patterns
3197 lbm_stack_drop(&ctx->K, 2);
3198 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
3199 ctx->app_cont = true1;
3200 } else if (lbm_is_cons(patterns)) {
3201 lbm_value match_case = get_car(patterns);
3202 lbm_value pattern = get_car(match_case);
3203 lbm_value n1 = get_cadr(match_case);
3204 lbm_value n2 = get_cadr(get_cdr(match_case));
3205 lbm_value body;
3206 bool_Bool check_guard = false0;
3207 if (lbm_is_symbol_nil(n2)) { // TODO: Not a very robust check.
3208 body = n1;
3209 } else {
3210 body = n2;
3211 check_guard = true1;
3212 }
3213
3214 bool_Bool is_match = match(pattern, e, &new_env, &do_gc);
3215 if (do_gc) {
3216 gc();
3217 do_gc = false0;
3218 new_env = orig_env;
3219 is_match = match(pattern, e, &new_env, &do_gc);
3220 if (do_gc) {
3221 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3222 }
3223 }
3224 if (is_match) {
3225 if (check_guard) {
3226 lbm_value *rptr = stack_reserve(ctx,5);
3227 sptr[0] = get_cdr(patterns);
3228 sptr[1] = ctx->curr_env;
3229 rptr[0] = MATCH(((9) << 2) | 0xF8000001u);
3230 rptr[1] = new_env;
3231 rptr[2] = body;
3232 rptr[3] = e;
3233 rptr[4] = MATCH_GUARD(((27) << 2) | 0xF8000001u);
3234 ctx->curr_env = new_env;
3235 ctx->curr_exp = n1; // The guard
3236 } else {
3237 lbm_stack_drop(&ctx->K, 2);
3238 ctx->curr_env = new_env;
3239 ctx->curr_exp = body;
3240 }
3241 } else {
3242 // set up for checking of next pattern
3243 sptr[0] = get_cdr(patterns);
3244 sptr[1] = orig_env;
3245 stack_reserve(ctx,1)[0] = MATCH(((9) << 2) | 0xF8000001u);
3246 // leave r unaltered
3247 ctx->app_cont = true1;
3248 }
3249 } else {
3250 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MATCH(((0x108) << 4) | 0x00000000u));
3251 }
3252}
3253
3254static void cont_exit_atomic(eval_context_t *ctx) {
3255 is_atomic --;
3256 ctx->app_cont = true1;
3257}
3258
3259static void cont_map(eval_context_t *ctx) {
3260 lbm_value *sptr = get_stack_ptr(ctx, 6);
3261
3262 lbm_value ls = sptr[0];
3263 lbm_value env = sptr[1];
3264 lbm_value t = sptr[3];
3265 lbm_set_car(t, ctx->r); // update car field tailmost position.
3266 if (lbm_is_cons(ls)) {
3267 lbm_value next, rest;
3268 get_car_and_cdr(ls, &next, &rest);
3269 sptr[0] = rest;
3270 stack_reserve(ctx,1)[0] = MAP(((26) << 2) | 0xF8000001u);
3271 lbm_set_car(sptr[5], next); // new arguments
3272
3273 lbm_value elt = cons_with_gc(ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3274 lbm_set_cdr(t, elt);
3275 sptr[3] = elt; // (r1 ... rN . (nil . nil))
3276 ctx->curr_exp = sptr[4];
3277 ctx->curr_env = env;
3278 } else {
3279 ctx->r = sptr[2]; //head of result list
3280 ctx->curr_env = env;
3281 lbm_stack_drop(&ctx->K, 6);
3282 ctx->app_cont = true1;
3283 }
3284}
3285
3286static void cont_match_guard(eval_context_t *ctx) {
3287 if (lbm_is_symbol_nil(ctx->r)) {
3288 lbm_value e;
3289 lbm_pop(&ctx->K, &e);
3290 lbm_stack_drop(&ctx->K, 2);
3291 ctx->r = e;
3292 ctx->app_cont = true1;
3293 } else {
3294 lbm_value body;
3295 lbm_value env;
3296 lbm_stack_drop(&ctx->K, 1);
3297 lbm_pop_2(&ctx->K, &body, &env);
3298 lbm_stack_drop(&ctx->K, 3);
3299 ctx->curr_env = env;
3300 ctx->curr_exp = body;
3301 }
3302}
3303
3304static void cont_terminate(eval_context_t *ctx) {
3305 error_ctx(ctx->r);
3306}
3307
3308static void cont_loop(eval_context_t *ctx) {
3309 lbm_value *sptr = get_stack_ptr(ctx, 2);
3310 stack_reserve(ctx,1)[0] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
3311 ctx->curr_exp = sptr[1];
3312}
3313
3314static void cont_loop_condition(eval_context_t *ctx) {
3315 if (lbm_is_symbol_nil(ctx->r)) {
3316 lbm_stack_drop(&ctx->K, 2);
3317 ctx->app_cont = true1; // A loop returns nil? Makes sense to me... but in general?
3318 return;
3319 }
3320 lbm_value *sptr = get_stack_ptr(ctx, 2);
3321 stack_reserve(ctx,1)[0] = LOOP(((41) << 2) | 0xF8000001u);
3322 ctx->curr_exp = sptr[0];
3323}
3324
3325static void cont_merge_rest(eval_context_t *ctx) {
3326 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3327
3328 // If comparator returns true (result is in ctx->r):
3329 // "a" should be moved to the last element position in merged list.
3330 // A new element from "a_rest" should be moved into comparator argument 1 pos.
3331 // else
3332 // "b" should be moved to last element position in merged list.
3333 // A new element from "b_rest" should be moved into comparator argument 2 pos.
3334 //
3335 // If a_rest or b_rest is NIL:
3336 // we are done, the remaining elements of
3337 // non_nil list should be appended to merged list.
3338 // else
3339 // Set up for a new comparator evaluation and recurse.
3340 lbm_value a = sptr[2];
3341 lbm_value b = lbm_cdr(a);
3342 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate 1 element list
3343
3344 if (ctx->r == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) { // Comparison false
3345
3346 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3347 sptr[0] = b;
3348 sptr[1] = b;
3349 } else {
3350 lbm_set_cdr(sptr[1], b);
3351 sptr[1] = b;
3352 }
3353 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3354 lbm_set_cdr(a, sptr[3]);
3355 lbm_set_cdr(sptr[1], a);
3356 ctx->r = sptr[0];
3357 lbm_stack_drop(&ctx->K, 9);
3358 ctx->app_cont = true1;
3359 return;
3360 } else {
3361 b = sptr[4];
3362 sptr[4] = lbm_cdr(sptr[4]);
3363 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3364 }
3365 } else {
3366 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3367 sptr[0] = a;
3368 sptr[1] = a;
3369 } else {
3370 lbm_set_cdr(sptr[1], a);
3371 sptr[1] = a;
3372 }
3373
3374 if (sptr[3] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3375 lbm_set_cdr(b, sptr[4]);
3376 lbm_set_cdr(sptr[1], b);
3377 ctx->r = sptr[0];
3378 lbm_stack_drop(&ctx->K, 9);
3379 ctx->app_cont = true1;
3380 return;
3381 } else {
3382 a = sptr[3];
3383 sptr[3] = lbm_cdr(sptr[3]);
3384 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3385 }
3386 }
3387 lbm_set_cdr(a, b);
3388 sptr[2] = a;
3389
3390 lbm_value par1 = sptr[7];
3391 lbm_value par2 = sptr[8];
3392 lbm_value cmp_body = sptr[5];
3393 lbm_value cmp_env = sptr[6];
3394 // Environment should be preallocated already at this point
3395 // and the operations below should never need GC.
3396 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3397 lbm_value new_env = lbm_env_set(new_env0, par2, lbm_car(b));
3398 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3399 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3400 }
3401 cmp_env = new_env;
3402
3403 stack_reserve(ctx,1)[0] = MERGE_REST(((43) << 2) | 0xF8000001u);
3404 ctx->curr_exp = cmp_body;
3405 ctx->curr_env = cmp_env;
3406}
3407
3408// merge_layer stack contents
3409// s[sp-9] = cmp
3410// s[sp-8] = cmp_env
3411// s[sp-7] = par1
3412// s[sp-6] = par2
3413// s[sp-5] = acc - first cell
3414// s[sp-4] = acc - last cell
3415// s[sp-3] = rest;
3416// s[sp-2] = layer
3417// s[sp-1] = length or original list
3418//
3419// ctx->r merged sublist
3420static void cont_merge_layer(eval_context_t *ctx) {
3421 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3422 lbm_int layer = lbm_dec_i(sptr[7]);
3423 lbm_int len = lbm_dec_i(sptr[8]);
3424
3425 lbm_value r_curr = ctx->r;
3426 while (lbm_is_cons(r_curr)) {
3427 lbm_value next = lbm_cdr(r_curr);
3428 if (next == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3429 break;
3430 }
3431 r_curr = next;
3432 }
3433
3434 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3435 sptr[4] = ctx->r;
3436 sptr[5] = r_curr;
3437 } else {
3438 lbm_set_cdr(sptr[5], ctx->r); // accumulate merged sublists.
3439 sptr[5] = r_curr;
3440 }
3441
3442 lbm_value layer_rest = sptr[6];
3443 // switch layer or done ?
3444 if (layer_rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3445 if (layer * 2 >= len) {
3446 ctx->r = sptr[4];
3447 ctx->app_cont = true1;
3448 lbm_stack_drop(&ctx->K, 9);
3449 return;
3450 } else {
3451 // Setup for merges of the next layer
3452 layer = layer * 2;
3453 sptr[7] = lbm_enc_i(layer);
3454 layer_rest = sptr[4]; // continue on the accumulation of all sublists.
3455 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3456 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3457 }
3458 }
3459 // merge another sublist based on current layer.
3460 lbm_value a_list = layer_rest;
3461 // build sublist a
3462 lbm_value curr = layer_rest;
3463 for (int i = 0; i < layer-1; i ++) {
3464 if (lbm_is_cons(curr)) {
3465 curr = lbm_cdr(curr);
3466 } else {
3467 break;
3468 }
3469 }
3470 layer_rest = lbm_cdr(curr);
3471 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3472
3473 lbm_value b_list = layer_rest;
3474 // build sublist b
3475 curr = layer_rest;
3476 for (int i = 0; i < layer-1; i ++) {
3477 if (lbm_is_cons(curr)) {
3478 curr = lbm_cdr(curr);
3479 } else {
3480 break;
3481 }
3482 }
3483 layer_rest = lbm_cdr(curr);
3484 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3485
3486 sptr[6] = layer_rest;
3487
3488 if (b_list == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3489 stack_reserve(ctx,1)[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3490 ctx->r = a_list;
3491 ctx->app_cont = true1;
3492 return;
3493 }
3494 // Set up for a merge of sublists.
3495
3496 lbm_value a_rest = lbm_cdr(a_list);
3497 lbm_value b_rest = lbm_cdr(b_list);
3498 lbm_value a = a_list;
3499 lbm_value b = b_list;
3500 lbm_set_cdr(a, b);
3501 // Terminating the b list would be incorrect here
3502 // if there was any chance that the environment update below
3503 // performs GC.
3504 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3505
3506 lbm_value cmp_body = sptr[0];
3507 lbm_value cmp_env = sptr[1];
3508 lbm_value par1 = sptr[2];
3509 lbm_value par2 = sptr[3];
3510 // Environment should be preallocated already at this point
3511 // and the operations below should never need GC.
3512 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3513 lbm_value new_env = lbm_env_set(cmp_env, par2, lbm_car(b));
3514 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3515 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3516 }
3517 cmp_env = new_env;
3518
3519 lbm_uint *merge_cont = stack_reserve(ctx, 11);
3520 merge_cont[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3521 merge_cont[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3522 merge_cont[2] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3523 merge_cont[3] = a;
3524 merge_cont[4] = a_rest;
3525 merge_cont[5] = b_rest;
3526 merge_cont[6] = cmp_body;
3527 merge_cont[7] = cmp_env;
3528 merge_cont[8] = par1;
3529 merge_cont[9] = par2;
3530 merge_cont[10] = MERGE_REST(((43) << 2) | 0xF8000001u);
3531 ctx->curr_exp = cmp_body;
3532 ctx->curr_env = cmp_env;
3533 return;
3534}
3535
3536/****************************************************/
3537/* READER */
3538
3539static void read_finish(lbm_char_channel_t *str, eval_context_t *ctx) {
3540
3541 /* Tokenizer reached "end of file"
3542 The parser could be in a state where it needs
3543 more tokens to correctly finish an expression.
3544
3545 Three cases
3546 1. The program / expression is malformed and the context should die.
3547 2. We are finished reading a program and should close off the
3548 internal representation with a closing parenthesis. Then
3549 apply continuation.
3550 3. We are finished reading an expression and should
3551 apply the continuation.
3552
3553 In case 3, we should find the READ_DONE at sp - 1.
3554 In case 2, we should find the READ_DONE at sp - 5.
3555
3556 */
3557
3558 if (lbm_is_symbol(ctx->r)) {
3559 lbm_uint sym_val = lbm_dec_sym(ctx->r);
3560 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
3561 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
3562 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3563 }
3564 }
3565
3566 if (ctx->K.data[ctx->K.sp-1] == READ_DONE(((20) << 2) | 0xF8000001u) &&
3567 lbm_dec_u(ctx->K.data[ctx->K.sp-3]) == 0) {
3568 /* successfully finished reading an expression (CASE 3) */
3569 ctx->app_cont = true1;
3570 } else if (ctx->K.sp > 4 && ctx->K.data[ctx->K.sp - 4] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3571 lbm_value env;
3572 lbm_value s;
3573 lbm_value sym;
3574 lbm_pop_3(&ctx->K, &sym, &env, &s);
3575 ctx->curr_env = env;
3576 ctx->app_cont = true1; // Program evaluated and result is in ctx->r.
3577 } else if (ctx->K.sp > 5 && ctx->K.data[ctx->K.sp - 5] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3578 /* successfully finished reading a program (CASE 2) */
3579 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3580 ctx->app_cont = true1;
3581 } else {
3582 /* Parsing failed */
3583 if (lbm_channel_row(str) == 1 &&
3584 lbm_channel_column(str) == 1 ){
3585 // eof at empty stream.
3586 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3587 ctx->app_cont = true1;
3588 } else {
3589 lbm_set_error_reason((char*)lbm_error_str_parse_eof);
3590 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3591 }
3592 lbm_channel_reader_close(str);
3593 }
3594}
3595
3596/* cont_read_next_token
3597 sp-2 : Stream
3598 sp-1 : Grab row
3599*/
3600static void cont_read_next_token(eval_context_t *ctx) {
3601 lbm_value *sptr = get_stack_ptr(ctx, 2);
3602 lbm_value stream = sptr[0];
3603 lbm_value grab_row0 = sptr[1];
3604
3605 lbm_char_channel_t *chan = lbm_dec_channel(stream);
3606 if (chan == NULL((void*)0) || chan->state == NULL((void*)0)) {
3607 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3608 }
3609
3610 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3611 lbm_stack_drop(&ctx->K, 2);
3612 read_finish(chan, ctx);
3613 return;
3614 }
3615 /* Eat whitespace and comments */
3616 if (!tok_clean_whitespace(chan)) {
3617 sptr[0] = stream;
3618 sptr[1] = lbm_enc_u(0);
3619 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3620 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3621 return;
3622 }
3623 /* After eating whitespace we may be at end of file/stream */
3624 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3625 lbm_stack_drop(&ctx->K, 2);
3626 read_finish(chan, ctx);
3627 return;
3628 }
3629
3630 if (lbm_dec_u(grab_row0)) {
3631 ctx->row0 = (int32_t)lbm_channel_row(chan);
3632 }
3633
3634 /* Attempt to extract tokens from the character stream */
3635 int n = 0;
3636 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3637 unsigned int string_len = 0;
3638
3639 /*
3640 * SYNTAX
3641 */
3642 uint32_t match;
3643 n = tok_syntax(chan, &match);
3644 if (n > 0) {
3645 if (!lbm_channel_drop(chan, (unsigned int)n)) {
3646 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3647 }
3648 ctx->app_cont = true1;
3649 lbm_uint do_next = 0;
3650 switch(match) {
3651 case TOKOPENPAR1u: {
3652 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3653 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3654 lbm_value *rptr = stack_reserve(ctx,5);
3655 rptr[0] = stream;
3656 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3657 rptr[2] = stream;
3658 rptr[3] = lbm_enc_u(0);
3659 rptr[4] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3660 ctx->r = ENC_SYM_OPENPAR(((0x70) << 4) | 0x00000000u);
3661 } return;
3662 case TOKCLOSEPAR2u: {
3663 lbm_stack_drop(&ctx->K, 2);
3664 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3665 } return;
3666 case TOKOPENBRACK3u: {
3667 sptr[0] = stream;
3668 sptr[1] = READ_START_ARRAY(((24) << 2) | 0xF8000001u);
3669 lbm_value *rptr = stack_reserve(ctx, 3);
3670 rptr[0] = stream;
3671 rptr[1] = lbm_enc_u(0);
3672 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3673 ctx->r = ENC_SYM_OPENBRACK(((0x80) << 4) | 0x00000000u);
3674 } return;
3675 case TOKCLOSEBRACK4u:
3676 lbm_stack_drop(&ctx->K, 2);
3677 ctx->r = ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u);
3678 return;
3679 case TOKDOT5u:
3680 lbm_stack_drop(&ctx->K, 2);
3681 ctx->r = ENC_SYM_DOT(((0x76) << 4) | 0x00000000u);
3682 return;
3683 case TOKDONTCARE6u:
3684 lbm_stack_drop(&ctx->K, 2);
3685 ctx->r = ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u);
3686 return;
3687 case TOKQUOTE7u:
3688 do_next = READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u);
3689 break;
3690 case TOKBACKQUOTE8u: {
3691 sptr[0] = QQ_EXPAND_START(((35) << 2) | 0xF8000001u);
3692 sptr[1] = stream;
3693 lbm_value *rptr = stack_reserve(ctx, 2);
3694 rptr[0] = lbm_enc_u(0);
3695 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3696 ctx->app_cont = true1;
3697 } return;
3698 case TOKCOMMAAT9u:
3699 do_next = READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u);
3700 break;
3701 case TOKCOMMA10u:
3702 do_next = READ_COMMA_RESULT(((23) << 2) | 0xF8000001u);
3703 break;
3704 case TOKMATCHANY11u:
3705 lbm_stack_drop(&ctx->K, 2);
3706 ctx->r = ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u);
3707 return;
3708 case TOKOPENCURL12u: {
3709 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3710 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3711 lbm_value *rptr = stack_reserve(ctx,2);
3712 rptr[0] = stream;
3713 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3714 ctx->r = ENC_SYM_PROGN(((0x102) << 4) | 0x00000000u);
3715 } return;
3716 case TOKCLOSECURL13u:
3717 lbm_stack_drop(&ctx->K, 2);
3718 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3719 return;
3720 case TOKCONSTSTART14u: /* fall through */
3721 case TOKCONSTEND15u:
3722 case TOKCONSTSYMSTR16u: {
3723 if (match == TOKCONSTSTART14u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3724 if (match == TOKCONSTEND15u) ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3725 if (match == TOKCONSTSYMSTR16u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04;
3726 sptr[0] = stream;
3727 sptr[1] = lbm_enc_u(0);
3728 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3729 ctx->app_cont = true1;
3730 } return;
3731 default:
3732 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3733 }
3734 sptr[0] = do_next;
3735 sptr[1] = stream;
3736 lbm_value *rptr = stack_reserve(ctx, 2);
3737 rptr[0] = lbm_enc_u(0);
3738 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3739 ctx->app_cont = true1;
3740 return;
3741 } else if (n < 0) goto retry_token;
3742
3743 /*
3744 * STRING
3745 */
3746 n = tok_string(chan, &string_len);
3747 if (n >= 2) {
3748 lbm_channel_drop(chan, (unsigned int)n);
3749 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3750 gc();
3751 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3752 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3753 return; // dead return but static analysis does not know that.
3754 }
3755 }
3756 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(res);
3757 char *data = (char*)arr->data;
3758 memset(data,0, string_len + 1);
3759 memcpy(data, tokpar_sym_str, string_len);
3760 lbm_stack_drop(&ctx->K, 2);
3761 ctx->r = res;
3762 ctx->app_cont = true1;
3763 return;
3764 } else if (n < 0) goto retry_token;
3765
3766 /*
3767 * FLOAT
3768 */
3769 token_float f_val;
3770 n = tok_double(chan, &f_val);
3771 if (n > 0) {
3772 lbm_channel_drop(chan, (unsigned int) n);
3773 switch(f_val.type) {
3774 case TOKTYPEF32107u:
3775 WITH_GC(res, lbm_enc_float((float)f_val.value))(res) = (lbm_enc_float((float)f_val.value)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (lbm_enc_float((float)f_val.value));
if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
3776 break;
3777 case TOKTYPEF64108u:
3778 res = lbm_enc_double(f_val.value);
3779 break;
3780 default:
3781 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3782 }
3783 lbm_stack_drop(&ctx->K, 2);
3784 ctx->r = res;
3785 ctx->app_cont = true1;
3786 return;
3787 } else if (n < 0) goto retry_token;
3788
3789 /*
3790 * INTEGER
3791 */
3792 token_int int_result;
3793 n = tok_integer(chan, &int_result);
3794 if (n > 0) {
3795 lbm_channel_drop(chan, (unsigned int)n);
3796 switch(int_result.type) {
3797 case TOKTYPEBYTE100u:
3798 res = lbm_enc_char((uint8_t)(int_result.negative ? -int_result.value : int_result.value));
3799 break;
3800 case TOKTYPEI101u:
3801 res = lbm_enc_i((lbm_int)(int_result.negative ? -int_result.value : int_result.value));
3802 break;
3803 case TOKTYPEU102u:
3804 res = lbm_enc_u((lbm_uint)(int_result.negative ? -int_result.value : int_result.value));
3805 break;
3806 case TOKTYPEI32103u:
3807 WITH_GC(res, lbm_enc_i32((int32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i32((int32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i32((int32_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3808 break;
3809 case TOKTYPEU32104u:
3810 WITH_GC(res,lbm_enc_u32((uint32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u32((uint32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u32((uint32_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3811 break;
3812 case TOKTYPEI64105u:
3813 WITH_GC(res,lbm_enc_i64((int64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i64((int64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i64((int64_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3814 break;
3815 case TOKTYPEU64106u:
3816 WITH_GC(res,lbm_enc_u64((uint64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u64((uint64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u64((uint64_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3817 break;
3818 default:
3819 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3820 }
3821 lbm_stack_drop(&ctx->K, 2);
3822 ctx->r = res;
3823 ctx->app_cont = true1;
3824 return;
3825 } else if (n < 0) goto retry_token;
3826
3827 /*
3828 * SYMBOL
3829 */
3830 n = tok_symbol(chan);
3831 if (n > 0) {
3832 lbm_channel_drop(chan, (unsigned int) n);
3833 lbm_uint symbol_id;
3834 if (lbm_get_symbol_by_name(tokpar_sym_str, &symbol_id)) {
3835 res = lbm_enc_sym(symbol_id);
3836 } else {
3837 int r = 0;
3838 if (n > 4 &&
3839 tokpar_sym_str[0] == 'e' &&
3840 tokpar_sym_str[1] == 'x' &&
3841 tokpar_sym_str[2] == 't' &&
3842 tokpar_sym_str[3] == '-') {
3843 lbm_uint ext_id;
3844 lbm_uint ext_name_len = (lbm_uint)n + 1;
3845 char *ext_name = lbm_malloc(ext_name_len);
3846 if (!ext_name) {
3847 gc();
3848 ext_name = lbm_malloc(ext_name_len);
3849 }
3850 if (ext_name) {
3851 memcpy(ext_name, tokpar_sym_str, ext_name_len);
3852 r = lbm_add_extension(ext_name, lbm_extensions_default);
3853 if (!lbm_lookup_extension_id(ext_name, &ext_id)) {
3854 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3855 }
3856 symbol_id = ext_id;
3857 } else {
3858 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3859 }
3860 } else {
3861 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04 &&
3862 ctx->flags & EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08) {
3863 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id, true1); //flash
3864 if (!r) {
3865 lbm_set_error_reason((char*)lbm_error_str_flash_error);
3866 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3867 }
3868 } else {
3869 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3870 if (!r) {
3871 gc();
3872 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3873 }
3874 }
3875 }
3876 if (r) {
3877 res = lbm_enc_sym(symbol_id);
3878 } else {
3879 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3880 }
3881 }
3882 lbm_stack_drop(&ctx->K, 2);
3883 ctx->r = res;
3884 ctx->app_cont = true1;
3885 return;
3886 } else if (n == TOKENIZER_NEED_MORE-1) {
3887 goto retry_token;
3888 } else if (n <= TOKENIZER_STRING_ERROR-2) {
3889 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3890 }
3891
3892 /*
3893 * CHAR
3894 */
3895 char c_val;
3896 n = tok_char(chan, &c_val);
3897 if(n > 0) {
3898 lbm_channel_drop(chan,(unsigned int) n);
3899 lbm_stack_drop(&ctx->K, 2);
3900 ctx->r = lbm_enc_char((uint8_t)c_val);
3901 ctx->app_cont = true1;
3902 return;
3903 }else if (n < 0) goto retry_token;
3904
3905 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3906
3907 retry_token:
3908 if (n == TOKENIZER_NEED_MORE-1) {
3909 sptr[0] = stream;
3910 sptr[1] = lbm_enc_u(0);
3911 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3912 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3913 return;
3914 }
3915 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3916}
3917
3918static void cont_read_start_array(eval_context_t *ctx) {
3919 lbm_value *sptr = get_stack_ptr(ctx, 1);
3920 lbm_value stream = sptr[0];
3921
3922 lbm_char_channel_t *str = lbm_dec_channel(stream);
3923 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
3924 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3925 }
3926
3927 lbm_uint num_free = lbm_memory_longest_free();
3928 lbm_uint initial_size = (lbm_uint)((float)num_free * 0.9);
3929 if (initial_size == 0) {
3930 gc();
3931 num_free = lbm_memory_longest_free();
3932 initial_size = (lbm_uint)((float)num_free * 0.9);
3933 if (initial_size == 0) {
3934 lbm_channel_reader_close(str);
3935 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3936 }
3937 }
3938
3939 if (lbm_is_number(ctx->r)) {
3940 lbm_value array;
3941 initial_size = sizeof(lbm_uint) * initial_size;
3942
3943 if (!lbm_heap_allocate_array(&array, initial_size)) {
3944 lbm_set_error_reason("Out of memory while reading.");
3945 lbm_channel_reader_close(str);
3946 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3947 // NOTE: If array is not created evaluation ends here.
3948 // Static analysis seems unaware.
3949 }
3950
3951 sptr[0] = array;
3952 lbm_value *rptr = stack_reserve(ctx, 4);
3953 rptr[0] = lbm_enc_u(initial_size);
3954 rptr[1] = lbm_enc_u(0);
3955 rptr[2] = stream;
3956 rptr[3] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3957 ctx->app_cont = true1;
3958 } else {
3959 lbm_channel_reader_close(str);
3960 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3961 }
3962}
3963
3964static void cont_read_append_array(eval_context_t *ctx) {
3965 lbm_uint *sptr = get_stack_ptr(ctx, 4);
3966
3967 lbm_value array = sptr[0];
3968 lbm_value size = lbm_dec_as_u32(sptr[1]);
3969 lbm_value ix = lbm_dec_as_u32(sptr[2]);
3970 lbm_value stream = sptr[3];
3971
3972 if (ix >= (size - 1)) {
3973 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3974 }
3975
3976 // get_car can return nil. Whose value is 0!
3977 // So static Analysis is right about this being a potential NULL pointer.
3978 // However, if the array was created correcly to begin with, it should be fine.
3979 lbm_value arr_car = get_car(array);
3980 lbm_array_header_t *arr = (lbm_array_header_t*)arr_car;
3981
3982 if (lbm_is_number(ctx->r)) {
3983 ((uint8_t*)arr->data)[ix] = (uint8_t)lbm_dec_as_u32(ctx->r);
3984
3985 sptr[2] = lbm_enc_u(ix + 1);
3986 lbm_value *rptr = stack_reserve(ctx, 4);
3987 rptr[0] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3988 rptr[1] = stream;
3989 rptr[2] = lbm_enc_u(0);
3990 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3991 ctx->app_cont = true1;
3992 } else if (lbm_is_symbol(ctx->r) && ctx->r == ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u)) {
3993 lbm_uint array_size = ix / sizeof(lbm_uint);
3994
3995 if (ix % sizeof(lbm_uint) != 0) {
3996 array_size = array_size + 1;
3997 }
3998 lbm_memory_shrink((lbm_uint*)arr->data, array_size);
3999 arr->size = ix;
4000 lbm_stack_drop(&ctx->K, 4);
4001 ctx->r = array;
4002 ctx->app_cont = true1;
4003 } else {
4004 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
4005 }
4006}
4007
4008static void cont_read_append_continue(eval_context_t *ctx) {
4009 lbm_value *sptr = get_stack_ptr(ctx, 3);
4010
4011 lbm_value first_cell = sptr[0];
4012 lbm_value last_cell = sptr[1];
4013 lbm_value stream = sptr[2];
4014
4015 lbm_char_channel_t *str = lbm_dec_channel(stream);
4016 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4017 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4018 }
4019
4020 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4021
4022 switch(ctx->r) {
4023 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4024 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4025 lbm_set_cdr(last_cell, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate the list
4026 ctx->r = first_cell;
4027 } else {
4028 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4029 }
4030 lbm_stack_drop(&ctx->K, 3);
4031 /* Skip reading another token and apply the continuation */
4032 ctx->app_cont = true1;
4033 return;
4034 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4035 lbm_value *rptr = stack_reserve(ctx, 4);
4036 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4037 rptr[1] = stream;
4038 rptr[2] = lbm_enc_u(0);
4039 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4040 ctx->app_cont = true1;
4041 } return;
4042 }
4043 }
4044 lbm_value new_cell = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4045 if (lbm_is_symbol_merror(new_cell)) {
4046 lbm_channel_reader_close(str);
4047 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4048 return;
4049 }
4050 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4051 lbm_set_cdr(last_cell, new_cell);
4052 last_cell = new_cell;
4053 } else {
4054 first_cell = last_cell = new_cell;
4055 }
4056 sptr[0] = first_cell;
4057 sptr[1] = last_cell;
4058 sptr[2] = stream; // unchanged.
4059 lbm_value *rptr = stack_reserve(ctx, 4);
4060 rptr[0] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
4061 rptr[1] = stream;
4062 rptr[2] = lbm_enc_u(0);
4063 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4064 ctx->app_cont = true1;
4065}
4066
4067static void cont_read_eval_continue(eval_context_t *ctx) {
4068 lbm_value env;
4069 lbm_value stream;
4070 lbm_pop_2(&ctx->K, &env, &stream);
4071
4072 lbm_char_channel_t *str = lbm_dec_channel(stream);
1
'str' initialized here
→
4073 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
2
←
Assuming 'str' is equal to NULL
→
4074 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4075 }
4076
4077 ctx->row1 = (lbm_int)str->row(str);
3
←
Access to field 'row' results in a dereference of a null pointer (loaded from variable 'str')
4078
4079 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4080
4081 switch(ctx->r) {
4082 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4083 ctx->app_cont = true1;
4084 return;
4085 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4086 // This case is a bit mysterious.
4087 // A dot, may in reality be an error in this location.
4088 lbm_value *rptr = stack_reserve(ctx, 4);
4089 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4090 rptr[1] = stream;
4091 rptr[2] = lbm_enc_u(0);
4092 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4093 ctx->app_cont = true1;
4094 } return;
4095 }
4096 }
4097
4098 lbm_value *rptr = stack_reserve(ctx, 6);
4099 rptr[0] = stream;
4100 rptr[1] = env;
4101 rptr[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
4102 rptr[3] = stream;
4103 rptr[4] = lbm_enc_u(1);
4104 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4105 rptr[6] = lbm_enc_u(ctx->flags);
4106 rptr[7] = POP_READER_FLAGS(((47) << 2) | 0xF8000001u);
4107 ctx->curr_env = env;
4108 ctx->curr_exp = ctx->r;
4109}
4110
4111static void cont_read_expect_closepar(eval_context_t *ctx) {
4112 lbm_value res;
4113 lbm_value stream;
4114
4115 lbm_pop_2(&ctx->K, &res, &stream);
4116
4117 lbm_char_channel_t *str = lbm_dec_channel(stream);
4118 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4119 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4120 }
4121
4122 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4123 ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u)) {
4124 ctx->r = res;
4125 ctx->app_cont = true1;
4126 } else {
4127 lbm_channel_reader_close(str);
4128 lbm_set_error_reason((char*)lbm_error_str_parse_close);
4129 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4130 }
4131}
4132
4133static void cont_read_dot_terminate(eval_context_t *ctx) {
4134 lbm_value *sptr = get_stack_ptr(ctx, 3);
4135
4136 lbm_value first_cell = sptr[0];
4137 lbm_value last_cell = sptr[1];
4138 lbm_value stream = sptr[2];
4139
4140 lbm_char_channel_t *str = lbm_dec_channel(stream);
4141 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4142 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4143 }
4144
4145 lbm_stack_drop(&ctx->K ,3);
4146
4147 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4148 (ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u) ||
4149 ctx->r == ENC_SYM_DOT(((0x76) << 4) | 0x00000000u))) {
4150 lbm_channel_reader_close(str);
4151 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4152 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4153 } else {
4154 if (lbm_is_cons(last_cell)) {
4155 lbm_set_cdr(last_cell, ctx->r);
4156 ctx->r = first_cell;
4157 lbm_value *rptr = stack_reserve(ctx, 6);
4158 rptr[0] = stream;
4159 rptr[1] = ctx->r;
4160 rptr[2] = READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u);
4161 rptr[3] = stream;
4162 rptr[4] = lbm_enc_u(0);
4163 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4164 ctx->app_cont = true1;
4165 } else {
4166 lbm_channel_reader_close(str);
4167 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4168 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4169 }
4170 }
4171}
4172
4173static void cont_read_done(eval_context_t *ctx) {
4174 lbm_value stream;
4175 lbm_value f_val;
4176 lbm_pop_2(&ctx->K, &stream ,&f_val);
4177
4178 uint32_t flags = lbm_dec_as_u32(f_val);
4179 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4180 ctx->flags |= (flags & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4181
4182 lbm_char_channel_t *str = lbm_dec_channel(stream);
4183 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4184 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4185 }
4186
4187 lbm_channel_reader_close(str);
4188 if (lbm_is_symbol(ctx->r)) {
4189 lbm_uint sym_val = lbm_dec_sym(ctx->r);
4190 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
4191 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
4192 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4193 }
4194 }
4195
4196 ctx->row0 = -1;
4197 ctx->row1 = -1;
4198 ctx->app_cont = true1;
4199}
4200
4201static void cont_read_quote_result(eval_context_t *ctx) {
4202 lbm_value cell;
4203 WITH_GC(cell, lbm_heap_allocate_list_init(2,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4204 ENC_SYM_QUOTE,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4205 ctx->r))(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
};
4206 ctx->r = cell;
4207 ctx->app_cont = true1;
4208}
4209
4210static void cont_read_commaat_result(eval_context_t *ctx) {
4211 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4212 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4213 ctx->r = cell1;
4214 ctx->app_cont = true1;
4215}
4216
4217static void cont_read_comma_result(eval_context_t *ctx) {
4218 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u),ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4219 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4220 ctx->r = cell1;
4221 ctx->app_cont = true1;
4222}
4223
4224static void cont_application_start(eval_context_t *ctx) {
4225
4226 /* sptr[0] = env
4227 * sptr[1] = args
4228 * ctx->r = function
4229 */
4230
4231 if (lbm_is_symbol(ctx->r)) {
4232 stack_reserve(ctx,1)[0] = lbm_enc_u(0);
4233 cont_application_args(ctx);
4234 } else if (lbm_is_cons(ctx->r)) {
4235 lbm_uint *sptr = get_stack_ptr(ctx, 2);
4236 lbm_value args = (lbm_value)sptr[1];
4237 switch (get_car(ctx->r)) {
4238 case ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u): {
4239 lbm_value cl[3];
4240 extract_n(get_cdr(ctx->r), cl, 3);
4241 lbm_value arg_env = (lbm_value)sptr[0];
4242 lbm_value arg0, arg_rest;
4243 get_car_and_cdr(args, &arg0, &arg_rest);
4244 sptr[1] = cl[CLO_BODY1];
4245 bool_Bool a_nil = lbm_is_symbol_nil(args);
4246 bool_Bool p_nil = lbm_is_symbol_nil(cl[CLO_PARAMS0]);
4247 lbm_value *reserved = stack_reserve(ctx, 4);
4248
4249 if (!a_nil && !p_nil) {
4250 reserved[0] = cl[CLO_ENV2];
4251 reserved[1] = cl[CLO_PARAMS0];
4252 reserved[2] = arg_rest;
4253 reserved[3] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
4254 ctx->curr_exp = arg0;
4255 ctx->curr_env = arg_env;
4256 } else if (a_nil && p_nil) {
4257 // No params, No args
4258 lbm_stack_drop(&ctx->K, 6);
4259 ctx->curr_exp = cl[CLO_BODY1];
4260 ctx->curr_env = cl[CLO_ENV2];
4261 } else if (p_nil) {
4262 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), cl[CLO_ENV2]);
4263 reserved[0] = rest_binder;
4264 reserved[1] = get_cdr(args);
4265 reserved[2] = get_car(rest_binder);
4266 reserved[3] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
4267 ctx->curr_exp = get_car(args);
4268 ctx->curr_env = arg_env;
4269 } else {
4270 lbm_set_error_reason((char*)lbm_error_str_num_args);
4271 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->r);
4272 }
4273 } break;
4274 case ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u):{
4275 /* Continuation created using call-cc.
4276 * ((SYM_CONT . cont-array) arg0 )
4277 */
4278 lbm_value c = get_cdr(ctx->r); /* should be the continuation array*/
4279
4280 if (!lbm_is_lisp_array_r(c)) {
4281 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4282 }
4283
4284 lbm_uint arg_count = lbm_list_length(args);
4285 lbm_value arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4286 switch (arg_count) {
4287 case 0:
4288 arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4289 break;
4290 case 1:
4291 arg = get_car(args);
4292 break;
4293 default:
4294 lbm_set_error_reason((char*)lbm_error_str_num_args);
4295 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4296 }
4297 lbm_stack_clear(&ctx->K);
4298
4299 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(c);
4300
4301 ctx->K.sp = arr->size / sizeof(lbm_uint);
4302 memcpy(ctx->K.data, arr->data, arr->size);
4303
4304 ctx->curr_exp = arg;
4305 break;
4306 }
4307 case ENC_SYM_MACRO(((0x10D) << 4) | 0x00000000u):{
4308 /*
4309 * Perform macro expansion.
4310 * Macro expansion is really just evaluation in an
4311 * environment augmented with the unevaluated expressions passed
4312 * as arguments.
4313 */
4314 lbm_value env = (lbm_value)sptr[0];
4315
4316 lbm_value curr_param = get_cadr(ctx->r);
4317 lbm_value curr_arg = args;
4318 lbm_value expand_env = env;
4319 while (lbm_is_cons(curr_param) &&
4320 lbm_is_cons(curr_arg)) {
4321 lbm_value car_curr_param, cdr_curr_param;
4322 lbm_value car_curr_arg, cdr_curr_arg;
4323 get_car_and_cdr(curr_param, &car_curr_param, &cdr_curr_param);
4324 get_car_and_cdr(curr_arg, &car_curr_arg, &cdr_curr_arg);
4325
4326 lbm_value entry = cons_with_gc(car_curr_param, car_curr_arg, expand_env);
4327 lbm_value aug_env = cons_with_gc(entry, expand_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4328 expand_env = aug_env;
4329
4330 curr_param = cdr_curr_param;
4331 curr_arg = cdr_curr_arg;
4332 }
4333 /* Two rounds of evaluation is performed.
4334 * First to instantiate the arguments into the macro body.
4335 * Second to evaluate the resulting program.
4336 */
4337 sptr[1] = EVAL_R(((11) << 2) | 0xF8000001u);
4338 lbm_value exp = get_cadr(get_cdr(ctx->r));
4339 ctx->curr_exp = exp;
4340 ctx->curr_env = expand_env;
4341 } break;
4342 default:
4343 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4344 }
4345 } else {
4346 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4347 }
4348}
4349
4350static void cont_eval_r(eval_context_t* ctx) {
4351 lbm_value env;
4352 lbm_pop(&ctx->K, &env);
4353 ctx->curr_exp = ctx->r;
4354 ctx->curr_env = env;
4355}
4356
4357static void cont_progn_var(eval_context_t* ctx) {
4358
4359 lbm_value key;
4360 lbm_value env;
4361
4362 lbm_pop_2(&ctx->K, &key, &env);
4363
4364 if (fill_binding_location(key, ctx->r, env) < 0) {
4365 lbm_set_error_reason("Incorrect type of name/key in let-binding");
4366 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
4367 }
4368
4369 ctx->app_cont = true1;
4370}
4371
4372static void cont_setq(eval_context_t *ctx) {
4373 lbm_value sym;
4374 lbm_value env;
4375 lbm_pop_2(&ctx->K, &sym, &env);
4376 lbm_value res;
4377 WITH_GC(res, perform_setvar(sym, ctx->r, env))(res) = (perform_setvar(sym, ctx->r, env)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (perform_setvar(sym, ctx->r, env)
); if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
4378 ctx->r = res;
4379 ctx->app_cont = true1;
4380}
4381
4382lbm_flash_status request_flash_storage_cell(lbm_value val, lbm_value *res) {
4383
4384 lbm_value flash_cell;
4385 lbm_flash_status s = lbm_allocate_const_cell(&flash_cell);
4386 if (s != LBM_FLASH_WRITE_OK)
4387 return s;
4388 lbm_value new_val = val;
4389 new_val &= ~LBM_PTR_VAL_MASK0x03FFFFFCu; // clear the value part of the ptr
4390 new_val |= (flash_cell & LBM_PTR_VAL_MASK0x03FFFFFCu);
4391 new_val |= LBM_PTR_TO_CONSTANT_BIT0x04000000u;
4392 *res = new_val;
4393 return s;
4394}
4395
4396static void cont_move_to_flash(eval_context_t *ctx) {
4397
4398 lbm_value args;
4399 lbm_pop(&ctx->K, &args);
4400
4401 if (lbm_is_symbol_nil(args)) {
4402 // Done looping over arguments. return true.
4403 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
4404 ctx->app_cont = true1;
4405 return;
4406 }
4407
4408 lbm_value first_arg, rest;
4409 get_car_and_cdr(args, &first_arg, &rest);
4410
4411 lbm_value val;
4412 if (lbm_is_symbol(first_arg) && lbm_global_env_lookup(&val, first_arg)) {
4413 // Prepare to copy the rest of the arguments when done with first.
4414 lbm_value *rptr = stack_reserve(ctx, 2);
4415 rptr[0] = rest;
4416 rptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
4417 if (lbm_is_ptr(val) &&
4418 (!(val & LBM_PTR_TO_CONSTANT_BIT0x04000000u))) {
4419 lbm_value * rptr1 = stack_reserve(ctx, 3);
4420 rptr1[0] = first_arg;
4421 rptr1[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
4422 rptr1[2] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4423 ctx->r = val;
4424 }
4425 ctx->app_cont = true1;
4426 return;
4427 }
4428 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4429}
4430
4431static void cont_move_val_to_flash_dispatch(eval_context_t *ctx) {
4432
4433 lbm_value val = ctx->r;
4434
4435 if (lbm_is_cons(val)) {
4436 lbm_value *rptr = stack_reserve(ctx, 5);
4437 rptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // fst cell of list
4438 rptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last cell of list
4439 rptr[2] = get_cdr(val);
4440 rptr[3] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4441 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4442 ctx->r = get_car(val);
4443 ctx->app_cont = true1;
4444 return;
4445 }
4446
4447 if (lbm_is_ptr(val) && (val & LBM_PTR_TO_CONSTANT_BIT0x04000000u)) {
4448 ctx->r = val;
4449 ctx->app_cont = true1;
4450 return;
4451 }
4452
4453 if (lbm_is_ptr(val)) {
4454 lbm_cons_t *ref = lbm_ref_cell(val);
4455 if (lbm_type_of(ref->cdr) == LBM_TYPE_SYMBOL0x00000000u) {
4456 switch (ref->cdr) {
4457 case ENC_SYM_RAW_I_TYPE(((0x31) << 4) | 0x00000000u): /* fall through */
4458 case ENC_SYM_RAW_U_TYPE(((0x32) << 4) | 0x00000000u):
4459 case ENC_SYM_RAW_F_TYPE(((0x33) << 4) | 0x00000000u): {
4460 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4461 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4462 handle_flash_status(write_const_car(flash_cell, ref->car));
4463 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4464 ctx->r = flash_cell;
4465 } break;
4466 case ENC_SYM_IND_I_TYPE(((0x34) << 4) | 0x00000000u): /* fall through */
4467 case ENC_SYM_IND_U_TYPE(((0x35) << 4) | 0x00000000u):
4468 case ENC_SYM_IND_F_TYPE(((0x36) << 4) | 0x00000000u): {
4469#ifndef LBM64
4470 /* 64 bit values are in lbm mem on 32bit platforms. */
4471 lbm_uint *lbm_mem_ptr = (lbm_uint*)ref->car;
4472 lbm_uint flash_ptr;
4473
4474 handle_flash_status(lbm_write_const_raw(lbm_mem_ptr, 2, &flash_ptr));
4475 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4476 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4477 handle_flash_status(write_const_car(flash_cell, flash_ptr));
4478 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4479 ctx->r = flash_cell;
4480#else
4481 // There are no indirect types in LBM64
4482 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4483#endif
4484 } break;
4485 case ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u): {
4486 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4487 lbm_uint size = arr->size / sizeof(lbm_uint);
4488 lbm_uint flash_addr;
4489 lbm_value *arrdata = (lbm_value *)arr->data;
4490 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4491 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4492 handle_flash_status(lbm_allocate_const_raw(size, &flash_addr));
4493 lift_array_flash(flash_cell,
4494 false0,
4495 (char *)flash_addr,
4496 arr->size);
4497 // Move array contents to flash recursively
4498 lbm_value *rptr = stack_reserve(ctx, 5);
4499 rptr[0] = flash_cell;
4500 rptr[1] = lbm_enc_u(0);
4501 rptr[2] = val;
4502 rptr[3] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4503 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4504 ctx->r = arrdata[0];
4505 ctx->app_cont = true1;
4506 return;
4507 }
4508 case ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u): {
4509 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4510 // arbitrary address: flash_arr.
4511 lbm_uint flash_arr;
4512 handle_flash_status(lbm_write_const_array_padded((uint8_t*)arr->data, arr->size, &flash_arr));
4513 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4514 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4515 lift_array_flash(flash_cell,
4516 true1,
4517 (char *)flash_arr,
4518 arr->size);
4519 ctx->r = flash_cell;
4520 } break;
4521 case ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u): /* fall through */
4522 case ENC_SYM_CUSTOM_TYPE(((0x38) << 4) | 0x00000000u):
4523 lbm_set_error_reason((char *)lbm_error_str_flash_not_possible);
4524 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4525 }
4526 } else {
4527 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4528 }
4529 ctx->app_cont = true1;
4530 return;
4531 }
4532 ctx->r = val;
4533 ctx->app_cont = true1;
4534}
4535
4536static void cont_move_list_to_flash(eval_context_t *ctx) {
4537
4538 // ctx->r holds the value that should go in car
4539
4540 lbm_value *sptr = get_stack_ptr(ctx, 3);
4541
4542 lbm_value fst = sptr[0];
4543 lbm_value lst = sptr[1];
4544 lbm_value val = sptr[2];
4545
4546
4547 lbm_value new_lst = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4548 // Allocate element ptr storage after storing the element to flash.
4549 handle_flash_status(request_flash_storage_cell(lbm_enc_cons_ptr(LBM_PTR_NULL(0x03FFFFFCu >> 2)), &new_lst));
4550
4551 if (lbm_is_symbol_nil(fst)) {
4552 lst = new_lst;
4553 fst = new_lst;
4554 handle_flash_status(write_const_car(lst, ctx->r));
4555 } else {
4556 handle_flash_status(write_const_cdr(lst, new_lst)); // low before high
4557 handle_flash_status(write_const_car(new_lst, ctx->r));
4558 lst = new_lst;
4559 }
4560
4561 if (lbm_is_cons(val)) {
4562 sptr[0] = fst;
4563 sptr[1] = lst;//rest_cell;
4564 sptr[2] = get_cdr(val);
4565 lbm_value *rptr = stack_reserve(ctx, 2);
4566 rptr[0] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4567 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4568 ctx->r = get_car(val);
4569 } else {
4570 sptr[0] = fst;
4571 sptr[1] = lst;
4572 sptr[2] = CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u);
4573 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4574 ctx->r = val;
4575 }
4576 ctx->app_cont = true1;
4577}
4578
4579static void cont_close_list_in_flash(eval_context_t *ctx) {
4580 lbm_value fst;
4581 lbm_value lst;
4582 lbm_pop_2(&ctx->K, &lst, &fst);
4583 lbm_value val = ctx->r;
4584 handle_flash_status(write_const_cdr(lst, val));
4585 ctx->r = fst;
4586 ctx->app_cont = true1;
4587}
4588
4589static void cont_move_array_elts_to_flash(eval_context_t *ctx) {
4590 lbm_value *sptr = get_stack_ptr(ctx, 3);
4591 // sptr[2] = source array in RAM
4592 // sptr[1] = current index
4593 // sptr[0] = target array in flash
4594 lbm_array_header_t *src_arr = (lbm_array_header_t*)get_car(sptr[2]);
4595 lbm_uint size = src_arr->size / sizeof(lbm_uint);
4596 lbm_value *srcdata = (lbm_value *)src_arr->data;
4597
4598 lbm_array_header_t *tgt_arr = (lbm_array_header_t*)get_car(sptr[0]);
4599 lbm_uint *tgtdata = (lbm_value *)tgt_arr->data;
4600 lbm_uint ix = lbm_dec_as_u32(sptr[1]);
4601 handle_flash_status(lbm_const_write(&tgtdata[ix], ctx->r));
4602 if (ix >= size-1) {
4603 ctx->r = sptr[0];
4604 lbm_stack_drop(&ctx->K, 3);
4605 ctx->app_cont = true1;
4606 return;
4607 }
4608 sptr[1] = lbm_enc_u(ix + 1);
4609 lbm_value *rptr = stack_reserve(ctx, 2);
4610 rptr[0] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4611 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4612 ctx->r = srcdata[ix+1];
4613 ctx->app_cont = true1;
4614 return;
4615}
4616
4617static void cont_qq_expand_start(eval_context_t *ctx) {
4618 lbm_value *rptr = stack_reserve(ctx, 2);
4619 rptr[0] = ctx->r;
4620 rptr[1] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4621 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4622 ctx->app_cont = true1;
4623}
4624
4625lbm_value quote_it(lbm_value qquoted) {
4626 if (lbm_is_symbol(qquoted) &&
4627 lbm_is_special(qquoted)) return qquoted;
4628
4629 lbm_value val = cons_with_gc(qquoted, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4630 return cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4631}
4632
4633bool_Bool is_append(lbm_value a) {
4634 return (lbm_is_cons(a) &&
4635 lbm_is_symbol(get_car(a)) &&
4636 (get_car(a) == ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u)));
4637}
4638
4639lbm_value append(lbm_value front, lbm_value back) {
4640 if (lbm_is_symbol_nil(front)) return back;
4641 if (lbm_is_symbol_nil(back)) return front;
4642
4643 if (lbm_is_quoted_list(front) &&
4644 lbm_is_quoted_list(back)) {
4645 lbm_value f = get_cadr(front);
4646 lbm_value b = get_cadr(back);
4647 return quote_it(lbm_list_append(f, b));
4648 }
4649
4650 if (is_append(back) &&
4651 lbm_is_quoted_list(get_cadr(back)) &&
4652 lbm_is_quoted_list(front)) {
4653 lbm_value ql = get_cadr(back);
4654 lbm_value f = get_cadr(front);
4655 lbm_value b = get_cadr(ql);
4656
4657 lbm_value v = lbm_list_append(f, b);
4658 lbm_set_car(get_cdr(ql), v);
4659 return back;
4660 }
4661
4662 if (is_append(back)) {
4663 back = get_cdr(back);
4664 lbm_value new = cons_with_gc(front, back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4665 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), new, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4666 }
4667
4668 lbm_value t0, t1;
4669
4670 t0 = cons_with_gc(back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), front);
4671 t1 = cons_with_gc(front, t0, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4672 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), t1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4673}
4674
4675/* Bawden's qq-expand implementation
4676(define (qq-expand x)
4677 (cond ((tag-comma? x)
4678 (tag-data x))
4679 ((tag-comma-atsign? x)
4680 (error "Illegal"))
4681 ((tag-backquote? x)
4682 (qq-expand
4683 (qq-expand (tag-data x))))
4684 ((pair? x)
4685 `(append
4686 ,(qq-expand-list (car x))
4687 ,(qq-expand (cdr x))))
4688 (else `',x)))
4689 */
4690static void cont_qq_expand(eval_context_t *ctx) {
4691 lbm_value qquoted;
4692 lbm_pop(&ctx->K, &qquoted);
4693
4694 switch(lbm_type_of(qquoted)) {
4695 case LBM_TYPE_CONS0x10000000u: {
4696 lbm_value car_val = get_car(qquoted);
4697 lbm_value cdr_val = get_cdr(qquoted);
4698 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4699 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4700 ctx->r = append(ctx->r, get_car(cdr_val));
4701 ctx->app_cont = true1;
4702 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4703 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4704 error_ctx(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u));
4705 } else {
4706 lbm_value *rptr = stack_reserve(ctx, 6);
4707 rptr[0] = ctx->r;
4708 rptr[1] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4709 rptr[2] = cdr_val;
4710 rptr[3] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4711 rptr[4] = car_val;
4712 rptr[5] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4713 ctx->app_cont = true1;
4714 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4715 }
4716
4717 } break;
4718 default: {
4719 lbm_value res = quote_it(qquoted);
4720 ctx->r = append(ctx->r, res);
4721 ctx->app_cont = true1;
4722 }
4723 }
4724}
4725
4726static void cont_qq_append(eval_context_t *ctx) {
4727 lbm_value head;
4728 lbm_pop(&ctx->K, &head);
4729 ctx->r = append(head, ctx->r);
4730 ctx->app_cont = true1;
4731}
4732
4733/* Bawden's qq-expand-list implementation
4734(define (qq-expand-list x)
4735 (cond ((tag-comma? x)
4736 `(list ,(tag-data x)))
4737 ((tag-comma-atsign? x)
4738 (tag-data x))
4739 ((tag-backquote? x)
4740 (qq-expand-list
4741 (qq-expand (tag-data x))))
4742 ((pair? x)
4743 `(list
4744 (append
4745 ,(qq-expand-list (car x))
4746 ,(qq-expand (cdr x)))))
4747 (else `'(,x))))
4748*/
4749
4750static void cont_qq_expand_list(eval_context_t* ctx) {
4751 lbm_value l;
4752 lbm_pop(&ctx->K, &l);
4753
4754 ctx->app_cont = true1;
4755 switch(lbm_type_of(l)) {
4756 case LBM_TYPE_CONS0x10000000u: {
4757 lbm_value car_val = get_car(l);
4758 lbm_value cdr_val = get_cdr(l);
4759 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4760 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4761 lbm_value tl = cons_with_gc(get_car(cdr_val), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4762 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4763 ctx->r = append(ctx->r, tmp);
4764 return;
4765 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4766 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4767 ctx->r = get_car(cdr_val);
4768 return;
4769 } else {
4770 lbm_value *rptr = stack_reserve(ctx, 7);
4771 rptr[0] = QQ_LIST(((39) << 2) | 0xF8000001u);
4772 rptr[1] = ctx->r;
4773 rptr[2] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4774 rptr[3] = cdr_val;
4775 rptr[4] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4776 rptr[5] = car_val;
4777 rptr[6] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4778 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4779 }
4780
4781 } break;
4782 default: {
4783 lbm_value a_list = cons_with_gc(l, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4784 lbm_value tl = cons_with_gc(a_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4785 lbm_value tmp = cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4786 ctx->r = append(ctx->r, tmp);
4787 }
4788 }
4789}
4790
4791static void cont_qq_list(eval_context_t *ctx) {
4792 lbm_value val = ctx->r;
4793 lbm_value apnd_app = cons_with_gc(val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4794 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), apnd_app, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4795 ctx->r = tmp;
4796 ctx->app_cont = true1;
4797}
4798
4799static void cont_kill(eval_context_t *ctx) {
4800 (void) ctx;
4801 finish_ctx();
4802}
4803
4804static void cont_pop_reader_flags(eval_context_t *ctx) {
4805 lbm_value flags;
4806 lbm_pop(&ctx->K, &flags);
4807 ctx->flags = ctx->flags & ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4808 ctx->flags |= (lbm_dec_as_u32(flags) & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4809 // r is unchanged.
4810 ctx->app_cont = true1;
4811}
4812
4813static void cont_exception_handler(eval_context_t *ctx) {
4814 lbm_value *sptr = pop_stack_ptr(ctx, 2);
4815 lbm_value retval = sptr[0];
4816 lbm_value flags = sptr[1];
4817 lbm_set_car(get_cdr(retval), ctx->r);
4818 ctx->flags = flags;
4819 ctx->r = retval;
4820 ctx->app_cont = true1;
4821}
4822
4823/*********************************************************/
4824/* Continuations table */
4825typedef void (*cont_fun)(eval_context_t *);
4826
4827static const cont_fun continuations[NUM_CONTINUATIONS49] =
4828 { advance_ctx, // CONT_DONE
4829 cont_set_global_env,
4830 cont_bind_to_key_rest,
4831 cont_if,
4832 cont_progn_rest,
4833 cont_application_args,
4834 cont_and,
4835 cont_or,
4836 cont_wait,
4837 cont_match,
4838 cont_application_start,
4839 cont_eval_r,
4840 cont_resume,
4841 cont_closure_application_args,
4842 cont_exit_atomic,
4843 cont_read_next_token,
4844 cont_read_append_continue,
4845 cont_read_eval_continue,
4846 cont_read_expect_closepar,
4847 cont_read_dot_terminate,
4848 cont_read_done,
4849 cont_read_quote_result,
4850 cont_read_commaat_result,
4851 cont_read_comma_result,
4852 cont_read_start_array,
4853 cont_read_append_array,
4854 cont_map,
4855 cont_match_guard,
4856 cont_terminate,
4857 cont_progn_var,
4858 cont_setq,
4859 cont_move_to_flash,
4860 cont_move_val_to_flash_dispatch,
4861 cont_move_list_to_flash,
4862 cont_close_list_in_flash,
4863 cont_qq_expand_start,
4864 cont_qq_expand,
4865 cont_qq_append,
4866 cont_qq_expand_list,
4867 cont_qq_list,
4868 cont_kill,
4869 cont_loop,
4870 cont_loop_condition,
4871 cont_merge_rest,
4872 cont_merge_layer,
4873 cont_closure_args_rest,
4874 cont_move_array_elts_to_flash,
4875 cont_pop_reader_flags,
4876 cont_exception_handler
4877 };
4878
4879/*********************************************************/
4880/* Evaluators lookup table (special forms) */
4881typedef void (*evaluator_fun)(eval_context_t *);
4882
4883static const evaluator_fun evaluators[] =
4884 {
4885 eval_quote,
4886 eval_define,
4887 eval_progn,
4888 eval_lambda,
4889 eval_if,
4890 eval_let,
4891 eval_and,
4892 eval_or,
4893 eval_match,
4894 eval_receive,
4895 eval_receive_timeout,
4896 eval_callcc,
4897 eval_atomic,
4898 eval_selfevaluating, // macro
4899 eval_selfevaluating, // cont
4900 eval_selfevaluating, // closure
4901 eval_cond,
4902 eval_app_cont,
4903 eval_var,
4904 eval_setq,
4905 eval_move_to_flash,
4906 eval_loop,
4907 eval_trap
4908 };
4909
4910
4911/*********************************************************/
4912/* Evaluator step function */
4913
4914static void evaluation_step(void){
4915 eval_context_t *ctx = ctx_running;
4916#ifdef VISUALIZE_HEAP
4917 heap_vis_gen_image();
4918#endif
4919
4920 if (ctx->app_cont) {
4921 lbm_value k;
4922 lbm_pop(&ctx->K, &k);
4923 ctx->app_cont = false0;
4924
4925 lbm_uint decoded_k = DEC_CONTINUATION(k)(((k) & ~0xF8000001u) >> 2);
4926
4927 if (decoded_k < NUM_CONTINUATIONS49) {
4928 continuations[decoded_k](ctx);
4929 } else {
4930 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4931 }
4932 return;
4933 }
4934
4935 if (lbm_is_symbol(ctx->curr_exp)) {
4936 eval_symbol(ctx);
4937 return;
4938 }
4939 if (lbm_is_cons(ctx->curr_exp)) {
4940 lbm_cons_t *cell = lbm_ref_cell(ctx->curr_exp);
4941 lbm_value h = cell->car;
4942 if (lbm_is_symbol(h) && ((h & ENC_SPECIAL_FORMS_MASK0xFFFFF000) == ENC_SPECIAL_FORMS_BIT0x00001000)) {
4943 lbm_uint eval_index = lbm_dec_sym(h) & SPECIAL_FORMS_INDEX_MASK0x000000FF;
4944 evaluators[eval_index](ctx);
4945 return;
4946 }
4947 /*
4948 * At this point head can be anything. It should evaluate
4949 * into a form that can be applied (closure, symbol, ...) though.
4950 */
4951 lbm_value *reserved = stack_reserve(ctx, 3);
4952 reserved[0] = ctx->curr_env;
4953 reserved[1] = cell->cdr;
4954 reserved[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
4955 ctx->curr_exp = h; // evaluate the function
4956 return;
4957 }
4958
4959 eval_selfevaluating(ctx);
4960 return;
4961}
4962
4963void lbm_pause_eval(void ) {
4964 eval_cps_next_state_arg = 0;
4965 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4966 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4967}
4968
4969void lbm_pause_eval_with_gc(uint32_t num_free) {
4970 eval_cps_next_state_arg = num_free;
4971 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4972 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4973}
4974
4975void lbm_continue_eval(void) {
4976 eval_cps_next_state = EVAL_CPS_STATE_RUNNING2;
4977 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4978}
4979
4980void lbm_kill_eval(void) {
4981 eval_cps_next_state = EVAL_CPS_STATE_KILL4;
4982 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4983}
4984
4985uint32_t lbm_get_eval_state(void) {
4986 return eval_cps_run_state;
4987}
4988
4989// Will wake up thread that is sleeping as well.
4990// Not sure this is good behavior.
4991static void handle_event_unblock_ctx(lbm_cid cid, lbm_value v) {
4992 eval_context_t *found = NULL((void*)0);
4993 mutex_lock(&qmutex);
4994
4995 found = lookup_ctx_nm(&blocked, cid);
4996 if (found) {
4997 drop_ctx_nm(&blocked,found);
4998 if (lbm_is_error(v)) {
4999 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
5000 found->app_cont = true1;
5001 }
5002 found->r = v;
5003 enqueue_ctx_nm(&queue,found);
5004 }
5005 mutex_unlock(&qmutex);
5006}
5007
5008static void handle_event_define(lbm_value key, lbm_value val) {
5009 lbm_uint dec_key = lbm_dec_sym(key);
5010 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
5011 lbm_value *global_env = lbm_get_global_env();
5012 lbm_uint orig_env = global_env[ix_key];
5013 lbm_value new_env;
5014 // A key is a symbol and should not need to be remembered.
5015 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
5016
5017 global_env[ix_key] = new_env;
5018}
5019
5020static lbm_value get_event_value(lbm_event_t *e) {
5021 lbm_value v;
5022 if (e->buf_len > 0) {
5023 lbm_flat_value_t fv;
5024 fv.buf = (uint8_t*)e->buf_ptr;
5025 fv.buf_size = e->buf_len;
5026 fv.buf_pos = 0;
5027 if (!lbm_unflatten_value(&fv, &v)) {
5028 lbm_set_flags(LBM_FLAG_HANDLER_EVENT_DELIVERY_FAILED(1 << 1));
5029 v = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
5030 }
5031 // Free the flat value buffer. GC is unaware of its existence.
5032 lbm_free(fv.buf);
5033 } else {
5034 v = (lbm_value)e->buf_ptr;
5035 }
5036 return v;
5037}
5038
5039static void process_events(void) {
5040
5041 if (!lbm_events) return;
5042 lbm_event_t e;
5043
5044 while (lbm_event_pop(&e)) {
5045
5046 lbm_value event_val = get_event_value(&e);
5047 switch(e.type) {
5048 case LBM_EVENT_UNBLOCK_CTX:
5049 handle_event_unblock_ctx((lbm_cid)e.parameter, event_val);
5050 break;
5051 case LBM_EVENT_DEFINE:
5052 handle_event_define((lbm_value)e.parameter, event_val);
5053 break;
5054 case LBM_EVENT_FOR_HANDLER:
5055 if (lbm_event_handler_pid >= 0) {
5056 lbm_find_receiver_and_send(lbm_event_handler_pid, event_val);
5057 }
5058 break;
5059 }
5060 }
5061}
5062
5063/* eval_cps_run can be paused
5064 I think it would be better use a mailbox for
5065 communication between other threads and the run_eval
5066 but for now a set of variables will be used. */
5067void lbm_run_eval(void){
5068
5069 if (setjmp(critical_error_jmp_buf)_setjmp (critical_error_jmp_buf) > 0) {
5070 printf_callback("GC stack overflow!\n");
5071 critical_error_callback();
5072 // terminate evaluation thread.
5073 return;
5074 }
5075
5076 setjmp(error_jmp_buf)_setjmp (error_jmp_buf);
5077
5078 while (eval_running) {
5079 if (eval_cps_state_changed || eval_cps_run_state == EVAL_CPS_STATE_PAUSED1) {
5080 eval_cps_state_changed = false0;
5081 switch (eval_cps_next_state) {
5082 case EVAL_CPS_STATE_PAUSED1:
5083 if (eval_cps_run_state != EVAL_CPS_STATE_PAUSED1) {
5084 if (lbm_heap_num_free() < eval_cps_next_state_arg) {
5085 gc();
5086 }
5087 eval_cps_next_state_arg = 0;
5088 }
5089 eval_cps_run_state = EVAL_CPS_STATE_PAUSED1;
5090 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5091 continue; /* jump back to start of eval_running loop */
5092 case EVAL_CPS_STATE_KILL4:
5093 eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
5094 eval_running = false0;
5095 continue;
5096 default: // running state
5097 eval_cps_run_state = eval_cps_next_state;
5098 break;
5099 }
5100 }
5101 while (true1) {
5102 if (eval_steps_quota && ctx_running) {
5103 eval_steps_quota--;
5104 evaluation_step();
5105 } else {
5106 if (eval_cps_state_changed) break;
5107 eval_steps_quota = eval_steps_refill;
5108 if (is_atomic) {
5109 if (!ctx_running) {
5110 lbm_set_flags(LBM_FLAG_ATOMIC_MALFUNCTION(1 << 0));
5111 is_atomic = 0;
5112 }
5113 } else {
5114 if (gc_requested) {
5115 gc();
5116 }
5117 process_events();
5118 mutex_lock(&qmutex);
5119 if (ctx_running) {
5120 enqueue_ctx_nm(&queue, ctx_running);
5121 ctx_running = NULL((void*)0);
5122 }
5123 wake_up_ctxs_nm();
5124 ctx_running = dequeue_ctx_nm(&queue);
5125 mutex_unlock(&qmutex);
5126 if (!ctx_running) {
5127 lbm_system_sleeping = true1;
5128 //Fixed sleep interval to poll events regularly.
5129 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5130 lbm_system_sleeping = false0;
5131 }
5132 }
5133 }
5134 }
5135 }
5136}
5137
5138lbm_cid lbm_eval_program(lbm_value lisp) {
5139 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), 256, NULL((void*)0));
5140}
5141
5142lbm_cid lbm_eval_program_ext(lbm_value lisp, unsigned int stack_size) {
5143 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), stack_size, NULL((void*)0));
5144}
5145
5146int lbm_eval_init() {
5147 if (!qmutex_initialized) {
5148 mutex_init(&qmutex);
5149 qmutex_initialized = true1;
5150 }
5151 if (!lbm_events_mutex_initialized) {
5152 mutex_init(&lbm_events_mutex);
5153 lbm_events_mutex_initialized = true1;
5154 }
5155 if (!blocking_extension_mutex_initialized) {
5156 mutex_init(&blocking_extension_mutex);
5157 blocking_extension_mutex_initialized = true1;
5158 }
5159
5160 mutex_lock(&qmutex);
5161 mutex_lock(&lbm_events_mutex);
5162
5163 blocked.first = NULL((void*)0);
5164 blocked.last = NULL((void*)0);
5165 queue.first = NULL((void*)0);
5166 queue.last = NULL((void*)0);
5167 ctx_running = NULL((void*)0);
5168
5169 eval_cps_run_state = EVAL_CPS_STATE_RUNNING2;
5170
5171 mutex_unlock(&lbm_events_mutex);
5172 mutex_unlock(&qmutex);
5173
5174 if (!lbm_init_env()) return 0;
5175 eval_running = true1;
5176 return 1;
5177}
5178
5179bool_Bool lbm_eval_init_events(unsigned int num_events) {
5180
5181 mutex_lock(&lbm_events_mutex);
5182 lbm_events = (lbm_event_t*)lbm_malloc(num_events * sizeof(lbm_event_t));
5183 bool_Bool r = false0;
5184 if (lbm_events) {
5185 lbm_events_max = num_events;
5186 lbm_events_head = 0;
5187 lbm_events_tail = 0;
5188 lbm_events_full = false0;
5189 lbm_event_handler_pid = -1;
5190 r = true1;
5191 }
5192 mutex_unlock(&lbm_events_mutex);
5193 return r;
5194}
diff --git a/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-4a8c88.html b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-4a8c88.html new file mode 100644 index 00000000..d2ac1e81 --- /dev/null +++ b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-4a8c88.html @@ -0,0 +1,5576 @@ + + + +src/eval_cps.c + + + + + + + + + + + + + + + + + + + + + + + + + + +

Bug Summary

+ + + + +
File:eval_cps.c
Warning:line 1598, column 5
3rd function call argument is an uninitialized value
+ +

Annotated Source Code

+

Press '?' + to see keyboard shortcuts

+ + +
clang -cc1 -triple i386-pc-linux-gnu -analyze -disable-free -disable-llvm-verifier -discard-value-names -main-file-name eval_cps.c -analyzer-store=region -analyzer-opt-analyze-nested-blocks -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -mrelocation-model static -mthread-model posix -mframe-pointer=none -fmath-errno -fno-rounding-math -masm-verbose -mconstructor-aliases -target-cpu i686 -dwarf-column-info -fno-split-dwarf-inlining -debugger-tuning=gdb -resource-dir /usr/lib/llvm-10/lib/clang/10.0.0 -I ./include -I ./include/extensions -I platform/linux/include -D _PRELUDE -internal-isystem /usr/local/include -internal-isystem /usr/lib/llvm-10/lib/clang/10.0.0/include -internal-externc-isystem /usr/include/i386-linux-gnu -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -std=c99 -fdebug-compilation-dir /home/joels/Current/lispbm -ferror-limit 19 -fmessage-length 0 -fgnuc-version=4.2.1 -fobjc-runtime=gcc -fdiagnostics-show-option -vectorize-loops -vectorize-slp -analyzer-output=html -faddrsig -o /home/joels/Current/lispbm/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1 -x c src/eval_cps.c +
+ + + +
+ + +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1/*
2 Copyright 2018, 2020 - 2024 Joel Svensson svenssonjoel@yahoo.se
3
4 This program is free software: you can redistribute it and/or modify
5 it under the terms of the GNU General Public License as published by
6 the Free Software Foundation, either version 3 of the License, or
7 (at your option) any later version.
8
9 This program is distributed in the hope that it will be useful,
10 but WITHOUT ANY WARRANTY; without even the implied warranty of
11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 GNU General Public License for more details.
13
14 You should have received a copy of the GNU General Public License
15 along with this program. If not, see <http://www.gnu.org/licenses/>.
16*/
17
18#include <lbm_memory.h>
19#include <lbm_types.h>
20#include "symrepr.h"
21#include "heap.h"
22#include "env.h"
23#include "eval_cps.h"
24#include "stack.h"
25#include "fundamental.h"
26#include "extensions.h"
27#include "tokpar.h"
28#include "lbm_channel.h"
29#include "print.h"
30#include "platform_mutex.h"
31#include "lbm_flat_value.h"
32#include "lbm_flags.h"
33
34#ifdef VISUALIZE_HEAP
35#include "heap_vis.h"
36#endif
37
38#include <setjmp.h>
39#include <stdarg.h>
40
41static jmp_buf error_jmp_buf;
42static jmp_buf critical_error_jmp_buf;
43
44#define S_TO_US(X)(lbm_uint)((X) * 1000000) (lbm_uint)((X) * 1000000)
45
46#define DEC_CONTINUATION(x)(((x) & ~0xF8000001u) >> 2) (((x) & ~LBM_CONTINUATION_INTERNAL0xF8000001u) >> LBM_ADDRESS_SHIFT2)
47#define IS_CONTINUATION(x)(((x) & 0xF8000001u) == 0xF8000001u) (((x) & LBM_CONTINUATION_INTERNAL0xF8000001u) == LBM_CONTINUATION_INTERNAL0xF8000001u)
48#define CONTINUATION(x)(((x) << 2) | 0xF8000001u) (((x) << LBM_ADDRESS_SHIFT2) | LBM_CONTINUATION_INTERNAL0xF8000001u)
49
50#define DONE(((0) << 2) | 0xF8000001u) CONTINUATION(0)(((0) << 2) | 0xF8000001u)
51#define SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u) CONTINUATION(1)(((1) << 2) | 0xF8000001u)
52#define BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u) CONTINUATION(2)(((2) << 2) | 0xF8000001u)
53#define IF(((3) << 2) | 0xF8000001u) CONTINUATION(3)(((3) << 2) | 0xF8000001u)
54#define PROGN_REST(((4) << 2) | 0xF8000001u) CONTINUATION(4)(((4) << 2) | 0xF8000001u)
55#define APPLICATION_ARGS(((5) << 2) | 0xF8000001u) CONTINUATION(5)(((5) << 2) | 0xF8000001u)
56#define AND(((6) << 2) | 0xF8000001u) CONTINUATION(6)(((6) << 2) | 0xF8000001u)
57#define OR(((7) << 2) | 0xF8000001u) CONTINUATION(7)(((7) << 2) | 0xF8000001u)
58#define WAIT(((8) << 2) | 0xF8000001u) CONTINUATION(8)(((8) << 2) | 0xF8000001u)
59#define MATCH(((9) << 2) | 0xF8000001u) CONTINUATION(9)(((9) << 2) | 0xF8000001u)
60#define APPLICATION_START(((10) << 2) | 0xF8000001u) CONTINUATION(10)(((10) << 2) | 0xF8000001u)
61#define EVAL_R(((11) << 2) | 0xF8000001u) CONTINUATION(11)(((11) << 2) | 0xF8000001u)
62#define RESUME(((12) << 2) | 0xF8000001u) CONTINUATION(12)(((12) << 2) | 0xF8000001u)
63#define CLOSURE_ARGS(((13) << 2) | 0xF8000001u) CONTINUATION(13)(((13) << 2) | 0xF8000001u)
64#define EXIT_ATOMIC(((14) << 2) | 0xF8000001u) CONTINUATION(14)(((14) << 2) | 0xF8000001u)
65#define READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u) CONTINUATION(15)(((15) << 2) | 0xF8000001u)
66#define READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u) CONTINUATION(16)(((16) << 2) | 0xF8000001u)
67#define READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u) CONTINUATION(17)(((17) << 2) | 0xF8000001u)
68#define READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u) CONTINUATION(18)(((18) << 2) | 0xF8000001u)
69#define READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u) CONTINUATION(19)(((19) << 2) | 0xF8000001u)
70#define READ_DONE(((20) << 2) | 0xF8000001u) CONTINUATION(20)(((20) << 2) | 0xF8000001u)
71#define READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u) CONTINUATION(21)(((21) << 2) | 0xF8000001u)
72#define READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u) CONTINUATION(22)(((22) << 2) | 0xF8000001u)
73#define READ_COMMA_RESULT(((23) << 2) | 0xF8000001u) CONTINUATION(23)(((23) << 2) | 0xF8000001u)
74#define READ_START_ARRAY(((24) << 2) | 0xF8000001u) CONTINUATION(24)(((24) << 2) | 0xF8000001u)
75#define READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u) CONTINUATION(25)(((25) << 2) | 0xF8000001u)
76#define MAP(((26) << 2) | 0xF8000001u) CONTINUATION(26)(((26) << 2) | 0xF8000001u)
77#define MATCH_GUARD(((27) << 2) | 0xF8000001u) CONTINUATION(27)(((27) << 2) | 0xF8000001u)
78#define TERMINATE(((28) << 2) | 0xF8000001u) CONTINUATION(28)(((28) << 2) | 0xF8000001u)
79#define PROGN_VAR(((29) << 2) | 0xF8000001u) CONTINUATION(29)(((29) << 2) | 0xF8000001u)
80#define SETQ(((30) << 2) | 0xF8000001u) CONTINUATION(30)(((30) << 2) | 0xF8000001u)
81#define MOVE_TO_FLASH(((31) << 2) | 0xF8000001u) CONTINUATION(31)(((31) << 2) | 0xF8000001u)
82#define MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u) CONTINUATION(32)(((32) << 2) | 0xF8000001u)
83#define MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u) CONTINUATION(33)(((33) << 2) | 0xF8000001u)
84#define CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u) CONTINUATION(34)(((34) << 2) | 0xF8000001u)
85#define QQ_EXPAND_START(((35) << 2) | 0xF8000001u) CONTINUATION(35)(((35) << 2) | 0xF8000001u)
86#define QQ_EXPAND(((36) << 2) | 0xF8000001u) CONTINUATION(36)(((36) << 2) | 0xF8000001u)
87#define QQ_APPEND(((37) << 2) | 0xF8000001u) CONTINUATION(37)(((37) << 2) | 0xF8000001u)
88#define QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u) CONTINUATION(38)(((38) << 2) | 0xF8000001u)
89#define QQ_LIST(((39) << 2) | 0xF8000001u) CONTINUATION(39)(((39) << 2) | 0xF8000001u)
90#define KILL(((40) << 2) | 0xF8000001u) CONTINUATION(40)(((40) << 2) | 0xF8000001u)
91#define LOOP(((41) << 2) | 0xF8000001u) CONTINUATION(41)(((41) << 2) | 0xF8000001u)
92#define LOOP_CONDITION(((42) << 2) | 0xF8000001u) CONTINUATION(42)(((42) << 2) | 0xF8000001u)
93#define MERGE_REST(((43) << 2) | 0xF8000001u) CONTINUATION(43)(((43) << 2) | 0xF8000001u)
94#define MERGE_LAYER(((44) << 2) | 0xF8000001u) CONTINUATION(44)(((44) << 2) | 0xF8000001u)
95#define CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u) CONTINUATION(45)(((45) << 2) | 0xF8000001u)
96#define MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u) CONTINUATION(46)(((46) << 2) | 0xF8000001u)
97#define POP_READER_FLAGS(((47) << 2) | 0xF8000001u) CONTINUATION(47)(((47) << 2) | 0xF8000001u)
98#define EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u) CONTINUATION(48)(((48) << 2) | 0xF8000001u)
99#define NUM_CONTINUATIONS49 49
100
101#define FM_NEED_GC-1 -1
102#define FM_NO_MATCH-2 -2
103#define FM_PATTERN_ERROR-3 -3
104
105typedef enum {
106 BL_OK = 0,
107 BL_NO_MEMORY,
108 BL_INCORRECT_KEY
109} binding_location_status;
110
111#define FB_OK0 0
112#define FB_TYPE_ERROR-1 -1
113
114const char* lbm_error_str_parse_eof = "End of parse stream.";
115const char* lbm_error_str_parse_dot = "Incorrect usage of '.'.";
116const char* lbm_error_str_parse_close = "Expected closing parenthesis.";
117const char* lbm_error_str_num_args = "Incorrect number of arguments.";
118const char* lbm_error_str_forbidden_in_atomic = "Operation is forbidden in an atomic block.";
119const char* lbm_error_str_no_number = "Argument(s) must be a number.";
120const char* lbm_error_str_not_a_boolean = "Argument must be t or nil (true or false).";
121const char* lbm_error_str_incorrect_arg = "Incorrect argument.";
122const char* lbm_error_str_var_outside_progn = "Usage of var outside of progn.";
123const char* lbm_error_str_flash_not_possible = "Value cannot be written to flash.";
124const char* lbm_error_str_flash_error = "Error writing to flash.";
125const char* lbm_error_str_flash_full = "Flash memory is full.";
126const char* lbm_error_str_variable_not_bound = "Variable not bound.";
127
128static lbm_value lbm_error_suspect;
129static bool_Bool lbm_error_has_suspect = false0;
130#ifdef LBM_ALWAYS_GC
131
132#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
133 gc(); \
134 (y) = (x); \
135 if (lbm_is_symbol_merror((y))) { \
136 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
137 }
138
139#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
140 lbm_gc_mark_phase(r); \
141 gc(); \
142 (y) = (x); \
143 if (lbm_is_symbol_merror((y))) { \
144 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
145 }
146
147#else
148
149#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
150 (y) = (x); \
151 if (lbm_is_symbol_merror((y))) { \
152 gc(); \
153 (y) = (x); \
154 if (lbm_is_symbol_merror((y))) { \
155 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
156 } \
157 /* continue executing statements below */ \
158 }
159#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
160 (y) = (x); \
161 if (lbm_is_symbol_merror((y))) { \
162 lbm_gc_mark_phase(r); \
163 gc(); \
164 (y) = (x); \
165 if (lbm_is_symbol_merror((y))) { \
166 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
167 } \
168 /* continue executing statements below */ \
169 }
170
171#endif
172
173typedef struct {
174 eval_context_t *first;
175 eval_context_t *last;
176} eval_context_queue_t;
177
178#ifdef CLEAN_UP_CLOSURES
179static lbm_value clean_cl_env_symbol = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
180#endif
181
182static int gc(void);
183static void error_ctx(lbm_value);
184static void error_at_ctx(lbm_value err_val, lbm_value at);
185static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx);
186static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail);
187
188// The currently executing context.
189eval_context_t *ctx_running = NULL((void*)0);
190volatile bool_Bool lbm_system_sleeping = false0;
191
192static volatile bool_Bool gc_requested = false0;
193void lbm_request_gc(void) {
194 gc_requested = true1;
195}
196
197/*
198 On ChibiOs the CH_CFG_ST_FREQUENCY setting in chconf.h sets the
199 resolution of the timer used for sleep operations. If this is set
200 to 10KHz the resolution is 100us.
201
202 The CH_CFG_ST_TIMEDELTA specifies the minimum number of ticks that
203 can be safely specified in a timeout directive (wonder if that
204 means sleep-period). The timedelta is set to 2.
205
206 If I have understood these correctly it means that the minimum
207 sleep duration possible is 2 * 100us = 200us.
208*/
209
210#define EVAL_CPS_DEFAULT_STACK_SIZE256 256
211#define EVAL_CPS_MIN_SLEEP200 200
212#define EVAL_STEPS_QUOTA10 10
213
214static volatile uint32_t eval_steps_refill = EVAL_STEPS_QUOTA10;
215static uint32_t eval_steps_quota = EVAL_STEPS_QUOTA10;
216
217void lbm_set_eval_step_quota(uint32_t quota) {
218 eval_steps_refill = quota;
219}
220
221static uint32_t eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
222static volatile uint32_t eval_cps_next_state = EVAL_CPS_STATE_NONE0;
223static volatile uint32_t eval_cps_next_state_arg = 0;
224static volatile bool_Bool eval_cps_state_changed = false0;
225
226static void usleep_nonsense(uint32_t us) {
227 (void) us;
228}
229
230static bool_Bool dynamic_load_nonsense(const char *sym, const char **code) {
231 (void) sym;
232 (void) code;
233 return false0;
234}
235
236static uint32_t timestamp_nonsense(void) {
237 return 0;
238}
239
240static int printf_nonsense(const char *fmt, ...) {
241 (void) fmt;
242 return 0;
243}
244
245static void ctx_done_nonsense(eval_context_t *ctx) {
246 (void) ctx;
247}
248
249static void critical_nonsense(void) {
250 return;
251}
252
253static void (*critical_error_callback)(void) = critical_nonsense;
254static void (*usleep_callback)(uint32_t) = usleep_nonsense;
255static uint32_t (*timestamp_us_callback)(void) = timestamp_nonsense;
256static void (*ctx_done_callback)(eval_context_t *) = ctx_done_nonsense;
257static int (*printf_callback)(const char *, ...) = printf_nonsense;
258static bool_Bool (*dynamic_load_callback)(const char *, const char **) = dynamic_load_nonsense;
259
260void lbm_set_critical_error_callback(void (*fptr)(void)) {
261 if (fptr == NULL((void*)0)) critical_error_callback = critical_nonsense;
262 else critical_error_callback = fptr;
263}
264
265void lbm_set_usleep_callback(void (*fptr)(uint32_t)) {
266 if (fptr == NULL((void*)0)) usleep_callback = usleep_nonsense;
267 else usleep_callback = fptr;
268}
269
270void lbm_set_timestamp_us_callback(uint32_t (*fptr)(void)) {
271 if (fptr == NULL((void*)0)) timestamp_us_callback = timestamp_nonsense;
272 else timestamp_us_callback = fptr;
273}
274
275void lbm_set_ctx_done_callback(void (*fptr)(eval_context_t *)) {
276 if (fptr == NULL((void*)0)) ctx_done_callback = ctx_done_nonsense;
277 else ctx_done_callback = fptr;
278}
279
280void lbm_set_printf_callback(int (*fptr)(const char*, ...)){
281 if (fptr == NULL((void*)0)) printf_callback = printf_nonsense;
282 else printf_callback = fptr;
283}
284
285void lbm_set_dynamic_load_callback(bool_Bool (*fptr)(const char *, const char **)) {
286 if (fptr == NULL((void*)0)) dynamic_load_callback = dynamic_load_nonsense;
287 else dynamic_load_callback = fptr;
288}
289
290static volatile lbm_event_t *lbm_events = NULL((void*)0);
291static unsigned int lbm_events_head = 0;
292static unsigned int lbm_events_tail = 0;
293static unsigned int lbm_events_max = 0;
294static bool_Bool lbm_events_full = false0;
295static mutex_t lbm_events_mutex;
296static bool_Bool lbm_events_mutex_initialized = false0;
297static volatile lbm_cid lbm_event_handler_pid = -1;
298
299lbm_cid lbm_get_event_handler_pid(void) {
300 return lbm_event_handler_pid;
301}
302
303void lbm_set_event_handler_pid(lbm_cid pid) {
304 lbm_event_handler_pid = pid;
305}
306
307bool_Bool lbm_event_handler_exists(void) {
308 return(lbm_event_handler_pid > 0);
309}
310
311
312static bool_Bool event_internal(lbm_event_type_t event_type, lbm_uint parameter, lbm_uint buf_ptr, lbm_uint buf_len) {
313 bool_Bool r = false0;
314 if (lbm_events) {
315 mutex_lock(&lbm_events_mutex);
316 if (!lbm_events_full) {
317 lbm_event_t event;
318 event.type = event_type;
319 event.parameter = parameter;
320 event.buf_ptr = buf_ptr;
321 event.buf_len = buf_len;
322 lbm_events[lbm_events_head] = event;
323 lbm_events_head = (lbm_events_head + 1) % lbm_events_max;
324 lbm_events_full = lbm_events_head == lbm_events_tail;
325 r = true1;
326 }
327 mutex_unlock(&lbm_events_mutex);
328 }
329 return r;
330}
331
332bool_Bool lbm_event_define(lbm_value key, lbm_flat_value_t *fv) {
333 return event_internal(LBM_EVENT_DEFINE, key, (lbm_uint)fv->buf, fv->buf_size);
334}
335
336bool_Bool lbm_event_unboxed(lbm_value unboxed) {
337 lbm_uint t = lbm_type_of(unboxed);
338 if (t == LBM_TYPE_SYMBOL0x00000000u ||
339 t == LBM_TYPE_I0x00000008u ||
340 t == LBM_TYPE_U0x0000000Cu ||
341 t == LBM_TYPE_CHAR0x00000004u) {
342 if (lbm_event_handler_pid > 0) {
343 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)unboxed, 0);
344 }
345 }
346 return false0;
347}
348
349bool_Bool lbm_event(lbm_flat_value_t *fv) {
350 if (lbm_event_handler_pid > 0) {
351 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)fv->buf, fv->buf_size);
352 }
353 return false0;
354}
355
356static bool_Bool lbm_event_pop(lbm_event_t *event) {
357 mutex_lock(&lbm_events_mutex);
358 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
359 mutex_unlock(&lbm_events_mutex);
360 return false0;
361 }
362 *event = lbm_events[lbm_events_tail];
363 lbm_events_tail = (lbm_events_tail + 1) % lbm_events_max;
364 lbm_events_full = false0;
365 mutex_unlock(&lbm_events_mutex);
366 return true1;
367}
368
369bool_Bool lbm_event_queue_is_empty(void) {
370 mutex_lock(&lbm_events_mutex);
371 bool_Bool empty = false0;
372 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
373 empty = true1;
374 }
375 mutex_unlock(&lbm_events_mutex);
376 return empty;
377}
378
379static bool_Bool eval_running = false0;
380static volatile bool_Bool blocking_extension = false0;
381static mutex_t blocking_extension_mutex;
382static bool_Bool blocking_extension_mutex_initialized = false0;
383static lbm_uint blocking_extension_timeout_us = 0;
384static bool_Bool blocking_extension_timeout = false0;
385
386static uint32_t is_atomic = 0;
387
388/* Process queues */
389static eval_context_queue_t blocked = {NULL((void*)0), NULL((void*)0)};
390static eval_context_queue_t queue = {NULL((void*)0), NULL((void*)0)};
391
392/* one mutex for all queue operations */
393mutex_t qmutex;
394bool_Bool qmutex_initialized = false0;
395
396
397// MODES
398static volatile bool_Bool lbm_verbose = false0;
399
400void lbm_toggle_verbose(void) {
401 lbm_verbose = !lbm_verbose;
402}
403
404void lbm_set_verbose(bool_Bool verbose) {
405 lbm_verbose = verbose;
406}
407
408lbm_cid lbm_get_current_cid(void) {
409 if (ctx_running)
410 return ctx_running->id;
411 else
412 return -1;
413}
414
415eval_context_t *lbm_get_current_context(void) {
416 return ctx_running;
417}
418
419/****************************************************/
420/* Utilities used locally in this file */
421
422static lbm_value cons_with_gc(lbm_value head, lbm_value tail, lbm_value remember) {
423#ifdef LBM_ALWAYS_GC
424 lbm_value roots[3] = {head, tail, remember};
425 lbm_gc_mark_roots(roots, 3);
426 gc();
427 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
428 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
429 if (lbm_is_symbol_merror(res)) {
430 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
431 }
432 return res;
433#else
434 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
435 if (lbm_is_symbol_merror(res)) {
436 lbm_value roots[3] = {head, tail, remember};
437 lbm_gc_mark_roots(roots,3);
438 gc();
439 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
440 if (lbm_is_symbol_merror(res)) {
441 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
442 }
443 }
444 return res;
445#endif
446}
447
448static lbm_uint *get_stack_ptr(eval_context_t *ctx, unsigned int n) {
449 if (n <= ctx->K.sp) {
450 lbm_uint index = ctx->K.sp - n;
451 return &ctx->K.data[index];
452 }
453 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
454 return 0; // dead code cannot be reached, but C compiler doesn't realise.
455}
456
457// pop_stack_ptr is safe when no GC is performed and
458// the values of the stack will be dropped.
459static lbm_uint *pop_stack_ptr(eval_context_t *ctx, unsigned int n) {
460 if (n <= ctx->K.sp) {
461 ctx->K.sp -= n;
462 return &ctx->K.data[ctx->K.sp];
463 }
464 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
465 return 0; // dead code cannot be reached, but C compiler doesn't realise.
466}
467
468static inline lbm_uint *stack_reserve(eval_context_t *ctx, unsigned int n) {
469 if (ctx->K.sp + n < ctx->K.size) {
470 lbm_uint *ptr = &ctx->K.data[ctx->K.sp];
471 ctx->K.sp += n;
472 return ptr;
473 }
474 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
475 return 0; // dead code cannot be reached, but C compiler doesn't realise.
476}
477
478static void handle_flash_status(lbm_flash_status s) {
479 if ( s == LBM_FLASH_FULL) {
480 lbm_set_error_reason((char*)lbm_error_str_flash_full);
481 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
482 }
483 if (s == LBM_FLASH_WRITE_ERROR) {
484 lbm_set_error_reason((char*)lbm_error_str_flash_error);
485 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
486 }
487}
488
489static void lift_array_flash(lbm_value flash_cell, bool_Bool bytearray, char *data, lbm_uint num_elt) {
490
491 lbm_array_header_t flash_array_header;
492 flash_array_header.size = num_elt;
493 flash_array_header.data = (lbm_uint*)data;
494 lbm_uint flash_array_header_ptr;
495 handle_flash_status(lbm_write_const_raw((lbm_uint*)&flash_array_header,
496 sizeof(lbm_array_header_t) / sizeof(lbm_uint),
497 &flash_array_header_ptr));
498 handle_flash_status(write_const_car(flash_cell, flash_array_header_ptr));
499 lbm_uint t = bytearray ? ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u) : ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u);
500 handle_flash_status(write_const_cdr(flash_cell, t));
501}
502
503static void get_car_and_cdr(lbm_value a, lbm_value *a_car, lbm_value *a_cdr) {
504 if (lbm_is_ptr(a)) {
505 lbm_cons_t *cell = lbm_ref_cell(a);
506 *a_car = cell->car;
507 *a_cdr = cell->cdr;
508 } else if (lbm_is_symbol_nil(a)) {
509 *a_car = *a_cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
510 } else {
511 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
512 }
513}
514
515/* car cdr caar cadr replacements that are evaluator safe. */
516static lbm_value get_car(lbm_value a) {
517 if (lbm_is_ptr(a)) {
518 lbm_cons_t *cell = lbm_ref_cell(a);
519 return cell->car;
520 } else if (lbm_is_symbol_nil(a)) {
521 return a;
522 }
523 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
524 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
525}
526
527static lbm_value get_cdr(lbm_value a) {
528 if (lbm_is_ptr(a)) {
529 lbm_cons_t *cell = lbm_ref_cell(a);
530 return cell->cdr;
531 } else if (lbm_is_symbol_nil(a)) {
532 return a;
533 }
534 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
535 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
536}
537
538static lbm_value get_cadr(lbm_value a) {
539 if (lbm_is_ptr(a)) {
540 lbm_cons_t *cell = lbm_ref_cell(a);
541 lbm_value tmp = cell->cdr;
542 if (lbm_is_ptr(tmp)) {
543 return lbm_ref_cell(tmp)->car;
544 } else if (lbm_is_symbol_nil(tmp)) {
545 return tmp;
546 }
547 } else if (lbm_is_symbol_nil(a)) {
548 return a;
549 }
550 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
551 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
552}
553
554static lbm_value allocate_closure(lbm_value params, lbm_value body, lbm_value env) {
555
556#ifdef LBM_ALWAYS_GC
557 gc();
558 if (lbm_heap_num_free() < 4) {
559 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
560 }
561#else
562 if (lbm_heap_num_free() < 4) {
563 gc();
564 if (lbm_heap_num_free() < 4) {
565 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
566 }
567 }
568#endif
569 // The freelist will always contain just plain heap-cells.
570 // So dec_ptr is sufficient.
571 lbm_value res = lbm_heap_state.freelist;
572 if (lbm_type_of(res) == LBM_TYPE_CONS0x10000000u) {
573 lbm_cons_t *heap = lbm_heap_state.heap;
574 lbm_uint ix = lbm_dec_ptr(res);
575 heap[ix].car = ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u);
576 ix = lbm_dec_ptr(heap[ix].cdr);
577 heap[ix].car = params;
578 ix = lbm_dec_ptr(heap[ix].cdr);
579 heap[ix].car = body;
580 ix = lbm_dec_ptr(heap[ix].cdr);
581 heap[ix].car = env;
582 lbm_heap_state.freelist = heap[ix].cdr;
583 heap[ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
584 lbm_heap_state.num_alloc+=4;
585 } else {
586 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
587 }
588 return res;
589}
590
591// Allocate a binding and attach it to a list (if so desired)
592static lbm_value allocate_binding(lbm_value key, lbm_value val, lbm_value the_cdr) {
593 if (lbm_heap_num_free() < 2) {
594 gc();
595 if (lbm_heap_num_free() < 2) {
596 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
597 }
598 }
599 lbm_cons_t* heap = lbm_heap_state.heap;
600 lbm_value binding_cell = lbm_heap_state.freelist;
601 lbm_uint binding_cell_ix = lbm_dec_ptr(binding_cell);
602 lbm_value list_cell = heap[binding_cell_ix].cdr;
603 lbm_uint list_cell_ix = lbm_dec_ptr(list_cell);
604 lbm_heap_state.freelist = heap[list_cell_ix].cdr;
605 lbm_heap_state.num_alloc += 2;
606 heap[binding_cell_ix].car = key;
607 heap[binding_cell_ix].cdr = val;
608 heap[list_cell_ix].car = binding_cell;
609 heap[list_cell_ix].cdr = the_cdr;
610 return list_cell;
611}
612
613#define CLO_PARAMS0 0
614#define CLO_BODY1 1
615#define CLO_ENV2 2
616#define LOOP_BINDS0 0
617#define LOOP_COND1 1
618#define LOOP_BODY2 2
619
620// (a b c) -> [a b c]
621static lbm_value extract_n(lbm_value curr, lbm_value *res, unsigned int n) {
622 for (unsigned int i = 0; i < n; i ++) {
623 if (lbm_is_ptr(curr)) {
624 lbm_cons_t *cell = lbm_ref_cell(curr);
625 res[i] = cell->car;
626 curr = cell->cdr;
627 } else {
628 res[i] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
629 }
630 }
631 return curr; // Rest of list is returned here.
632}
633
634static void call_fundamental(lbm_uint fundamental, lbm_value *args, lbm_uint arg_count, eval_context_t *ctx) {
635 lbm_value res;
636 res = fundamental_table[fundamental](args, arg_count, ctx);
637 if (lbm_is_error(res)) {
638 if (lbm_is_symbol_merror(res)) {
639 gc();
640 res = fundamental_table[fundamental](args, arg_count, ctx);
641 }
642 if (lbm_is_error(res)) {
643 error_at_ctx(res, lbm_enc_sym(FUNDAMENTAL_SYMBOLS_START0x20000 | fundamental));
644 }
645 }
646 lbm_stack_drop(&ctx->K, arg_count+1);
647 ctx->app_cont = true1;
648 ctx->r = res;
649}
650
651// block_current_ctx blocks a context until it is
652// woken up externally or a timeout period of time passes.
653static void block_current_ctx(uint32_t state, lbm_uint sleep_us, bool_Bool do_cont) {
654 ctx_running->timestamp = timestamp_us_callback();
655 ctx_running->sleep_us = sleep_us;
656 ctx_running->state = state;
657 ctx_running->app_cont = do_cont;
658 enqueue_ctx(&blocked, ctx_running);
659 ctx_running = NULL((void*)0);
660}
661
662lbm_flash_status lbm_write_const_array_padded(uint8_t *data, lbm_uint n, lbm_uint *res) {
663 lbm_uint full_words = n / sizeof(lbm_uint);
664 lbm_uint n_mod = n % sizeof(lbm_uint);
665
666 if (n_mod == 0) { // perfect fit.
667 return lbm_write_const_raw((lbm_uint*)data, full_words, res);
668 } else {
669 lbm_uint last_word = 0;
670 memcpy(&last_word, &data[full_words * sizeof(lbm_uint)], n_mod);
671 if (full_words >= 1) {
672 lbm_flash_status s = lbm_write_const_raw((lbm_uint*)data, full_words, res);
673 if ( s == LBM_FLASH_WRITE_OK) {
674 lbm_uint dummy;
675 s = lbm_write_const_raw(&last_word, 1, &dummy);
676 }
677 return s;
678 } else {
679 return lbm_write_const_raw(&last_word, 1, res);
680 }
681 }
682}
683
684/****************************************************/
685/* Error message creation */
686
687#define ERROR_MESSAGE_BUFFER_SIZE_BYTES256 256
688
689void print_environments(char *buf, unsigned int size) {
690
691 lbm_value curr_l = ctx_running->curr_env;
692 printf_callback("\tCurrent local environment:\n");
693 while (lbm_type_of(curr_l) == LBM_TYPE_CONS0x10000000u) {
694 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_l));
695 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_l)));
696 printf_callback("\t%s = %s\n", buf, buf+(size/2));
697 curr_l = lbm_cdr(curr_l);
698 }
699 printf_callback("\n\n");
700 printf_callback("\tCurrent global environment:\n");
701 lbm_value *glob_env = lbm_get_global_env();
702
703 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
704 lbm_value curr_g = glob_env[i];;
705 while (lbm_type_of(curr_g) == LBM_TYPE_CONS0x10000000u) {
706
707 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_g));
708 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_g)));
709 printf_callback("\t%s = %s\n", buf, buf+(size/2));
710 curr_g = lbm_cdr(curr_g);
711 }
712 }
713}
714
715void print_error_message(lbm_value error, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int col, lbm_int row0, lbm_int row1) {
716 if (!printf_callback) return;
717
718 /* try to allocate a lbm_print_value buffer on the lbm_memory */
719 char *buf = lbm_malloc_reserve(ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
720 if (!buf) {
721 printf_callback("Error: Not enough free memory to create a human readable error message\n");
722 return;
723 }
724
725 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, error);
726 printf_callback( "*** Error: %s\n", buf);
727 if (has_at) {
728 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, at);
729 printf_callback("*** In: %s\n",buf);
730 if (lbm_error_has_suspect) {
731 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, lbm_error_suspect);
732 lbm_error_has_suspect = false0;
733 printf_callback("*** At: %s\n", buf);
734 } else {
735 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
736 printf_callback("*** After: %s\n",buf);
737 }
738 } else {
739 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
740 printf_callback("*** Near: %s\n",buf);
741 }
742
743 printf_callback("\n");
744
745 if (lbm_is_symbol(error) &&
746 error == ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u)) {
747 printf_callback("*** Line: %u\n", row);
748 printf_callback("*** Column: %u\n", col);
749 } else if (row0 != -1 || row1 != -1 ) {
750 printf_callback("*** Between rows: (-1 unknown) \n");
751 printf_callback("*** Start: %d\n", (int32_t)row0);
752 printf_callback("*** End: %d\n", (int32_t)row1);
753 }
754
755 printf_callback("\n");
756
757 if (ctx_running->error_reason) {
758 printf_callback("Reason:\n %s\n\n", ctx_running->error_reason);
759 }
760 if (lbm_verbose) {
761 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
762 printf_callback(" In context: %d\n", ctx_running->id);
763 printf_callback(" Current intermediate result: %s\n\n", buf);
764
765 print_environments(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
766 printf_callback("\n\n");
767
768 printf_callback(" Stack:\n");
769 for (unsigned int i = 0; i < ctx_running->K.sp; i ++) {
770 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->K.data[i]);
771 printf_callback(" %s\n", buf);
772 }
773 }
774 lbm_free(buf);
775}
776
777/****************************************************/
778/* Tokenizing and parsing */
779
780bool_Bool create_string_channel(char *str, lbm_value *res) {
781
782 lbm_char_channel_t *chan = NULL((void*)0);
783 lbm_string_channel_state_t *st = NULL((void*)0);
784
785 st = (lbm_string_channel_state_t*)lbm_memory_allocate(sizeof(lbm_string_channel_state_t) / sizeof(lbm_uint) +1);
786 if (st == NULL((void*)0)) {
25
←
Assuming 'st' is equal to NULL
→
26
←
Taking true branch
→
31
←
Assuming 'st' is equal to NULL
→
32
←
Taking true branch
→
787 return false0;
27
←
Returning without writing to '*res'
→
33
←
Returning without writing to '*res'
→
788 }
789 chan = (lbm_char_channel_t*)lbm_memory_allocate(sizeof(lbm_char_channel_t) / sizeof(lbm_uint) + 1);
790 if (chan == NULL((void*)0)) {
791 lbm_memory_free((lbm_uint*)st);
792 return false0;
793 }
794
795 lbm_create_string_char_channel(st, chan, str);
796 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
797 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
798 lbm_memory_free((lbm_uint*)st);
799 lbm_memory_free((lbm_uint*)chan);
800 return false0;
801 }
802
803 *res = cell;
804 return true1;
805}
806
807bool_Bool lift_char_channel(lbm_char_channel_t *chan , lbm_value *res) {
808 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
809 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
810 return false0;
811 }
812 *res = cell;
813 return true1;
814}
815
816
817/****************************************************/
818/* Queue functions */
819
820static void queue_iterator_nm(eval_context_queue_t *q, ctx_fun f, void *arg1, void *arg2) {
821 eval_context_t *curr;
822 curr = q->first;
823
824 while (curr != NULL((void*)0)) {
825 f(curr, arg1, arg2);
826 curr = curr->next;
827 }
828}
829
830void lbm_running_iterator(ctx_fun f, void *arg1, void *arg2){
831 mutex_lock(&qmutex);
832 queue_iterator_nm(&queue, f, arg1, arg2);
833 mutex_unlock(&qmutex);
834}
835
836void lbm_blocked_iterator(ctx_fun f, void *arg1, void *arg2){
837 mutex_lock(&qmutex);
838 queue_iterator_nm(&blocked, f, arg1, arg2);
839 mutex_unlock(&qmutex);
840}
841
842static void enqueue_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
843 if (q->last == NULL((void*)0)) {
844 ctx->prev = NULL((void*)0);
845 ctx->next = NULL((void*)0);
846 q->first = ctx;
847 q->last = ctx;
848 } else {
849 ctx->prev = q->last;
850 ctx->next = NULL((void*)0);
851 q->last->next = ctx;
852 q->last = ctx;
853 }
854}
855
856static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx) {
857 mutex_lock(&qmutex);
858 enqueue_ctx_nm(q,ctx);
859 mutex_unlock(&qmutex);
860}
861
862static eval_context_t *lookup_ctx_nm(eval_context_queue_t *q, lbm_cid cid) {
863 eval_context_t *curr;
864 curr = q->first;
865 while (curr != NULL((void*)0)) {
866 if (curr->id == cid) {
867 return curr;
868 }
869 curr = curr->next;
870 }
871 return NULL((void*)0);
872}
873
874static bool_Bool drop_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
875
876 bool_Bool res = false0;
877 if (q->first == NULL((void*)0) || q->last == NULL((void*)0)) {
878 if (!(q->last == NULL((void*)0) && q->first == NULL((void*)0))) {
879 /* error state that should not happen */
880 return res;
881 }
882 /* Queue is empty */
883 return res;
884 }
885
886 eval_context_t *curr = q->first;
887 while (curr) {
888 if (curr->id == ctx->id) {
889 res = true1;
890 eval_context_t *tmp = curr->next;
891 if (curr->prev == NULL((void*)0)) {
892 if (curr->next == NULL((void*)0)) {
893 q->last = NULL((void*)0);
894 q->first = NULL((void*)0);
895 } else {
896 q->first = tmp;
897 tmp->prev = NULL((void*)0);
898 }
899 } else { /* curr->prev != NULL */
900 if (curr->next == NULL((void*)0)) {
901 q->last = curr->prev;
902 q->last->next = NULL((void*)0);
903 } else {
904 curr->prev->next = tmp;
905 tmp->prev = curr->prev;
906 }
907 }
908 break;
909 }
910 curr = curr->next;
911 }
912 return res;
913}
914
915/* End execution of the running context. */
916static void finish_ctx(void) {
917
918 if (!ctx_running) {
919 return;
920 }
921 /* Drop the continuation stack immediately to free up lbm_memory */
922 lbm_stack_free(&ctx_running->K);
923 ctx_done_callback(ctx_running);
924 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->name)) {
925 lbm_free(ctx_running->name);
926 }
927 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->error_reason)) {
928 lbm_memory_free((lbm_uint*)ctx_running->error_reason);
929 }
930 lbm_memory_free((lbm_uint*)ctx_running->mailbox);
931 lbm_memory_free((lbm_uint*)ctx_running);
932 ctx_running = NULL((void*)0);
933}
934
935static void context_exists(eval_context_t *ctx, void *cid, void *b) {
936 if (ctx->id == *(lbm_cid*)cid) {
937 *(bool_Bool*)b = true1;
938 }
939}
940
941bool_Bool lbm_wait_ctx(lbm_cid cid, lbm_uint timeout_ms) {
942
943 bool_Bool exists;
944 uint32_t i = 0;
945
946 do {
947 exists = false0;
948 lbm_blocked_iterator(context_exists, &cid, &exists);
949 lbm_running_iterator(context_exists, &cid, &exists);
950
951 if (ctx_running &&
952 ctx_running->id == cid) {
953 exists = true1;
954 }
955
956 if (exists) {
957 if (usleep_callback) {
958 usleep_callback(1000);
959 }
960 if (timeout_ms > 0) i ++;
961 }
962 } while (exists && i < timeout_ms);
963
964 if (exists) return false0;
965 return true1;
966}
967
968void lbm_set_error_suspect(lbm_value suspect) {
969 lbm_error_suspect = suspect;
970 lbm_error_has_suspect = true1;
971}
972
973void lbm_set_error_reason(char *error_str) {
974 if (ctx_running != NULL((void*)0)) {
975 ctx_running->error_reason = error_str;
976 }
977}
978
979// Not possible to CONS_WITH_GC in error_ctx_base (potential loop)
980static void error_ctx_base(lbm_value err_val, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int column) {
981
982 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
983 if (lbm_heap_num_free() < 3) {
984 gc();
985 }
986
987 if (lbm_heap_num_free() >= 3) {
988 lbm_value msg = lbm_cons(err_val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
989 msg = lbm_cons(lbm_enc_i(ctx_running->id), msg);
990 msg = lbm_cons(ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u), msg);
991 if (!lbm_is_symbol_merror(msg)) {
992 lbm_find_receiver_and_send(ctx_running->parent, msg);
993 goto error_ctx_base_done;
994 }
995 }
996 }
997 if ((ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10) &&
998 (err_val != ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u))) {
999 lbm_uint v;
1000 while (ctx_running->K.sp > 0) {
1001 lbm_pop(&ctx_running->K, &v);
1002 if (v == EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u)) {
1003 lbm_value *sptr = get_stack_ptr(ctx_running, 2);
1004 lbm_set_car(sptr[0], ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
1005 stack_reserve(ctx_running, 1)[0] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1006 ctx_running->app_cont = true1;
1007 ctx_running->r = err_val;
1008 longjmp(error_jmp_buf, 1);
1009 }
1010 }
1011 err_val = ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u);
1012 }
1013 print_error_message(err_val,
1014 has_at,
1015 at,
1016 row,
1017 column,
1018 ctx_running->row0,
1019 ctx_running->row1);
1020 error_ctx_base_done:
1021 ctx_running->r = err_val;
1022 finish_ctx();
1023 longjmp(error_jmp_buf, 1);
1024}
1025
1026static void error_at_ctx(lbm_value err_val, lbm_value at) {
1027 error_ctx_base(err_val, true1, at, 0, 0);
1028}
1029
1030static void error_ctx(lbm_value err_val) {
1031 error_ctx_base(err_val, false0, 0, 0, 0);
1032}
1033
1034static void read_error_ctx(unsigned int row, unsigned int column) {
1035 error_ctx_base(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u), false0, 0, row, column);
1036}
1037
1038void lbm_critical_error(void) {
1039 longjmp(critical_error_jmp_buf, 1);
1040}
1041
1042// successfully finish a context
1043static void ok_ctx(void) {
1044 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
1045 lbm_value msg;
1046 WITH_GC(msg, lbm_heap_allocate_list_init(3,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1047 ENC_SYM_EXIT_OK,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1048 lbm_enc_i(ctx_running->id),(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1049 ctx_running->r))(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
1050 lbm_find_receiver_and_send(ctx_running->parent, msg);
1051 }
1052 finish_ctx();
1053}
1054
1055static eval_context_t *dequeue_ctx_nm(eval_context_queue_t *q) {
1056 if (q->last == NULL((void*)0)) {
1057 return NULL((void*)0);
1058 }
1059 // q->first should only be NULL if q->last is.
1060 eval_context_t *res = q->first;
1061
1062 if (q->first == q->last) { // One thing in queue
1063 q->first = NULL((void*)0);
1064 q->last = NULL((void*)0);
1065 } else {
1066 q->first = q->first->next;
1067 q->first->prev = NULL((void*)0);
1068 }
1069 res->prev = NULL((void*)0);
1070 res->next = NULL((void*)0);
1071 return res;
1072}
1073
1074static void wake_up_ctxs_nm(void) {
1075 lbm_uint t_now;
1076
1077 if (timestamp_us_callback) {
1078 t_now = timestamp_us_callback();
1079 } else {
1080 t_now = 0;
1081 }
1082
1083 eval_context_queue_t *q = &blocked;
1084 eval_context_t *curr = q->first;
1085
1086 while (curr != NULL((void*)0)) {
1087 lbm_uint t_diff;
1088 eval_context_t *next = curr->next;
1089 if (curr->state != LBM_THREAD_STATE_BLOCKED(uint32_t)1) {
1090 if ( curr->timestamp > t_now) {
1091 /* There was an overflow on the counter */
1092#ifndef LBM64
1093 t_diff = (0xFFFFFFFF - curr->timestamp) + t_now;
1094#else
1095 t_diff = (0xFFFFFFFFFFFFFFFF - curr->timestamp) + t_now;
1096#endif
1097 } else {
1098 t_diff = t_now - curr->timestamp;
1099 }
1100
1101 if (t_diff >= curr->sleep_us) {
1102 eval_context_t *wake_ctx = curr;
1103 if (curr == q->last) {
1104 if (curr->prev) {
1105 q->last = curr->prev;
1106 q->last->next = NULL((void*)0);
1107 } else {
1108 q->first = NULL((void*)0);
1109 q->last = NULL((void*)0);
1110 }
1111 } else if (curr->prev == NULL((void*)0)) {
1112 q->first = curr->next;
1113 q->first->prev = NULL((void*)0);
1114 } else {
1115 curr->prev->next = curr->next;
1116 if (curr->next) {
1117 curr->next->prev = curr->prev;
1118 }
1119 }
1120 wake_ctx->next = NULL((void*)0);
1121 wake_ctx->prev = NULL((void*)0);
1122 if (curr->state == LBM_THREAD_STATE_TIMEOUT(uint32_t)2) {
1123 mailbox_add_mail(wake_ctx, ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u));
1124 wake_ctx->r = ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u);
1125 }
1126 wake_ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1127 enqueue_ctx_nm(&queue, wake_ctx);
1128 }
1129 }
1130 curr = next;
1131 }
1132}
1133
1134static void yield_ctx(lbm_uint sleep_us) {
1135 if (timestamp_us_callback) {
1136 ctx_running->timestamp = timestamp_us_callback();
1137 ctx_running->sleep_us = sleep_us;
1138 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1139 } else {
1140 ctx_running->timestamp = 0;
1141 ctx_running->sleep_us = 0;
1142 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1143 }
1144 ctx_running->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1145 ctx_running->app_cont = true1;
1146 enqueue_ctx(&blocked,ctx_running);
1147 ctx_running = NULL((void*)0);
1148}
1149
1150static lbm_cid lbm_create_ctx_parent(lbm_value program, lbm_value env, lbm_uint stack_size, lbm_cid parent, uint32_t context_flags, char *name) {
1151
1152 if (!lbm_is_cons(program)) return -1;
1153
1154 eval_context_t *ctx = NULL((void*)0);
1155
1156 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1157 if (ctx == NULL((void*)0)) {
1158 lbm_uint roots[2] = {program, env};
1159 lbm_gc_mark_roots(roots, 2);
1160 gc();
1161 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1162 }
1163 if (ctx == NULL((void*)0)) return -1;
1164
1165 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1166 lbm_uint roots[2] = {program, env};
1167 lbm_gc_mark_roots(roots, 2);
1168 gc();
1169 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1170 lbm_memory_free((lbm_uint*)ctx);
1171 return -1;
1172 }
1173 }
1174
1175 lbm_value *mailbox = NULL((void*)0);
1176 mailbox = (lbm_value*)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1177 if (mailbox == NULL((void*)0)) {
1178 lbm_value roots[2] = {program, env};
1179 lbm_gc_mark_roots(roots,2);
1180 gc();
1181 mailbox = (lbm_value *)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1182 }
1183 if (mailbox == NULL((void*)0)) {
1184 lbm_stack_free(&ctx->K);
1185 lbm_memory_free((lbm_uint*)ctx);
1186 return -1;
1187 }
1188
1189 // TODO: Limit names to 19 chars + 1 char for 0? (or something similar).
1190 if (name) {
1191 lbm_uint name_len = strlen(name) + 1;
1192 ctx->name = lbm_malloc(strlen(name) + 1);
1193 if (ctx->name == NULL((void*)0)) {
1194 lbm_value roots[2] = {program, env};
1195 lbm_gc_mark_roots(roots, 2);
1196 gc();
1197 ctx->name = lbm_malloc(strlen(name) + 1);
1198 }
1199 if (ctx->name == NULL((void*)0)) {
1200 lbm_stack_free(&ctx->K);
1201 lbm_memory_free((lbm_uint*)mailbox);
1202 lbm_memory_free((lbm_uint*)ctx);
1203 return -1;
1204 }
1205 memcpy(ctx->name, name, name_len+1);
1206 } else {
1207 ctx->name = NULL((void*)0);
1208 }
1209
1210 lbm_int cid = lbm_memory_address_to_ix((lbm_uint*)ctx);
1211
1212 ctx->program = lbm_cdr(program);
1213 ctx->curr_exp = lbm_car(program);
1214 ctx->curr_env = env;
1215 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1216 ctx->error_reason = NULL((void*)0);
1217 ctx->mailbox = mailbox;
1218 ctx->mailbox_size = EVAL_CPS_DEFAULT_MAILBOX_SIZE10;
1219 ctx->flags = context_flags;
1220 ctx->num_mail = 0;
1221 ctx->app_cont = false0;
1222 ctx->timestamp = 0;
1223 ctx->sleep_us = 0;
1224 ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1225 ctx->prev = NULL((void*)0);
1226 ctx->next = NULL((void*)0);
1227
1228 ctx->row0 = -1;
1229 ctx->row1 = -1;
1230
1231 ctx->id = cid;
1232 ctx->parent = parent;
1233
1234 if (!lbm_push(&ctx->K, DONE(((0) << 2) | 0xF8000001u))) {
1235 lbm_memory_free((lbm_uint*)ctx->mailbox);
1236 lbm_stack_free(&ctx->K);
1237 lbm_memory_free((lbm_uint*)ctx);
1238 return -1;
1239 }
1240
1241 enqueue_ctx(&queue,ctx);
1242
1243 return ctx->id;
1244}
1245
1246lbm_cid lbm_create_ctx(lbm_value program, lbm_value env, lbm_uint stack_size, char *name) {
1247 // Creates a parentless context.
1248 return lbm_create_ctx_parent(program,
1249 env,
1250 stack_size,
1251 -1,
1252 EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00,
1253 name);
1254}
1255
1256bool_Bool lbm_mailbox_change_size(eval_context_t *ctx, lbm_uint new_size) {
1257
1258 lbm_value *mailbox = NULL((void*)0);
1259 mailbox = (lbm_value*)lbm_memory_allocate(new_size);
1260 if (mailbox == NULL((void*)0)) {
1261 gc();
1262 mailbox = (lbm_value *)lbm_memory_allocate(new_size);
1263 }
1264 if (mailbox == NULL((void*)0)) {
1265 return false0;
1266 }
1267
1268 for (lbm_uint i = 0; i < ctx->num_mail; i ++ ) {
1269 mailbox[i] = ctx->mailbox[i];
1270 }
1271 lbm_memory_free(ctx->mailbox);
1272 ctx->mailbox = mailbox;
1273 ctx->mailbox_size = (uint32_t)new_size;
1274 return true1;
1275}
1276
1277static void mailbox_remove_mail(eval_context_t *ctx, lbm_uint ix) {
1278
1279 for (lbm_uint i = ix; i < ctx->num_mail-1; i ++) {
1280 ctx->mailbox[i] = ctx->mailbox[i+1];
1281 }
1282 ctx->num_mail --;
1283}
1284
1285static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail) {
1286
1287 if (ctx->num_mail >= ctx->mailbox_size) {
1288 mailbox_remove_mail(ctx, 0);
1289 }
1290
1291 ctx->mailbox[ctx->num_mail] = mail;
1292 ctx->num_mail ++;
1293 return true1;
1294}
1295
1296/* Advance execution to the next expression in the program */
1297static void advance_ctx(eval_context_t *ctx) {
1298 if (lbm_is_cons(ctx->program)) {
1299 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);;
1300 get_car_and_cdr(ctx->program, &ctx->curr_exp, &ctx->program);
1301 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1302 } else {
1303 if (ctx_running == ctx) { // This should always be the case because of odd historical reasons.
1304 ok_ctx();
1305 }
1306 }
1307}
1308
1309bool_Bool lbm_unblock_ctx(lbm_cid cid, lbm_flat_value_t *fv) {
1310 return event_internal(LBM_EVENT_UNBLOCK_CTX, (lbm_uint)cid, (lbm_uint)fv->buf, fv->buf_size);
1311}
1312
1313bool_Bool lbm_unblock_ctx_r(lbm_cid cid) {
1314 mutex_lock(&blocking_extension_mutex);
1315 bool_Bool r = false0;
1316 eval_context_t *found = NULL((void*)0);
1317 mutex_lock(&qmutex);
1318 found = lookup_ctx_nm(&blocked, cid);
1319 if (found) {
1320 drop_ctx_nm(&blocked,found);
1321 enqueue_ctx_nm(&queue,found);
1322 r = true1;
1323 }
1324 mutex_unlock(&qmutex);
1325 mutex_unlock(&blocking_extension_mutex);
1326 return r;
1327}
1328
1329// unblock unboxed is also safe for rmbr:ed things.
1330bool_Bool lbm_unblock_ctx_unboxed(lbm_cid cid, lbm_value unboxed) {
1331 mutex_lock(&blocking_extension_mutex);
1332 bool_Bool r = false0;
1333 eval_context_t *found = NULL((void*)0);
1334 mutex_lock(&qmutex);
1335 found = lookup_ctx_nm(&blocked, cid);
1336 if (found) {
1337 drop_ctx_nm(&blocked,found);
1338 found->r = unboxed;
1339 if (lbm_is_error(unboxed)) {
1340 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
1341 found->app_cont = true1;
1342 }
1343 enqueue_ctx_nm(&queue,found);
1344 r = true1;
1345 }
1346 mutex_unlock(&qmutex);
1347 mutex_unlock(&blocking_extension_mutex);
1348 return r;
1349}
1350
1351static bool_Bool lbm_block_ctx_base(bool_Bool timeout, float t_s) {
1352 mutex_lock(&blocking_extension_mutex);
1353 blocking_extension = true1;
1354 if (timeout) {
1355 blocking_extension_timeout_us = S_TO_US(t_s)(lbm_uint)((t_s) * 1000000);
1356 blocking_extension_timeout = true1;
1357 } else {
1358 blocking_extension_timeout = false0;
1359 }
1360 return true1;
1361}
1362
1363void lbm_block_ctx_from_extension_timeout(float s) {
1364 lbm_block_ctx_base(true1, s);
1365}
1366
1367void lbm_block_ctx_from_extension(void) {
1368 lbm_block_ctx_base(false0, 0);
1369}
1370
1371// todo: May need to pop rmbrs from stack, if present.
1372// Suspect that the letting the discard cont run is really not a problem.
1373// Either way will be quite confusing what happens to allocated things when undoing block.
1374void lbm_undo_block_ctx_from_extension(void) {
1375 blocking_extension = false0;
1376 blocking_extension_timeout_us = 0;
1377 blocking_extension_timeout = false0;
1378 mutex_unlock(&blocking_extension_mutex);
1379}
1380
1381lbm_value lbm_find_receiver_and_send(lbm_cid cid, lbm_value msg) {
1382 mutex_lock(&qmutex);
1383 eval_context_t *found = NULL((void*)0);
1384 bool_Bool found_blocked = false0;
1385
1386 found = lookup_ctx_nm(&blocked, cid);
1387 if (found) found_blocked = true1;
1388
1389 if (found == NULL((void*)0)) {
1390 found = lookup_ctx_nm(&queue, cid);
1391 }
1392
1393 if (found) {
1394 if (!mailbox_add_mail(found, msg)) {
1395 mutex_unlock(&qmutex);
1396 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1397 }
1398
1399 if (found_blocked){
1400 drop_ctx_nm(&blocked,found);
1401 enqueue_ctx_nm(&queue,found);
1402 }
1403 mutex_unlock(&qmutex);
1404 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1405 }
1406
1407 /* check the current context */
1408 if (ctx_running && ctx_running->id == cid) {
1409 if (!mailbox_add_mail(ctx_running, msg)) {
1410 mutex_unlock(&qmutex);
1411 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1412 }
1413 mutex_unlock(&qmutex);
1414 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1415 }
1416 mutex_unlock(&qmutex);
1417 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1418}
1419
1420/* Pattern matching is currently implemented as a recursive
1421 function and make use of stack relative to the size of
1422 expressions that are being matched. */
1423static bool_Bool match(lbm_value p, lbm_value e, lbm_value *env, bool_Bool *gc) {
1424
1425 lbm_value binding;
1426
1427 if (lbm_is_match_binder(p)) {
1428 lbm_value var = get_cadr(p);
1429 lbm_value bindertype = get_car(p);
1430
1431 if (!lbm_is_symbol(var)) return false0;
1432
1433 switch (bindertype) {
1434 case ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u):
1435 if ( var == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) {
1436 return true1;
1437 }
1438 break;
1439 default: /* this should be an error case */
1440 return false0;
1441 }
1442 binding = lbm_cons(var, e);
1443 if ( lbm_type_of(binding) == LBM_TYPE_SYMBOL0x00000000u ) {
1444 *gc = true1;
1445 return false0;
1446 }
1447 *env = lbm_cons(binding, *env);
1448 if ( lbm_type_of(*env) == LBM_TYPE_SYMBOL0x00000000u ) {
1449 *gc = true1;
1450 return false0;
1451 }
1452 return true1;
1453 }
1454
1455 if (lbm_is_symbol(p)) {
1456 if (p == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return true1;
1457 return (p == e);
1458 }
1459 if (lbm_is_cons(p) &&
1460 lbm_is_cons(e) ) {
1461
1462 lbm_value headp, tailp;
1463 lbm_value heade, taile;
1464 get_car_and_cdr(p, &headp, &tailp);
1465 get_car_and_cdr(e, &heade, &taile); // Static analysis warns, but execution does not
1466 // past this point unless head and tail get initialized.
1467 if (!match(headp, heade, env, gc)) {
1468 return false0;
1469 }
1470 return match (tailp, taile, env, gc);
1471 }
1472 return struct_eq(p, e);
1473}
1474
1475// Find match is not very picky about syntax.
1476// A completely malformed recv form is most likely to
1477// just return no_match.
1478static int find_match(lbm_value plist, lbm_value *earr, lbm_uint num, lbm_value *e, lbm_value *env) {
1479
1480 // A pattern list is a list of pattern, expression lists.
1481 // ( (p1 e1) (p2 e2) ... (pn en))
1482 lbm_value curr_p = plist;
1483 int n = 0;
1484 bool_Bool gc = false0;
1485 for (int i = 0; i < (int)num; i ++ ) {
1486 lbm_value curr_e = earr[i];
1487 while (!lbm_is_symbol_nil(curr_p)) {
1488 lbm_value me = get_car(curr_p);
1489 if (match(get_car(me), curr_e, env, &gc)) {
1490 if (gc) return FM_NEED_GC-1;
1491 *e = get_cadr(me);
1492
1493 if (!lbm_is_symbol_nil(get_cadr(get_cdr(me)))) {
1494 return FM_PATTERN_ERROR-3;
1495 }
1496 return n;
1497 }
1498 curr_p = get_cdr(curr_p);
1499 }
1500 curr_p = plist; /* search all patterns against next exp */
1501 n ++;
1502 }
1503
1504 return FM_NO_MATCH-2;
1505}
1506
1507/****************************************************/
1508/* Garbage collection */
1509
1510static void mark_context(eval_context_t *ctx, void *arg1, void *arg2) {
1511 (void) arg1;
1512 (void) arg2;
1513 lbm_value roots[3] = {ctx->curr_exp, ctx->program, ctx->r };
1514 lbm_gc_mark_env(ctx->curr_env);
1515 lbm_gc_mark_roots(roots, 3);
1516 lbm_gc_mark_roots(ctx->mailbox, ctx->num_mail);
1517 lbm_gc_mark_aux(ctx->K.data, ctx->K.sp);
1518}
1519
1520static int gc(void) {
1521 if (ctx_running) {
1522 ctx_running->state = ctx_running->state | LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1523 }
1524
1525 gc_requested = false0;
1526 lbm_gc_state_inc();
1527
1528 // The freelist should generally be NIL when GC runs.
1529 lbm_nil_freelist();
1530 lbm_value *env = lbm_get_global_env();
1531 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
1532 lbm_gc_mark_env(env[i]);
1533 }
1534
1535 mutex_lock(&qmutex); // Lock the queues.
1536 // Any concurrent messing with the queues
1537 // while doing GC cannot possibly be good.
1538 queue_iterator_nm(&queue, mark_context, NULL((void*)0), NULL((void*)0));
1539 queue_iterator_nm(&blocked, mark_context, NULL((void*)0), NULL((void*)0));
1540
1541 if (ctx_running) {
1542 mark_context(ctx_running, NULL((void*)0), NULL((void*)0));
1543 }
1544 mutex_unlock(&qmutex);
1545
1546#ifdef VISUALIZE_HEAP
1547 heap_vis_gen_image();
1548#endif
1549
1550 int r = lbm_gc_sweep_phase();
1551 lbm_heap_new_freelist_length();
1552
1553 if (ctx_running) {
1554 ctx_running->state = ctx_running->state & ~LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1555 }
1556 return r;
1557}
1558
1559int lbm_perform_gc(void) {
1560 return gc();
1561}
1562
1563/****************************************************/
1564/* Evaluation functions */
1565
1566
1567static void eval_symbol(eval_context_t *ctx) {
1568 lbm_uint s = lbm_dec_sym(ctx->curr_exp);
1569 if (s >= RUNTIME_SYMBOLS_START0x40000) {
16
←
Assuming 's' is >= RUNTIME_SYMBOLS_START
→
17
←
Taking true branch
→
1570 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1571 if (lbm_env_lookup_b(&res, ctx->curr_exp, ctx->curr_env) ||
18
←
Assuming the condition is false
→
20
←
Taking false branch
→
1572 lbm_global_env_lookup(&res, ctx->curr_exp)) {
19
←
Assuming the condition is false
→
1573 ctx->r = res;
1574 ctx->app_cont = true1;
1575 return;
1576 }
1577 // Dynamic load attempt
1578 // Only symbols of kind RUNTIME can be dynamically loaded.
1579 const char *sym_str = lbm_get_name_by_symbol(s);
1580 const char *code_str = NULL((void*)0);
1581 if (!dynamic_load_callback(sym_str, &code_str)) {
21
←
Assuming the condition is false
→
22
←
Taking false branch
→
1582 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), ctx->curr_exp);
1583 }
1584 lbm_value *sptr = stack_reserve(ctx, 3);
1585 sptr[0] = ctx->curr_exp;
1586 sptr[1] = ctx->curr_env;
1587 sptr[2] = RESUME(((12) << 2) | 0xF8000001u);
1588
1589 lbm_value chan;
23
←
'chan' declared without an initial value
→
1590 if (!create_string_channel((char *)code_str, &chan)) {
24
←
Calling 'create_string_channel'
→
28
←
Returning from 'create_string_channel'
→
29
←
Taking true branch
→
1591 gc();
1592 if (!create_string_channel((char *)code_str, &chan)) {
30
←
Calling 'create_string_channel'
→
34
←
Returning from 'create_string_channel'
→
35
←
Taking true branch
→
1593 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1594 }
1595 }
1596
1597 lbm_value loader;
1598 WITH_GC_RMBR_1(loader, lbm_heap_allocate_list_init(2,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
36
←
3rd function call argument is an uninitialized value
1599 ENC_SYM_READ,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1600 chan), chan)(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} };
1601 lbm_value evaluator;
1602 WITH_GC_RMBR_1(evaluator, lbm_heap_allocate_list_init(2,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1603 ENC_SYM_EVAL,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1604 loader), loader)(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } };
1605 ctx->curr_exp = evaluator;
1606 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // dynamics should be evaluable in empty local env
1607 } else {
1608 //special symbols and extensions can be handled the same way.
1609 ctx->r = ctx->curr_exp;
1610 ctx->app_cont = true1;
1611 }
1612}
1613
1614static void eval_quote(eval_context_t *ctx) {
1615 ctx->r = get_cadr(ctx->curr_exp);
1616 ctx->app_cont = true1;
1617}
1618
1619static void eval_selfevaluating(eval_context_t *ctx) {
1620 ctx->r = ctx->curr_exp;
1621 ctx->app_cont = true1;
1622}
1623
1624static void eval_progn(eval_context_t *ctx) {
1625 lbm_value exps = get_cdr(ctx->curr_exp);
1626
1627 if (lbm_is_cons(exps)) {
1628 lbm_uint *sptr = stack_reserve(ctx, 4);
1629 sptr[0] = ctx->curr_env; // env to restore between expressions in progn
1630 sptr[1] = lbm_enc_u(0); // Has env been copied (needed for progn local bindings)
1631 sptr[3] = PROGN_REST(((4) << 2) | 0xF8000001u);
1632 get_car_and_cdr(exps, &ctx->curr_exp, &sptr[2]);
1633 if (lbm_is_symbol(sptr[2])) /* The only symbol it can be is nil */
1634 lbm_stack_drop(&ctx->K, 4);
1635 } else if (lbm_is_symbol_nil(exps)) {
1636 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1637 ctx->app_cont = true1;
1638 } else {
1639 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1640 }
1641}
1642
1643static void eval_atomic(eval_context_t *ctx) {
1644 if (is_atomic) {
1645 lbm_set_error_reason("Atomic blocks cannot be nested!");
1646 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1647 }
1648 stack_reserve(ctx, 1)[0] = EXIT_ATOMIC(((14) << 2) | 0xF8000001u);
1649 is_atomic ++;
1650 eval_progn(ctx);
1651}
1652
1653/* (call-cc (lambda (k) .... )) */
1654static void eval_callcc(eval_context_t *ctx) {
1655 lbm_value cont_array;
1656 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1657 gc();
1658 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1659 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1660 return; // dead return but static analysis doesn't know :)
1661 }
1662 }
1663 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(cont_array);
1664 memcpy(arr->data, ctx->K.data, ctx->K.sp * sizeof(lbm_uint));
1665
1666 lbm_value acont = cons_with_gc(ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u), cont_array, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1667 lbm_value arg_list = cons_with_gc(acont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1668 // Go directly into application evaluation without passing go
1669 lbm_uint *sptr = stack_reserve(ctx, 3);
1670 sptr[0] = ctx->curr_env;
1671 sptr[1] = arg_list;
1672 sptr[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
1673 ctx->curr_exp = get_cadr(ctx->curr_exp);
1674}
1675
1676// (define sym exp)
1677#define KEY1 1
1678#define VAL2 2
1679static void eval_define(eval_context_t *ctx) {
1680 lbm_value parts[3];
1681 lbm_value rest = extract_n(ctx->curr_exp, parts, 3);
1682 lbm_uint *sptr = stack_reserve(ctx, 2);
1683 if (lbm_is_symbol(parts[KEY1]) && lbm_is_symbol_nil(rest)) {
1684 lbm_uint sym_val = lbm_dec_sym(parts[KEY1]);
1685 sptr[0] = parts[KEY1];
1686 if (sym_val >= RUNTIME_SYMBOLS_START0x40000) {
1687 sptr[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
1688 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02) {
1689 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
1690 }
1691 ctx->curr_exp = parts[VAL2];
1692 return;
1693 }
1694 }
1695 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
1696}
1697
1698
1699/* Eval lambda is cheating, a lot! It does this
1700 for performance reasons. The cheats are that
1701 1. When closure is created, a reference to the local env
1702 in which the lambda was evaluated is added to the closure.
1703 Ideally it should have created a list of free variables in the function
1704 and then looked up the values of these creating a new environment.
1705 2. The global env is considered global constant. As there is no copying
1706 of environment bindings into the closure, undefine may break closures.
1707
1708 Correct closure creation is a lot more expensive than what happens here.
1709 However, one can try to write programs in such a way that closures are created
1710 seldomly. If one does that the space-usage benefits of "correct" closures
1711 may outweigh the performance gain of "incorrect" ones.
1712
1713 some obscure programs such as test_setq_local_closure.lisp does not
1714 work properly due to this cheating.
1715 */
1716// (lambda param-list body-exp) -> (closure param-list body-exp env)
1717static void eval_lambda(eval_context_t *ctx) {
1718 lbm_value vals[3];
1719 extract_n(ctx->curr_exp, vals, 3);
1720 ctx->r = allocate_closure(vals[1],vals[2], ctx->curr_env);
1721#ifdef CLEAN_UP_CLOSURES
1722 lbm_uint sym_id = 0;
1723 if (clean_cl_env_symbol) {
1724 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1725 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1726 ctx->curr_exp = app;
1727 } else if (lbm_get_symbol_by_name("clean-cl-env", &sym_id)) {
1728 clean_cl_env_symbol = lbm_enc_sym(sym_id);
1729 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1730 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1731 ctx->curr_exp = app;
1732 } else {
1733 ctx->app_cont = true1;
1734 }
1735#else
1736 ctx->app_cont = true1;
1737#endif
1738}
1739
1740// (if cond-expr then-expr else-expr)
1741static void eval_if(eval_context_t *ctx) {
1742 lbm_value cdr = get_cdr(ctx->curr_exp);
1743 lbm_value *sptr = stack_reserve(ctx, 3);
1744 sptr[0] = get_cdr(cdr);
1745 sptr[1] = ctx->curr_env;
1746 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1747 ctx->curr_exp = get_car(cdr);
1748}
1749
1750// (cond (cond-expr-1 expr-1)
1751// ...
1752// (cond-expr-N expr-N))
1753static void eval_cond(eval_context_t *ctx) {
1754 lbm_value cond1[2];
1755 lbm_value rest_conds = extract_n(ctx->curr_exp, cond1, 2);
1756
1757 // end recursion at (cond )
1758 if (lbm_is_symbol_nil(cond1[1])) {
1759 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1760 ctx->app_cont = true1;
1761 } else {
1762 // Cond is one of the few places where a bit of syntax checking takes place at runtime..
1763 // Maybe dont bother?
1764 lbm_uint len = lbm_list_length(cond1[1]);
1765 if (len != 2) {
1766 lbm_set_error_reason("Incorrect syntax in cond");
1767 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1768 }
1769 lbm_value cond_expr[2];
1770 extract_n(cond1[1], cond_expr, 2);
1771 lbm_value rest;
1772 WITH_GC(rest, lbm_heap_allocate_list_init(2,(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1773 cond_expr[1], // Then branch(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1774 cons_with_gc(ENC_SYM_COND, rest_conds , ENC_SYM_NIL)))(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
1775 lbm_value *sptr = stack_reserve(ctx, 3);
1776 sptr[0] = rest;
1777 sptr[1] = ctx->curr_env;
1778 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1779 ctx->curr_exp = cond_expr[0]; //condition;
1780 }
1781}
1782
1783static void eval_app_cont(eval_context_t *ctx) {
1784 lbm_stack_drop(&ctx->K, 1);
1785 ctx->app_cont = true1;
1786}
1787
1788// Create a named location in an environment to later receive a value.
1789static binding_location_status create_binding_location_internal(lbm_value key, lbm_value *env) {
1790
1791 if (lbm_is_symbol(key) &&
1792 (key == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u) ||
1793 key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)))
1794 return BL_OK;
1795
1796 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) { // default case
1797 lbm_value binding;
1798 lbm_value new_env_tmp;
1799 binding = lbm_cons(key, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1800 new_env_tmp = lbm_cons(binding, *env);
1801 if (lbm_is_symbol(binding) || lbm_is_symbol(new_env_tmp)) {
1802 return BL_NO_MEMORY;
1803 }
1804 *env = new_env_tmp;
1805 } else if (lbm_is_cons(key)) { // deconstruct case
1806 int r = create_binding_location_internal(get_car(key), env);
1807 if (r == BL_OK) {
1808 r = create_binding_location_internal(get_cdr(key), env);
1809 }
1810 return r;
1811 }
1812 return BL_OK;
1813}
1814
1815static void create_binding_location(lbm_value key, lbm_value *env) {
1816
1817 lbm_value env_tmp = *env;
1818 binding_location_status r = create_binding_location_internal(key, &env_tmp);
1819 if (r != BL_OK) {
1820 if (r == BL_NO_MEMORY) {
1821 env_tmp = *env;
1822 lbm_gc_mark_phase(env_tmp);
1823 gc();
1824 r = create_binding_location_internal(key, &env_tmp);
1825 }
1826 switch(r) {
1827 case BL_OK:
1828 break;
1829 case BL_NO_MEMORY:
1830 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1831 break;
1832 case BL_INCORRECT_KEY:
1833 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
1834 break;
1835 }
1836 }
1837 *env = env_tmp;
1838}
1839
1840static void let_bind_values_eval(lbm_value binds, lbm_value exp, lbm_value env, eval_context_t *ctx) {
1841
1842 if (!lbm_is_cons(binds)) {
1843 // binds better be nil or there is a programmer error.
1844 ctx->curr_exp = exp;
1845 return;
1846 }
1847
1848 // Preallocate binding locations.
1849 lbm_value curr = binds;
1850 while (lbm_is_cons(curr)) {
1851 lbm_value new_env_tmp = env;
1852 lbm_value car_curr, cdr_curr;
1853 get_car_and_cdr(curr, &car_curr, &cdr_curr);
1854 lbm_value key = get_car(car_curr);
1855 create_binding_location(key, &new_env_tmp);
1856 env = new_env_tmp;
1857 curr = cdr_curr;
1858 }
1859
1860 lbm_value car_binds;
1861 lbm_value cdr_binds;
1862 get_car_and_cdr(binds, &car_binds, &cdr_binds);
1863 lbm_value key_val[2];
1864 extract_n(car_binds, key_val, 2);
1865
1866 lbm_uint *sptr = stack_reserve(ctx, 5);
1867 sptr[0] = exp;
1868 sptr[1] = cdr_binds;
1869 sptr[2] = env;
1870 sptr[3] = key_val[0];
1871 sptr[4] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
1872 ctx->curr_exp = key_val[1];
1873 ctx->curr_env = env;
1874}
1875
1876// (var x (...)) - local binding inside of an progn
1877// var has to take, place root-level nesting within progn.
1878// (progn ... (var a 10) ...) OK!
1879// (progn ... (something (var a 10)) ... ) NOT OK!
1880/* progn stack
1881 sp-4 : env
1882 sp-3 : 0
1883 sp-2 : rest
1884 sp-1 : PROGN_REST
1885*/
1886static void eval_var(eval_context_t *ctx) {
1887
1888 if (ctx->K.sp >= 4) { // Possibly in progn
1889 lbm_value sv = ctx->K.data[ctx->K.sp - 1];
1890 if (IS_CONTINUATION(sv)(((sv) & 0xF8000001u) == 0xF8000001u) && (sv == PROGN_REST(((4) << 2) | 0xF8000001u))) {
1891 lbm_uint sp = ctx->K.sp;
1892 uint32_t is_copied = lbm_dec_as_u32(ctx->K.data[sp-3]);
1893 if (is_copied == 0) {
1894 lbm_value env;
1895 WITH_GC(env, lbm_env_copy_spine(ctx->K.data[sp-4]))(env) = (lbm_env_copy_spine(ctx->K.data[sp-4])); if (lbm_is_symbol_merror
((env))) { gc(); (env) = (lbm_env_copy_spine(ctx->K.data[sp
-4])); if (lbm_is_symbol_merror((env))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1896 ctx->K.data[sp-3] = lbm_enc_u(1);
1897 ctx->K.data[sp-4] = env;
1898 }
1899 lbm_value new_env = ctx->K.data[sp-4];
1900 lbm_value args = get_cdr(ctx->curr_exp);
1901 lbm_value key = get_car(args);
1902 create_binding_location(key, &new_env);
1903 ctx->K.data[sp-4] = new_env;
1904
1905 lbm_value v_exp = get_cadr(args);
1906 lbm_value *sptr = stack_reserve(ctx, 3);
1907 sptr[0] = new_env;
1908 sptr[1] = key;
1909 sptr[2] = PROGN_VAR(((29) << 2) | 0xF8000001u);
1910 // Activating the new environment before the evaluation of the value to be bound,
1911 // means that other variables with same name will be shadowed already in the value
1912 // body.
1913 // The way closures work, the var-variable needs to be in scope during val evaluation
1914 // for a recursive closure to be possible.
1915 ctx->curr_env = new_env;
1916 ctx->curr_exp = v_exp;
1917 return;
1918 }
1919 }
1920 lbm_set_error_reason((char*)lbm_error_str_var_outside_progn);
1921 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1922}
1923
1924// (setq x (...)) - same as (set 'x (...)) or (setvar 'x (...))
1925static void eval_setq(eval_context_t *ctx) {
1926 lbm_value parts[3];
1927 extract_n(ctx->curr_exp, parts, 3);
1928 lbm_value *sptr = stack_reserve(ctx, 3);
1929 sptr[0] = ctx->curr_env;
1930 sptr[1] = parts[1];
1931 sptr[2] = SETQ(((30) << 2) | 0xF8000001u);
1932 ctx->curr_exp = parts[2];
1933}
1934
1935static void eval_move_to_flash(eval_context_t *ctx) {
1936 lbm_value args = get_cdr(ctx->curr_exp);
1937 lbm_value *sptr = stack_reserve(ctx,2);
1938 sptr[0] = args;
1939 sptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
1940 ctx->app_cont = true1;
1941}
1942
1943// (loop list-of-local-bindings
1944// condition-exp
1945// body-exp)
1946static void eval_loop(eval_context_t *ctx) {
1947 lbm_value env = ctx->curr_env;
1948 lbm_value parts[3];
1949 extract_n(get_cdr(ctx->curr_exp), parts, 3);
1950 lbm_value *sptr = stack_reserve(ctx, 3);
1951 sptr[0] = parts[LOOP_BODY2];
1952 sptr[1] = parts[LOOP_COND1];
1953 sptr[2] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
1954 let_bind_values_eval(parts[LOOP_BINDS0], parts[LOOP_COND1], env, ctx);
1955}
1956
1957/* (trap expression)
1958 *
1959 * suggested use:
1960 * (match (trap expression)
1961 * ((exit-error (? err)) (error-handler err))
1962 * ((exit-ok (? v)) (value-handler v)))
1963 */
1964static void eval_trap(eval_context_t *ctx) {
1965
1966 lbm_value expr = get_cadr(ctx->curr_exp);
1967 lbm_value retval;
1968 WITH_GC(retval, lbm_heap_allocate_list(2))(retval) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((retval))) { gc(); (retval) = (lbm_heap_allocate_list(2)); if
(lbm_is_symbol_merror((retval))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1969 lbm_set_car(retval, ENC_SYM_EXIT_OK(((0x3000B) << 4) | 0x00000000u)); // Assume things will go well.
1970 lbm_uint *sptr = stack_reserve(ctx,3);
1971 sptr[0] = retval;
1972 sptr[1] = ctx->flags;
1973 sptr[2] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1974 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10;
1975 ctx->curr_exp = expr;
1976}
1977
1978// (let list-of-binding s
1979// body-exp)
1980static void eval_let(eval_context_t *ctx) {
1981 lbm_value env = ctx->curr_env;
1982 lbm_value parts[3];
1983 extract_n(ctx->curr_exp, parts, 3);
1984 let_bind_values_eval(parts[1], parts[2], env, ctx);
1985}
1986
1987// (and exp0 ... expN)
1988static void eval_and(eval_context_t *ctx) {
1989 lbm_value rest = get_cdr(ctx->curr_exp);
1990 if (lbm_is_symbol_nil(rest)) {
1991 ctx->app_cont = true1;
1992 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1993 } else {
1994 lbm_value *sptr = stack_reserve(ctx, 3);
1995 sptr[0] = ctx->curr_env;
1996 sptr[1] = get_cdr(rest);
1997 sptr[2] = AND(((6) << 2) | 0xF8000001u);
1998 ctx->curr_exp = get_car(rest);
1999 }
2000}
2001
2002// (or exp0 ... expN)
2003static void eval_or(eval_context_t *ctx) {
2004 lbm_value rest = get_cdr(ctx->curr_exp);
2005 if (lbm_is_symbol_nil(rest)) {
2006 ctx->app_cont = true1;
2007 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2008 } else {
2009 lbm_value *sptr = stack_reserve(ctx, 3);
2010 sptr[0] = ctx->curr_env;
2011 sptr[1] = get_cdr(rest);
2012 sptr[2] = OR(((7) << 2) | 0xF8000001u);
2013 ctx->curr_exp = get_car(rest);
2014 }
2015}
2016
2017// Pattern matching
2018// format:
2019// (match e (pattern body)
2020// (pattern body)
2021// ... )
2022//
2023// There can be an optional pattern guard:
2024// (match e (pattern guard body)
2025// ... )
2026// a guard is a boolean expression.
2027// Guards make match, pattern matching more complicated
2028// than the recv pattern matching and requires staged execution
2029// via the continuation system rather than a while loop over a list.
2030static void eval_match(eval_context_t *ctx) {
2031
2032 lbm_value rest = get_cdr(ctx->curr_exp);
2033 if (lbm_type_of(rest) == LBM_TYPE_SYMBOL0x00000000u &&
2034 rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
2035 // Someone wrote the program (match)
2036 ctx->app_cont = true1;
2037 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2038 } else {
2039 lbm_value cdr_rest;
2040 get_car_and_cdr(rest, &ctx->curr_exp, &cdr_rest);
2041 lbm_value *sptr = stack_reserve(ctx, 3);
2042 sptr[0] = cdr_rest;
2043 sptr[1] = ctx->curr_env;
2044 sptr[2] = MATCH(((9) << 2) | 0xF8000001u);
2045 }
2046}
2047
2048static void receive_base(eval_context_t *ctx, lbm_value pats, float timeout_time, bool_Bool timeout) {
2049 if (ctx->num_mail == 0) {
2050 if (timeout) {
2051 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000), false0);
2052 } else {
2053 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1,0,false0);
2054 }
2055 } else {
2056 lbm_value *msgs = ctx->mailbox;
2057 lbm_uint num = ctx->num_mail;
2058
2059 if (lbm_is_symbol_nil(pats)) {
2060 /* A receive statement without any patterns */
2061 ctx->app_cont = true1;
2062 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2063 } else {
2064 /* The common case */
2065 lbm_value e;
2066 lbm_value new_env = ctx->curr_env;
2067 int n = find_match(pats, msgs, num, &e, &new_env);
2068 if (n == FM_NEED_GC-1) {
2069 gc();
2070 new_env = ctx->curr_env;
2071 n = find_match(pats, msgs, num, &e, &new_env);
2072 if (n == FM_NEED_GC-1) {
2073 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2074 }
2075 }
2076 if (n == FM_PATTERN_ERROR-3) {
2077 lbm_set_error_reason("Incorrect pattern format for recv");
2078 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),pats);
2079 } else if (n >= 0 ) { /* Match */
2080 mailbox_remove_mail(ctx, (lbm_uint)n);
2081 ctx->curr_env = new_env;
2082 ctx->curr_exp = e;
2083 } else { /* No match go back to sleep */
2084 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
2085 if (timeout) {
2086 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2,S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000),false0);
2087 } else {
2088 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,false0);
2089 }
2090 }
2091 }
2092 }
2093 return;
2094}
2095
2096static void eval_receive_timeout(eval_context_t *ctx) {
2097 if (is_atomic) {
2098 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2099 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2100 }
2101 lbm_value timeout_val = get_cadr(ctx->curr_exp);
2102 if (!lbm_is_number(timeout_val)) {
2103 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2104 }
2105 float timeout_time = lbm_dec_as_float(timeout_val);
2106 lbm_value pats = get_cdr(get_cdr(ctx->curr_exp));
2107 receive_base(ctx, pats, timeout_time, true1);
2108}
2109
2110// Receive
2111// (recv (pattern expr)
2112// (pattern expr))
2113static void eval_receive(eval_context_t *ctx) {
2114
2115 if (is_atomic) {
2116 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2117 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
2118 }
2119 lbm_value pats = get_cdr(ctx->curr_exp);
2120 receive_base(ctx, pats, 0, false0);
2121}
2122
2123/*********************************************************/
2124/* Continuation functions */
2125
2126/* cont_set_global_env
2127 sp-1 : Key-symbol
2128 */
2129static void cont_set_global_env(eval_context_t *ctx){
2130
2131 lbm_value key;
2132 lbm_value val = ctx->r;
2133
2134 lbm_pop(&ctx->K, &key);
2135 lbm_uint dec_key = lbm_dec_sym(key);
2136 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
2137 lbm_value *global_env = lbm_get_global_env();
2138 lbm_uint orig_env = global_env[ix_key];
2139 lbm_value new_env;
2140 // A key is a symbol and should not need to be remembered.
2141 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2142
2143 global_env[ix_key] = new_env;
2144 ctx->r = val;
2145
2146 ctx->app_cont = true1;
2147
2148 return;
2149}
2150
2151static void cont_resume(eval_context_t *ctx) {
2152 lbm_pop_2(&ctx->K, &ctx->curr_env, &ctx->curr_exp);
2153}
2154
2155static void cont_progn_rest(eval_context_t *ctx) {
2156 lbm_value *sptr = get_stack_ptr(ctx, 3);
2157
2158 lbm_value rest = sptr[2];
2159 lbm_value env = sptr[0];
2160
2161 lbm_value rest_car, rest_cdr;
2162 get_car_and_cdr(rest, &rest_car, &rest_cdr);
2163 ctx->curr_exp = rest_car;
2164 ctx->curr_env = env;
2165 if (lbm_is_symbol_nil(rest_cdr)) {
2166 // allow for tail recursion
2167 lbm_stack_drop(&ctx->K, 3);
2168 } else {
2169 sptr[2] = rest_cdr;
2170 stack_reserve(ctx, 1)[0] = PROGN_REST(((4) << 2) | 0xF8000001u);
2171 }
2172}
2173
2174static void cont_wait(eval_context_t *ctx) {
2175
2176 lbm_value cid_val;
2177 lbm_pop(&ctx->K, &cid_val);
2178 lbm_cid cid = (lbm_cid)lbm_dec_i(cid_val);
2179
2180 bool_Bool exists = false0;
2181
2182 lbm_blocked_iterator(context_exists, &cid, &exists);
2183 lbm_running_iterator(context_exists, &cid, &exists);
2184
2185 if (ctx_running->id == cid) {
2186 exists = true1;
2187 }
2188
2189 if (exists) {
2190 lbm_value *sptr = stack_reserve(ctx, 2);
2191 sptr[0] = lbm_enc_i(cid);
2192 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2193 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2194 ctx->app_cont = true1;
2195 yield_ctx(50000);
2196 } else {
2197 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2198 ctx->app_cont = true1;
2199 }
2200}
2201
2202static lbm_value perform_setvar(lbm_value key, lbm_value val, lbm_value env) {
2203
2204 lbm_uint s = lbm_dec_sym(key);
2205 if (s >= RUNTIME_SYMBOLS_START0x40000) {
2206 lbm_value new_env = lbm_env_modify_binding(env, key, val);
2207 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2208 lbm_uint ix_key = lbm_dec_sym(key) & GLOBAL_ENV_MASK0x1F;
2209 lbm_value *glob_env = lbm_get_global_env();
2210 new_env = lbm_env_modify_binding(glob_env[ix_key], key, val);
2211 glob_env[ix_key] = new_env;
2212 }
2213 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2214 lbm_set_error_reason((char*)lbm_error_str_variable_not_bound);
2215 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), key);
2216 }
2217 return val;
2218 }
2219 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2220 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // unreachable
2221}
2222
2223static void apply_setvar(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2224 if (nargs == 2 && lbm_is_symbol(args[0])) {
2225 lbm_value res;
2226 WITH_GC(res, perform_setvar(args[0], args[1], ctx->curr_env))(res) = (perform_setvar(args[0], args[1], ctx->curr_env));
if (lbm_is_symbol_merror((res))) { gc(); (res) = (perform_setvar
(args[0], args[1], ctx->curr_env)); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2227 ctx->r = args[1];
2228 lbm_stack_drop(&ctx->K, nargs+1);
2229 ctx->app_cont = true1;
2230 } else {
2231 if (nargs == 2) lbm_set_error_reason((char*)lbm_error_str_incorrect_arg);
2232 else lbm_set_error_reason((char*)lbm_error_str_num_args);
2233 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2234 }
2235}
2236
2237static void apply_read_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, bool_Bool program, bool_Bool incremental) {
2238 if (nargs == 1) {
2239 lbm_value chan = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2240 if (lbm_type_of_functional(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2241 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2242 gc();
2243 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2244 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2245 }
2246 }
2247 } else if (lbm_type_of(args[0]) == LBM_TYPE_CHANNEL0x90000000u) {
2248 chan = args[0];
2249 } else {
2250 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2251 }
2252 lbm_value *sptr = get_stack_ptr(ctx, 2);
2253
2254 // If we are inside a reader, its settings are stored.
2255 sptr[0] = lbm_enc_u(ctx->flags); // flags stored.
2256 sptr[1] = chan;
2257 lbm_value *rptr = stack_reserve(ctx,1);
2258 rptr[0] = READ_DONE(((20) << 2) | 0xF8000001u);
2259
2260 // Each reader starts in a fresh situation
2261 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
2262
2263 if (program) {
2264 if (incremental) {
2265 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2266 lbm_value *rptr1 = stack_reserve(ctx,3);
2267 rptr1[0] = chan;
2268 rptr1[1] = ctx->curr_env;
2269 rptr1[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
2270 } else {
2271 ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2272 lbm_value *rptr1 = stack_reserve(ctx,4);
2273 rptr1[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2274 rptr1[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2275 rptr1[2] = chan;
2276 rptr1[3] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
2277 }
2278 }
2279 rptr = stack_reserve(ctx,3); // reuse of variable rptr
2280 rptr[0] = chan;
2281 rptr[1] = lbm_enc_u(1);
2282 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
2283 ctx->app_cont = true1;
2284 } else {
2285 lbm_set_error_reason((char*)lbm_error_str_num_args);
2286 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2287 }
2288}
2289
2290static void apply_read_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2291 apply_read_base(args,nargs,ctx,true1,false0);
2292}
2293
2294static void apply_read_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2295 apply_read_base(args,nargs,ctx,true1,true1);
2296}
2297
2298static void apply_read(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2299 apply_read_base(args,nargs,ctx,false0,false0);
2300}
2301
2302static void apply_spawn_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, uint32_t context_flags) {
2303
2304 lbm_uint stack_size = EVAL_CPS_DEFAULT_STACK_SIZE256;
2305 lbm_uint closure_pos = 0;
2306 char *name = NULL((void*)0);
2307
2308 if (nargs >= 1 &&
2309 lbm_is_closure(args[0])) {
2310 closure_pos = 0;
2311 } else if (nargs >= 2 &&
2312 lbm_is_number(args[0]) &&
2313 lbm_is_closure(args[1])) {
2314 stack_size = lbm_dec_as_u32(args[0]);
2315 closure_pos = 1;
2316 } else if (nargs >= 2 &&
2317 lbm_is_array_r(args[0]) &&
2318 lbm_is_closure(args[1])) {
2319 name = lbm_dec_str(args[0]);
2320 closure_pos = 1;
2321 }else if (nargs >= 3 &&
2322 lbm_is_array_r(args[0]) &&
2323 lbm_is_number(args[1]) &&
2324 lbm_is_closure(args[2])) {
2325 stack_size = lbm_dec_as_u32(args[1]);
2326 closure_pos = 2;
2327 name = lbm_dec_str(args[0]);
2328 } else {
2329 if (context_flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01)
2330 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN_TRAP(((0x30005) << 4) | 0x00000000u));
2331 else
2332 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN(((0x30004) << 4) | 0x00000000u));
2333 }
2334
2335 lbm_value cl[3];
2336 extract_n(get_cdr(args[closure_pos]), cl, 3);
2337 lbm_value curr_param = cl[CLO_PARAMS0];
2338 lbm_value clo_env = cl[CLO_ENV2];
2339 lbm_uint i = closure_pos + 1;
2340 while (lbm_is_cons(curr_param) && i <= nargs) {
2341 lbm_value entry = cons_with_gc(get_car(curr_param), args[i], clo_env);
2342 lbm_value aug_env = cons_with_gc(entry, clo_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2343 clo_env = aug_env;
2344 curr_param = get_cdr(curr_param);
2345 i ++;
2346 }
2347
2348 lbm_stack_drop(&ctx->K, nargs+1);
2349
2350 lbm_value program = cons_with_gc(cl[CLO_BODY1], ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), clo_env);
2351
2352 lbm_cid cid = lbm_create_ctx_parent(program,
2353 clo_env,
2354 stack_size,
2355 lbm_get_current_cid(),
2356 context_flags,
2357 name);
2358 ctx->r = lbm_enc_i(cid);
2359 ctx->app_cont = true1;
2360}
2361
2362static void apply_spawn(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2363 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00);
2364}
2365
2366static void apply_spawn_trap(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2367 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01);
2368}
2369
2370static void apply_yield(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2371 if (is_atomic) {
2372 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2373 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2374 }
2375 if (nargs == 1 && lbm_is_number(args[0])) {
2376 lbm_uint ts = lbm_dec_as_u32(args[0]);
2377 lbm_stack_drop(&ctx->K, nargs+1);
2378 yield_ctx(ts);
2379 } else {
2380 lbm_set_error_reason((char*)lbm_error_str_no_number);
2381 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2382 }
2383}
2384
2385static void apply_sleep(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2386 if (is_atomic) {
2387 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2388 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2389 }
2390 if (nargs == 1 && lbm_is_number(args[0])) {
2391 lbm_uint ts = (lbm_uint)(1000000.0f * lbm_dec_as_float(args[0]));
2392 lbm_stack_drop(&ctx->K, nargs+1);
2393 yield_ctx(ts);
2394 } else {
2395 lbm_set_error_reason((char*)lbm_error_str_no_number);
2396 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2397 }
2398}
2399
2400static void apply_wait(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2401 if (nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2402 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2403 lbm_value *sptr = get_stack_ptr(ctx, 2);
2404 sptr[0] = lbm_enc_i(cid);
2405 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2406 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2407 ctx->app_cont = true1;
2408 yield_ctx(50000);
2409 } else {
2410 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_WAIT(((0x30007) << 4) | 0x00000000u));
2411 }
2412}
2413
2414/* (eval expr)
2415 (eval env expr) */
2416static void apply_eval(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2417 if ( nargs == 1) {
2418 ctx->curr_exp = args[0];
2419 } else if (nargs == 2) {
2420 ctx->curr_exp = args[1];
2421 ctx->curr_env = args[0];
2422 } else {
2423 lbm_set_error_reason((char*)lbm_error_str_num_args);
2424 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL(((0x30008) << 4) | 0x00000000u));
2425 }
2426 lbm_stack_drop(&ctx->K, nargs+1);
2427}
2428
2429static void apply_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2430 int prg_pos = 0;
2431 if (nargs == 2) {
2432 prg_pos = 1;
2433 ctx->curr_env = args[0];
2434 }
2435 if (nargs == 1 || nargs == 2) {
2436 lbm_value prg = args[prg_pos];
2437 lbm_value app_cont;
2438 lbm_value app_cont_prg;
2439 lbm_value new_prg;
2440 lbm_value prg_copy;
2441
2442 int len = -1;
2443 WITH_GC(prg_copy, lbm_list_copy(&len, prg))(prg_copy) = (lbm_list_copy(&len, prg)); if (lbm_is_symbol_merror
((prg_copy))) { gc(); (prg_copy) = (lbm_list_copy(&len, prg
)); if (lbm_is_symbol_merror((prg_copy))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2444 lbm_stack_drop(&ctx->K, nargs+1);
2445
2446 if (ctx->K.sp > nargs+2) { // if there is a continuation
2447 app_cont = cons_with_gc(ENC_SYM_APP_CONT(((0x111) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2448 app_cont_prg = cons_with_gc(app_cont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2449 new_prg = lbm_list_append(app_cont_prg, ctx->program);
2450 new_prg = lbm_list_append(prg_copy, new_prg);
2451 } else {
2452 new_prg = lbm_list_append(prg_copy, ctx->program);
2453 }
2454 if (!lbm_is_list(new_prg)) {
2455 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2456 }
2457 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);
2458 ctx->program = get_cdr(new_prg);
2459 ctx->curr_exp = get_car(new_prg);
2460 } else {
2461 lbm_set_error_reason((char*)lbm_error_str_num_args);
2462 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2463 }
2464}
2465
2466static void apply_send(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2467 if (nargs == 2) {
2468 if (lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2469 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2470 lbm_value msg = args[1];
2471 lbm_value status = lbm_find_receiver_and_send(cid, msg);
2472 /* return the status */
2473 lbm_stack_drop(&ctx->K, nargs+1);
2474 ctx->r = status;
2475 ctx->app_cont = true1;
2476 } else {
2477 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2478 }
2479 } else {
2480 lbm_set_error_reason((char*)lbm_error_str_num_args);
2481 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2482 }
2483}
2484
2485static void apply_ok(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2486 lbm_value ok_val = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2487 if (nargs >= 1) {
2488 ok_val = args[0];
2489 }
2490 ctx->r = ok_val;
2491 ok_ctx();
2492}
2493
2494static void apply_error(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2495 (void) ctx;
2496 lbm_value err_val = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
2497 if (nargs >= 1) {
2498 err_val = args[0];
2499 }
2500 error_at_ctx(err_val, ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
2501}
2502
2503// (map f arg-list)
2504static void apply_map(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2505 if (nargs == 2 && lbm_is_cons(args[1])) {
2506 lbm_value *sptr = get_stack_ptr(ctx, 3);
2507
2508 lbm_value f = args[0];
2509 lbm_value h = get_car(args[1]);
2510 lbm_value t = get_cdr(args[1]);
2511
2512 lbm_value appli_1;
2513 lbm_value appli;
2514 WITH_GC(appli_1, lbm_heap_allocate_list(2))(appli_1) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli_1))) { gc(); (appli_1) = (lbm_heap_allocate_list(2));
if (lbm_is_symbol_merror((appli_1))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2515 WITH_GC_RMBR_1(appli, lbm_heap_allocate_list(2), appli_1)(appli) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli))) { lbm_gc_mark_phase(appli_1); gc(); (appli) = (lbm_heap_allocate_list
(2)); if (lbm_is_symbol_merror((appli))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2516
2517 lbm_value appli_0 = get_cdr(appli_1);
2518
2519 lbm_set_car_and_cdr(appli_0, h, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2520 lbm_set_car(appli_1, ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u));
2521
2522 lbm_set_car_and_cdr(get_cdr(appli), appli_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2523 lbm_set_car(appli, f);
2524
2525 lbm_value elt = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), appli);
2526 sptr[0] = t; // reuse stack space
2527 sptr[1] = ctx->curr_env;
2528 sptr[2] = elt;
2529 lbm_value *rptr = stack_reserve(ctx,4);
2530 rptr[0] = elt;
2531 rptr[1] = appli;
2532 rptr[2] = appli_0;
2533 rptr[3] = MAP(((26) << 2) | 0xF8000001u);
2534 ctx->curr_exp = appli;
2535 } else if (nargs == 2 && lbm_is_symbol_nil(args[1])) {
2536 lbm_stack_drop(&ctx->K, 3);
2537 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2538 ctx->app_cont = true1;
2539 return;
2540 } else {
2541 lbm_set_error_reason((char*)lbm_error_str_num_args);
2542 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_MAP(((0x3000D) << 4) | 0x00000000u));
2543 }
2544}
2545
2546static void apply_reverse(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2547 if (nargs == 1 && lbm_is_list(args[0])) {
2548 lbm_value curr = args[0];
2549
2550 lbm_value new_list = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2551 while (lbm_is_cons(curr)) {
2552 lbm_value tmp = cons_with_gc(get_car(curr), new_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2553 new_list = tmp;
2554 curr = get_cdr(curr);
2555 }
2556 lbm_stack_drop(&ctx->K, 2);
2557 ctx->r = new_list;
2558 ctx->app_cont = true1;
2559 } else {
2560 lbm_set_error_reason("Reverse requires a list argument");
2561 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_REVERSE(((0x3000E) << 4) | 0x00000000u));
2562 }
2563}
2564
2565static void apply_flatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2566 if (nargs == 1) {
2567
2568 lbm_value v = flatten_value(args[0]);
2569 if ( v == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)) {
2570 gc();
2571 v = flatten_value(args[0]);
2572 }
2573
2574 if (lbm_is_symbol(v)) {
2575 error_at_ctx(v, ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2576 } else {
2577 lbm_stack_drop(&ctx->K, 2);
2578 ctx->r = v;
2579 ctx->app_cont = true1;
2580 }
2581 return;
2582 }
2583 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2584}
2585
2586static void apply_unflatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2587 if(nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2588 lbm_array_header_t *array;
2589 array = (lbm_array_header_t *)get_car(args[0]);
2590
2591 lbm_flat_value_t fv;
2592 fv.buf = (uint8_t*)array->data;
2593 fv.buf_size = array->size;
2594 fv.buf_pos = 0;
2595
2596 lbm_value res;
2597
2598 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2599 if (lbm_unflatten_value(&fv, &res)) {
2600 ctx->r = res;
2601 }
2602 lbm_stack_drop(&ctx->K, 2);
2603 ctx->app_cont = true1;
2604 return;
2605 }
2606 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_UNFLATTEN(((0x30010) << 4) | 0x00000000u));
2607}
2608
2609static void apply_kill(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2610 if (nargs == 2 && lbm_is_number(args[0])) {
2611 lbm_cid cid = lbm_dec_as_i32(args[0]);
2612
2613 if (ctx->id == cid) {
2614 ctx->r = args[1];
2615 finish_ctx();
2616 return;
2617 }
2618 mutex_lock(&qmutex);
2619 eval_context_t *found = NULL((void*)0);
2620 found = lookup_ctx_nm(&blocked, cid);
2621 if (found)
2622 drop_ctx_nm(&blocked, found);
2623 else
2624 found = lookup_ctx_nm(&queue, cid);
2625 if (found)
2626 drop_ctx_nm(&queue, found);
2627
2628 if (found) {
2629 found->K.data[found->K.sp - 1] = KILL(((40) << 2) | 0xF8000001u);
2630 found->r = args[1];
2631 found->app_cont = true1;
2632 enqueue_ctx_nm(&queue,found);
2633 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2634 } else {
2635 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2636 }
2637 lbm_stack_drop(&ctx->K, 3);
2638 ctx->app_cont = true1;
2639 mutex_unlock(&qmutex);
2640 return;
2641 }
2642 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_KILL(((0x30011) << 4) | 0x00000000u));
2643}
2644
2645// (merge comparator list1 list2)
2646static void apply_merge(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2647 if (nargs == 3 && lbm_is_list(args[1]) && lbm_is_list(args[2])) {
2648
2649 if (!lbm_is_closure(args[0])) {
2650 lbm_value closure;
2651 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2652 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2653 lbm_value cl1 = lbm_cdr(closure);
2654 lbm_value par;
2655 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2656 lbm_set_car(cl1, par);
2657 lbm_value cl2 = lbm_cdr(cl1);
2658 lbm_value body;
2659 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2660 lbm_set_car(cl2, body);
2661 lbm_value cl3 = lbm_cdr(cl2);
2662 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2663
2664 // Replace operator on stack with closure and rest of the code is
2665 // compatible.
2666 args[0] = closure;
2667 }
2668
2669 // Copy input lists for functional behaviour at top-level
2670 // merge itself is in-place in the copied lists.
2671 lbm_value a;
2672 lbm_value b;
2673 int len_a = -1;
2674 int len_b = -1;
2675 WITH_GC(a, lbm_list_copy(&len_a, args[1]))(a) = (lbm_list_copy(&len_a, args[1])); if (lbm_is_symbol_merror
((a))) { gc(); (a) = (lbm_list_copy(&len_a, args[1])); if
(lbm_is_symbol_merror((a))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } };
2676 WITH_GC_RMBR_1(b, lbm_list_copy(&len_b, args[2]), a)(b) = (lbm_list_copy(&len_b, args[2])); if (lbm_is_symbol_merror
((b))) { lbm_gc_mark_phase(a); gc(); (b) = (lbm_list_copy(&
len_b, args[2])); if (lbm_is_symbol_merror((b))) { error_ctx(
(((0x23) << 4) | 0x00000000u)); } };
2677
2678 if (len_a == 0) {
2679 ctx->r = b;
2680 lbm_stack_drop(&ctx->K, 4);
2681 ctx->app_cont = true1;
2682 return;
2683 }
2684 if (len_b == 0) {
2685 ctx->r = a;
2686 lbm_stack_drop(&ctx->K, 4);
2687 ctx->app_cont = true1;
2688 return;
2689 }
2690
2691 args[1] = a; // keep safe by replacing the original on stack.
2692 args[2] = b;
2693
2694 lbm_value a_1 = a;
2695 lbm_value a_rest = lbm_cdr(a);
2696 lbm_value b_1 = b;
2697 lbm_value b_rest = lbm_cdr(b);
2698
2699 lbm_value cl[3]; // Comparator closure
2700 extract_n(lbm_cdr(args[0]), cl, 3);
2701 lbm_value cmp_env = cl[CLO_ENV2];
2702 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2703 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2704 lbm_uint len = lbm_list_length(cl[CLO_PARAMS0]);
2705 if (len == 2) {
2706 par1 = get_car(cl[CLO_PARAMS0]);
2707 par2 = get_cadr(cl[CLO_PARAMS0]);
2708 lbm_value new_env0;
2709 lbm_value new_env;
2710 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a_1)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a_1))); if (
lbm_is_symbol_merror((new_env0))) { gc(); (new_env0) = (lbm_env_set
(cmp_env, par1, lbm_car(a_1))); if (lbm_is_symbol_merror((new_env0
))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2711 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b_1)),new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1))); if (
lbm_is_symbol_merror((new_env))) { lbm_gc_mark_phase(new_env0
); gc(); (new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1
))); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2712 cmp_env = new_env;
2713 } else {
2714 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2715 }
2716 lbm_set_cdr(a_1, b_1);
2717 lbm_set_cdr(b_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2718 lbm_value cmp = cl[CLO_BODY1];
2719
2720 lbm_stack_drop(&ctx->K, 4); // TODO: Optimize drop 4 alloc 10 into alloc 6
2721 lbm_uint *sptr = stack_reserve(ctx, 10);
2722 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged list
2723 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged list
2724 sptr[2] = a_1;
2725 sptr[3] = a_rest;
2726 sptr[4] = b_rest;
2727 sptr[5] = cmp;
2728 sptr[6] = cmp_env;
2729 sptr[7] = par1;
2730 sptr[8] = par2;
2731 sptr[9] = MERGE_REST(((43) << 2) | 0xF8000001u);
2732 ctx->curr_exp = cl[CLO_BODY1];
2733 ctx->curr_env = cmp_env;
2734 return;
2735 }
2736 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MERGE(((0x30013) << 4) | 0x00000000u));
2737}
2738
2739// (sort comparator list)
2740static void apply_sort(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2741 if (nargs == 2 && lbm_is_list(args[1])) {
2742
2743 if (!lbm_is_closure(args[0])) {
2744 lbm_value closure;
2745 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2746 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2747 lbm_value cl1 = lbm_cdr(closure);
2748 lbm_value par;
2749 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2750 lbm_set_car(cl1, par);
2751 lbm_value cl2 = lbm_cdr(cl1);
2752 lbm_value body;
2753 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2754 lbm_set_car(cl2, body);
2755 lbm_value cl3 = lbm_cdr(cl2);
2756 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2757
2758 // Replace operator on stack with closure and rest of the code is
2759 // compatible.
2760 args[0] = closure;
2761 }
2762
2763 int len = -1;
2764 lbm_value list_copy;
2765 WITH_GC(list_copy, lbm_list_copy(&len, args[1]))(list_copy) = (lbm_list_copy(&len, args[1])); if (lbm_is_symbol_merror
((list_copy))) { gc(); (list_copy) = (lbm_list_copy(&len,
args[1])); if (lbm_is_symbol_merror((list_copy))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2766 if (len <= 1) {
2767 lbm_stack_drop(&ctx->K, 3);
2768 ctx->r = list_copy;
2769 ctx->app_cont = true1;
2770 return;
2771 }
2772
2773 args[1] = list_copy; // Keep safe, original replaced on stack.
2774
2775 // Take the headmost 2, 1-element sublists.
2776 lbm_value a = list_copy;
2777 lbm_value b = lbm_cdr(a);
2778 lbm_value rest = lbm_cdr(b);
2779 // Do not terminate b. keep rest of list safe from GC in the following
2780 // closure extraction.
2781 //lbm_set_cdr(a, b); // This is void
2782
2783 lbm_value cl[3]; // Comparator closure
2784 extract_n(lbm_cdr(args[0]), cl, 3);
2785 lbm_value cmp_env = cl[CLO_ENV2];
2786 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2787 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2788 lbm_uint cl_len = lbm_list_length(cl[CLO_PARAMS0]);
2789 if (cl_len == 2) {
2790 par1 = get_car(cl[CLO_PARAMS0]);
2791 par2 = get_cadr(cl[CLO_PARAMS0]);
2792 lbm_value new_env0;
2793 lbm_value new_env;
2794 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a))); if (lbm_is_symbol_merror
((new_env0))) { gc(); (new_env0) = (lbm_env_set(cmp_env, par1
, lbm_car(a))); if (lbm_is_symbol_merror((new_env0))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2795 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b)), new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { lbm_gc_mark_phase(new_env0); gc(); (new_env) =
(lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { error_ctx((((0x23) << 4) | 0x00000000u))
; } };
2796 cmp_env = new_env;
2797 } else {
2798 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2799 }
2800 lbm_value cmp = cl[CLO_BODY1];
2801
2802 // Terminate the comparator argument list.
2803 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2804
2805 lbm_stack_drop(&ctx->K, 3); //TODO: optimize drop 3, alloc 20 into alloc 17
2806 lbm_uint *sptr = stack_reserve(ctx, 20);
2807 sptr[0] = cmp;
2808 sptr[1] = cmp_env;
2809 sptr[2] = par1;
2810 sptr[3] = par2;
2811 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged accumulation of sublists
2812 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged accumulation of sublists
2813 sptr[6] = rest;
2814 sptr[7] = lbm_enc_i(1);
2815 sptr[8] = lbm_enc_i(len); //TODO: 28 bit i vs 32 bit i
2816 sptr[9] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
2817 sptr[10] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged sublist
2818 sptr[11] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged sublist
2819 sptr[12] = a;
2820 sptr[13] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no a_rest, 1 element lists in layer 1.
2821 sptr[14] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no b_rest, 1 element lists in layer 1.
2822 sptr[15] = cmp;
2823 sptr[16] = cmp_env;
2824 sptr[17] = par1;
2825 sptr[18] = par2;
2826 sptr[19] = MERGE_REST(((43) << 2) | 0xF8000001u);
2827 ctx->curr_exp = cmp;
2828 ctx->curr_env = cmp_env;
2829 return;
2830 }
2831 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
2832}
2833
2834static void apply_rest_args(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2835 lbm_value res;
2836 if (lbm_env_lookup_b(&res, ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ctx->curr_env)) {
2837 if (nargs == 1 && lbm_is_number(args[0])) {
2838 int32_t ix = lbm_dec_as_i32(args[0]);
2839 res = lbm_index_list(res, ix);
2840 }
2841 ctx->r = res;
2842 } else {
2843 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2844 }
2845 lbm_stack_drop(&ctx->K, nargs+1);
2846 ctx->app_cont = true1;
2847}
2848
2849/* (rotate list-expr dist/dir-expr) */
2850static void apply_rotate(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2851 if (nargs == 2 && lbm_is_list(args[0]) && lbm_is_number(args[1])) {
2852 int len = -1;
2853 lbm_value ls = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2854 WITH_GC(ls, lbm_list_copy(&len, args[0]))(ls) = (lbm_list_copy(&len, args[0])); if (lbm_is_symbol_merror
((ls))) { gc(); (ls) = (lbm_list_copy(&len, args[0])); if
(lbm_is_symbol_merror((ls))) { error_ctx((((0x23) << 4
) | 0x00000000u)); } };
2855 int dist = lbm_dec_as_i32(args[1]);
2856 if (len > 0 && dist != 0) {
2857 int d = dist;
2858 if (dist > 0) {
2859 ls = lbm_list_destructive_reverse(ls);
2860 } else {
2861 d = -dist;
2862 }
2863
2864 lbm_value start = ls;
2865 lbm_value end = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2866 lbm_value curr = start;
2867 while (lbm_is_cons(curr)) {
2868 end = curr;
2869 curr = get_cdr(curr);
2870 }
2871
2872 for (int i = 0; i < d; i ++) {
2873 lbm_value a = start;
2874 start = lbm_cdr(start);
2875 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2876 lbm_set_cdr(end, a);
2877 end = a;
2878 }
2879 ls = start;
2880 if (dist > 0) {
2881 ls = lbm_list_destructive_reverse(ls);
2882 }
2883 }
2884 lbm_stack_drop(&ctx->K, nargs+1);
2885 ctx->app_cont = true1;
2886 ctx->r = ls;
2887 return;
2888 }
2889 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2890}
2891
2892/***************************************************/
2893/* Application lookup table */
2894
2895typedef void (*apply_fun)(lbm_value *, lbm_uint, eval_context_t *);
2896static const apply_fun fun_table[] =
2897 {
2898 apply_setvar,
2899 apply_read,
2900 apply_read_program,
2901 apply_read_eval_program,
2902 apply_spawn,
2903 apply_spawn_trap,
2904 apply_yield,
2905 apply_wait,
2906 apply_eval,
2907 apply_eval_program,
2908 apply_send,
2909 apply_ok,
2910 apply_error,
2911 apply_map,
2912 apply_reverse,
2913 apply_flatten,
2914 apply_unflatten,
2915 apply_kill,
2916 apply_sleep,
2917 apply_merge,
2918 apply_sort,
2919 apply_rest_args,
2920 apply_rotate,
2921 };
2922
2923/***************************************************/
2924/* Application of function that takes arguments */
2925/* passed over the stack. */
2926
2927static void application(eval_context_t *ctx, lbm_value *fun_args, lbm_uint arg_count) {
2928 /* If arriving here, we know that the fun is a symbol.
2929 * and can be a built in operation or an extension.
2930 */
2931 lbm_value fun = fun_args[0];
2932
2933 lbm_uint fun_val = lbm_dec_sym(fun);
2934 lbm_uint fun_kind = SYMBOL_KIND(fun_val)((fun_val) >> 16);
2935
2936 switch (fun_kind) {
2937 case SYMBOL_KIND_EXTENSION1: {
2938 extension_fptr f = extension_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)].fptr;
2939
2940 lbm_value ext_res;
2941 WITH_GC(ext_res, f(&fun_args[1], arg_count))(ext_res) = (f(&fun_args[1], arg_count)); if (lbm_is_symbol_merror
((ext_res))) { gc(); (ext_res) = (f(&fun_args[1], arg_count
)); if (lbm_is_symbol_merror((ext_res))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2942 if (lbm_is_error(ext_res)) { //Error other than merror
2943 error_at_ctx(ext_res, fun);
2944 }
2945 lbm_stack_drop(&ctx->K, arg_count + 1);
2946
2947 ctx->app_cont = true1;
2948 ctx->r = ext_res;
2949
2950 if (blocking_extension) {
2951 blocking_extension = false0;
2952 if (blocking_extension_timeout) {
2953 blocking_extension_timeout = false0;
2954 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, blocking_extension_timeout_us,true1);
2955 } else {
2956 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,true1);
2957 }
2958 mutex_unlock(&blocking_extension_mutex);
2959 }
2960 } break;
2961 case SYMBOL_KIND_FUNDAMENTAL2:
2962 call_fundamental(SYMBOL_IX(fun_val)((fun_val) & 0xFFFF), &fun_args[1], arg_count, ctx);
2963 break;
2964 case SYMBOL_KIND_APPFUN3:
2965 fun_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)](&fun_args[1], arg_count, ctx);
2966 break;
2967 default:
2968 // Symbols that are "special" but not in the way caught above
2969 // ends up here.
2970 lbm_set_error_reason("Symbol does not represent a function");
2971 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),fun_args[0]);
2972 break;
2973 }
2974}
2975
2976static void cont_closure_application_args(eval_context_t *ctx) {
2977 lbm_uint* sptr = get_stack_ptr(ctx, 5);
2978
2979 lbm_value arg_env = (lbm_value)sptr[0];
2980 lbm_value exp = (lbm_value)sptr[1];
2981 lbm_value clo_env = (lbm_value)sptr[2];
2982 lbm_value params = (lbm_value)sptr[3];
2983 lbm_value args = (lbm_value)sptr[4];
2984
2985 lbm_value car_params, cdr_params;
2986 get_car_and_cdr(params, &car_params, &cdr_params);
2987
2988 bool_Bool a_nil = lbm_is_symbol_nil(args);
2989 bool_Bool p_nil = lbm_is_symbol_nil(cdr_params);
2990
2991 lbm_value binder = allocate_binding(car_params, ctx->r, clo_env);
2992
2993 if (!a_nil && !p_nil) {
2994 lbm_value car_args, cdr_args;
2995 get_car_and_cdr(args, &car_args, &cdr_args);
2996 sptr[2] = binder;
2997 sptr[3] = cdr_params;
2998 sptr[4] = cdr_args;
2999 stack_reserve(ctx,1)[0] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
3000 ctx->curr_exp = car_args;
3001 ctx->curr_env = arg_env;
3002 } else if (a_nil && p_nil) {
3003 // Arguments and parameters match up in number
3004 lbm_stack_drop(&ctx->K, 5);
3005 ctx->curr_env = binder;
3006 ctx->curr_exp = exp;
3007 } else if (p_nil) {
3008 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), binder);
3009 sptr[2] = rest_binder;
3010 sptr[3] = get_cdr(args);
3011 sptr[4] = get_car(rest_binder); // last element of rest_args so far
3012 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3013 ctx->curr_exp = get_car(args);
3014 ctx->curr_env = arg_env;
3015 } else {
3016 lbm_set_error_reason((char*)lbm_error_str_num_args);
3017 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
3018 }
3019}
3020
3021
3022static void cont_closure_args_rest(eval_context_t *ctx) {
3023 lbm_uint* sptr = get_stack_ptr(ctx, 5);
3024 lbm_value arg_env = (lbm_value)sptr[0];
3025 lbm_value exp = (lbm_value)sptr[1];
3026 lbm_value clo_env = (lbm_value)sptr[2];
3027 lbm_value args = (lbm_value)sptr[3];
3028 lbm_value last = (lbm_value)sptr[4];
3029 lbm_cons_t* heap = lbm_heap_state.heap;
3030
3031 lbm_value binding = lbm_heap_state.freelist;
3032 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3033 gc();
3034 binding = lbm_heap_state.freelist;
3035 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3036 }
3037 lbm_uint binding_ix = lbm_dec_ptr(binding);
3038 lbm_heap_state.freelist = heap[binding_ix].cdr;
3039 lbm_heap_state.num_alloc += 1;
3040 heap[binding_ix].car = ctx->r;
3041 heap[binding_ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3042
3043
3044 lbm_set_cdr(last, binding);
3045 sptr[4] = binding;
3046
3047 if (args == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3048 lbm_stack_drop(&ctx->K, 5);
3049 ctx->curr_env = clo_env;
3050 ctx->curr_exp = exp;
3051 } else {
3052 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3053 sptr[3] = get_cdr(args);
3054 ctx->curr_exp = get_car(args);
3055 ctx->curr_env = arg_env;
3056 }
3057}
3058
3059static void cont_application_args(eval_context_t *ctx) {
3060 lbm_uint *sptr = get_stack_ptr(ctx, 3);
3061
3062 lbm_value env = sptr[0];
3063 lbm_value rest = sptr[1];
3064 lbm_value count = sptr[2];
3065
3066 ctx->curr_env = env;
3067 sptr[0] = ctx->r; // Function 1st then Arguments
3068 if (lbm_is_cons(rest)) {
3069 lbm_cons_t *cell = lbm_ref_cell(rest);
3070 sptr[1] = env;
3071 sptr[2] = cell->cdr;
3072 lbm_value *rptr = stack_reserve(ctx,2);
3073 rptr[0] = count + (1 << LBM_VAL_SHIFT4);
3074 rptr[1] = APPLICATION_ARGS(((5) << 2) | 0xF8000001u);
3075 ctx->curr_exp = cell->car;
3076 } else {
3077 // No more arguments
3078 lbm_stack_drop(&ctx->K, 2);
3079 lbm_uint nargs = lbm_dec_u(count);
3080 lbm_value *args = get_stack_ptr(ctx, (uint32_t)(nargs + 1));
3081 application(ctx,args, nargs);
3082 }
3083}
3084
3085static void cont_and(eval_context_t *ctx) {
3086 lbm_value env;
3087 lbm_value rest;
3088 lbm_value arg = ctx->r;
3089 lbm_pop_2(&ctx->K, &rest, &env);
3090 if (lbm_is_symbol_nil(arg)) {
3091 ctx->app_cont = true1;
3092 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3093 } else if (lbm_is_symbol_nil(rest)) {
3094 ctx->app_cont = true1;
3095 } else {
3096 lbm_value *sptr = stack_reserve(ctx, 3);
3097 sptr[0] = env;
3098 sptr[1] = get_cdr(rest);
3099 sptr[2] = AND(((6) << 2) | 0xF8000001u);
3100 ctx->curr_env = env;
3101 ctx->curr_exp = get_car(rest);
3102 }
3103}
3104
3105static void cont_or(eval_context_t *ctx) {
3106 lbm_value env;
3107 lbm_value rest;
3108 lbm_value arg = ctx->r;
3109 lbm_pop_2(&ctx->K, &rest, &env);
3110 if (!lbm_is_symbol_nil(arg)) {
3111 ctx->app_cont = true1;
3112 } else if (lbm_is_symbol_nil(rest)) {
3113 ctx->app_cont = true1;
3114 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3115 } else {
3116 lbm_value *sptr = stack_reserve(ctx, 3);
3117 sptr[0] = env;
3118 sptr[1] = get_cdr(rest);
3119 sptr[2] = OR(((7) << 2) | 0xF8000001u);
3120 ctx->curr_exp = get_car(rest);
3121 ctx->curr_env = env;
3122 }
3123}
3124
3125static int fill_binding_location(lbm_value key, lbm_value value, lbm_value env) {
3126 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) {
3127 if (key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return FB_OK0;
3128 lbm_env_modify_binding(env,key,value);
3129 return FB_OK0;
3130 } else if (lbm_is_cons(key) &&
3131 lbm_is_cons(value)) {
3132 int r = fill_binding_location(get_car(key), get_car(value), env);
3133 if (r == FB_OK0) {
3134 r = fill_binding_location(get_cdr(key), get_cdr(value), env);
3135 }
3136 return r;
3137 }
3138 return FB_TYPE_ERROR-1;
3139}
3140
3141static void cont_bind_to_key_rest(eval_context_t *ctx) {
3142
3143 lbm_value *sptr = get_stack_ptr(ctx, 4);
3144
3145 lbm_value rest = sptr[1];
3146 lbm_value env = sptr[2];
3147 lbm_value key = sptr[3];
3148
3149 if (fill_binding_location(key, ctx->r, env) < 0) {
3150 lbm_set_error_reason("Incorrect type of name/key in let-binding");
3151 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
3152 }
3153
3154 if (lbm_is_cons(rest)) {
3155 lbm_value car_rest = get_car(rest);
3156 lbm_value key_val[2];
3157 extract_n(car_rest, key_val, 2);
3158
3159 sptr[1] = get_cdr(rest);
3160 sptr[3] = key_val[0];
3161 stack_reserve(ctx,1)[0] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
3162 ctx->curr_exp = key_val[1];
3163 ctx->curr_env = env;
3164 } else {
3165 // Otherwise evaluate the expression in the populated env
3166 ctx->curr_exp = sptr[0];
3167 ctx->curr_env = env;
3168 lbm_stack_drop(&ctx->K, 4);
3169 }
3170}
3171
3172static void cont_if(eval_context_t *ctx) {
3173
3174 lbm_value arg = ctx->r;
3175
3176 lbm_value *sptr = pop_stack_ptr(ctx, 2);
3177
3178 ctx->curr_env = sptr[1];
3179 if (lbm_is_symbol_nil(arg)) {
3180 ctx->curr_exp = get_cadr(sptr[0]); // else branch
3181 } else {
3182 ctx->curr_exp = get_car(sptr[0]); // then branch
3183 }
3184}
3185
3186static void cont_match(eval_context_t *ctx) {
3187 lbm_value e = ctx->r;
3188 bool_Bool do_gc = false0;
3189
3190 lbm_uint *sptr = get_stack_ptr(ctx, 2);
3191 lbm_value patterns = (lbm_value)sptr[0];
3192 lbm_value orig_env = (lbm_value)sptr[1]; // restore enclosing environment.
3193 lbm_value new_env = orig_env;
3194
3195 if (lbm_is_symbol_nil(patterns)) {
3196 // no more patterns
3197 lbm_stack_drop(&ctx->K, 2);
3198 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
3199 ctx->app_cont = true1;
3200 } else if (lbm_is_cons(patterns)) {
3201 lbm_value match_case = get_car(patterns);
3202 lbm_value pattern = get_car(match_case);
3203 lbm_value n1 = get_cadr(match_case);
3204 lbm_value n2 = get_cadr(get_cdr(match_case));
3205 lbm_value body;
3206 bool_Bool check_guard = false0;
3207 if (lbm_is_symbol_nil(n2)) { // TODO: Not a very robust check.
3208 body = n1;
3209 } else {
3210 body = n2;
3211 check_guard = true1;
3212 }
3213
3214 bool_Bool is_match = match(pattern, e, &new_env, &do_gc);
3215 if (do_gc) {
3216 gc();
3217 do_gc = false0;
3218 new_env = orig_env;
3219 is_match = match(pattern, e, &new_env, &do_gc);
3220 if (do_gc) {
3221 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3222 }
3223 }
3224 if (is_match) {
3225 if (check_guard) {
3226 lbm_value *rptr = stack_reserve(ctx,5);
3227 sptr[0] = get_cdr(patterns);
3228 sptr[1] = ctx->curr_env;
3229 rptr[0] = MATCH(((9) << 2) | 0xF8000001u);
3230 rptr[1] = new_env;
3231 rptr[2] = body;
3232 rptr[3] = e;
3233 rptr[4] = MATCH_GUARD(((27) << 2) | 0xF8000001u);
3234 ctx->curr_env = new_env;
3235 ctx->curr_exp = n1; // The guard
3236 } else {
3237 lbm_stack_drop(&ctx->K, 2);
3238 ctx->curr_env = new_env;
3239 ctx->curr_exp = body;
3240 }
3241 } else {
3242 // set up for checking of next pattern
3243 sptr[0] = get_cdr(patterns);
3244 sptr[1] = orig_env;
3245 stack_reserve(ctx,1)[0] = MATCH(((9) << 2) | 0xF8000001u);
3246 // leave r unaltered
3247 ctx->app_cont = true1;
3248 }
3249 } else {
3250 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MATCH(((0x108) << 4) | 0x00000000u));
3251 }
3252}
3253
3254static void cont_exit_atomic(eval_context_t *ctx) {
3255 is_atomic --;
3256 ctx->app_cont = true1;
3257}
3258
3259static void cont_map(eval_context_t *ctx) {
3260 lbm_value *sptr = get_stack_ptr(ctx, 6);
3261
3262 lbm_value ls = sptr[0];
3263 lbm_value env = sptr[1];
3264 lbm_value t = sptr[3];
3265 lbm_set_car(t, ctx->r); // update car field tailmost position.
3266 if (lbm_is_cons(ls)) {
3267 lbm_value next, rest;
3268 get_car_and_cdr(ls, &next, &rest);
3269 sptr[0] = rest;
3270 stack_reserve(ctx,1)[0] = MAP(((26) << 2) | 0xF8000001u);
3271 lbm_set_car(sptr[5], next); // new arguments
3272
3273 lbm_value elt = cons_with_gc(ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3274 lbm_set_cdr(t, elt);
3275 sptr[3] = elt; // (r1 ... rN . (nil . nil))
3276 ctx->curr_exp = sptr[4];
3277 ctx->curr_env = env;
3278 } else {
3279 ctx->r = sptr[2]; //head of result list
3280 ctx->curr_env = env;
3281 lbm_stack_drop(&ctx->K, 6);
3282 ctx->app_cont = true1;
3283 }
3284}
3285
3286static void cont_match_guard(eval_context_t *ctx) {
3287 if (lbm_is_symbol_nil(ctx->r)) {
3288 lbm_value e;
3289 lbm_pop(&ctx->K, &e);
3290 lbm_stack_drop(&ctx->K, 2);
3291 ctx->r = e;
3292 ctx->app_cont = true1;
3293 } else {
3294 lbm_value body;
3295 lbm_value env;
3296 lbm_stack_drop(&ctx->K, 1);
3297 lbm_pop_2(&ctx->K, &body, &env);
3298 lbm_stack_drop(&ctx->K, 3);
3299 ctx->curr_env = env;
3300 ctx->curr_exp = body;
3301 }
3302}
3303
3304static void cont_terminate(eval_context_t *ctx) {
3305 error_ctx(ctx->r);
3306}
3307
3308static void cont_loop(eval_context_t *ctx) {
3309 lbm_value *sptr = get_stack_ptr(ctx, 2);
3310 stack_reserve(ctx,1)[0] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
3311 ctx->curr_exp = sptr[1];
3312}
3313
3314static void cont_loop_condition(eval_context_t *ctx) {
3315 if (lbm_is_symbol_nil(ctx->r)) {
3316 lbm_stack_drop(&ctx->K, 2);
3317 ctx->app_cont = true1; // A loop returns nil? Makes sense to me... but in general?
3318 return;
3319 }
3320 lbm_value *sptr = get_stack_ptr(ctx, 2);
3321 stack_reserve(ctx,1)[0] = LOOP(((41) << 2) | 0xF8000001u);
3322 ctx->curr_exp = sptr[0];
3323}
3324
3325static void cont_merge_rest(eval_context_t *ctx) {
3326 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3327
3328 // If comparator returns true (result is in ctx->r):
3329 // "a" should be moved to the last element position in merged list.
3330 // A new element from "a_rest" should be moved into comparator argument 1 pos.
3331 // else
3332 // "b" should be moved to last element position in merged list.
3333 // A new element from "b_rest" should be moved into comparator argument 2 pos.
3334 //
3335 // If a_rest or b_rest is NIL:
3336 // we are done, the remaining elements of
3337 // non_nil list should be appended to merged list.
3338 // else
3339 // Set up for a new comparator evaluation and recurse.
3340 lbm_value a = sptr[2];
3341 lbm_value b = lbm_cdr(a);
3342 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate 1 element list
3343
3344 if (ctx->r == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) { // Comparison false
3345
3346 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3347 sptr[0] = b;
3348 sptr[1] = b;
3349 } else {
3350 lbm_set_cdr(sptr[1], b);
3351 sptr[1] = b;
3352 }
3353 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3354 lbm_set_cdr(a, sptr[3]);
3355 lbm_set_cdr(sptr[1], a);
3356 ctx->r = sptr[0];
3357 lbm_stack_drop(&ctx->K, 9);
3358 ctx->app_cont = true1;
3359 return;
3360 } else {
3361 b = sptr[4];
3362 sptr[4] = lbm_cdr(sptr[4]);
3363 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3364 }
3365 } else {
3366 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3367 sptr[0] = a;
3368 sptr[1] = a;
3369 } else {
3370 lbm_set_cdr(sptr[1], a);
3371 sptr[1] = a;
3372 }
3373
3374 if (sptr[3] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3375 lbm_set_cdr(b, sptr[4]);
3376 lbm_set_cdr(sptr[1], b);
3377 ctx->r = sptr[0];
3378 lbm_stack_drop(&ctx->K, 9);
3379 ctx->app_cont = true1;
3380 return;
3381 } else {
3382 a = sptr[3];
3383 sptr[3] = lbm_cdr(sptr[3]);
3384 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3385 }
3386 }
3387 lbm_set_cdr(a, b);
3388 sptr[2] = a;
3389
3390 lbm_value par1 = sptr[7];
3391 lbm_value par2 = sptr[8];
3392 lbm_value cmp_body = sptr[5];
3393 lbm_value cmp_env = sptr[6];
3394 // Environment should be preallocated already at this point
3395 // and the operations below should never need GC.
3396 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3397 lbm_value new_env = lbm_env_set(new_env0, par2, lbm_car(b));
3398 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3399 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3400 }
3401 cmp_env = new_env;
3402
3403 stack_reserve(ctx,1)[0] = MERGE_REST(((43) << 2) | 0xF8000001u);
3404 ctx->curr_exp = cmp_body;
3405 ctx->curr_env = cmp_env;
3406}
3407
3408// merge_layer stack contents
3409// s[sp-9] = cmp
3410// s[sp-8] = cmp_env
3411// s[sp-7] = par1
3412// s[sp-6] = par2
3413// s[sp-5] = acc - first cell
3414// s[sp-4] = acc - last cell
3415// s[sp-3] = rest;
3416// s[sp-2] = layer
3417// s[sp-1] = length or original list
3418//
3419// ctx->r merged sublist
3420static void cont_merge_layer(eval_context_t *ctx) {
3421 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3422 lbm_int layer = lbm_dec_i(sptr[7]);
3423 lbm_int len = lbm_dec_i(sptr[8]);
3424
3425 lbm_value r_curr = ctx->r;
3426 while (lbm_is_cons(r_curr)) {
3427 lbm_value next = lbm_cdr(r_curr);
3428 if (next == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3429 break;
3430 }
3431 r_curr = next;
3432 }
3433
3434 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3435 sptr[4] = ctx->r;
3436 sptr[5] = r_curr;
3437 } else {
3438 lbm_set_cdr(sptr[5], ctx->r); // accumulate merged sublists.
3439 sptr[5] = r_curr;
3440 }
3441
3442 lbm_value layer_rest = sptr[6];
3443 // switch layer or done ?
3444 if (layer_rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3445 if (layer * 2 >= len) {
3446 ctx->r = sptr[4];
3447 ctx->app_cont = true1;
3448 lbm_stack_drop(&ctx->K, 9);
3449 return;
3450 } else {
3451 // Setup for merges of the next layer
3452 layer = layer * 2;
3453 sptr[7] = lbm_enc_i(layer);
3454 layer_rest = sptr[4]; // continue on the accumulation of all sublists.
3455 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3456 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3457 }
3458 }
3459 // merge another sublist based on current layer.
3460 lbm_value a_list = layer_rest;
3461 // build sublist a
3462 lbm_value curr = layer_rest;
3463 for (int i = 0; i < layer-1; i ++) {
3464 if (lbm_is_cons(curr)) {
3465 curr = lbm_cdr(curr);
3466 } else {
3467 break;
3468 }
3469 }
3470 layer_rest = lbm_cdr(curr);
3471 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3472
3473 lbm_value b_list = layer_rest;
3474 // build sublist b
3475 curr = layer_rest;
3476 for (int i = 0; i < layer-1; i ++) {
3477 if (lbm_is_cons(curr)) {
3478 curr = lbm_cdr(curr);
3479 } else {
3480 break;
3481 }
3482 }
3483 layer_rest = lbm_cdr(curr);
3484 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3485
3486 sptr[6] = layer_rest;
3487
3488 if (b_list == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3489 stack_reserve(ctx,1)[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3490 ctx->r = a_list;
3491 ctx->app_cont = true1;
3492 return;
3493 }
3494 // Set up for a merge of sublists.
3495
3496 lbm_value a_rest = lbm_cdr(a_list);
3497 lbm_value b_rest = lbm_cdr(b_list);
3498 lbm_value a = a_list;
3499 lbm_value b = b_list;
3500 lbm_set_cdr(a, b);
3501 // Terminating the b list would be incorrect here
3502 // if there was any chance that the environment update below
3503 // performs GC.
3504 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3505
3506 lbm_value cmp_body = sptr[0];
3507 lbm_value cmp_env = sptr[1];
3508 lbm_value par1 = sptr[2];
3509 lbm_value par2 = sptr[3];
3510 // Environment should be preallocated already at this point
3511 // and the operations below should never need GC.
3512 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3513 lbm_value new_env = lbm_env_set(cmp_env, par2, lbm_car(b));
3514 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3515 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3516 }
3517 cmp_env = new_env;
3518
3519 lbm_uint *merge_cont = stack_reserve(ctx, 11);
3520 merge_cont[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3521 merge_cont[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3522 merge_cont[2] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3523 merge_cont[3] = a;
3524 merge_cont[4] = a_rest;
3525 merge_cont[5] = b_rest;
3526 merge_cont[6] = cmp_body;
3527 merge_cont[7] = cmp_env;
3528 merge_cont[8] = par1;
3529 merge_cont[9] = par2;
3530 merge_cont[10] = MERGE_REST(((43) << 2) | 0xF8000001u);
3531 ctx->curr_exp = cmp_body;
3532 ctx->curr_env = cmp_env;
3533 return;
3534}
3535
3536/****************************************************/
3537/* READER */
3538
3539static void read_finish(lbm_char_channel_t *str, eval_context_t *ctx) {
3540
3541 /* Tokenizer reached "end of file"
3542 The parser could be in a state where it needs
3543 more tokens to correctly finish an expression.
3544
3545 Three cases
3546 1. The program / expression is malformed and the context should die.
3547 2. We are finished reading a program and should close off the
3548 internal representation with a closing parenthesis. Then
3549 apply continuation.
3550 3. We are finished reading an expression and should
3551 apply the continuation.
3552
3553 In case 3, we should find the READ_DONE at sp - 1.
3554 In case 2, we should find the READ_DONE at sp - 5.
3555
3556 */
3557
3558 if (lbm_is_symbol(ctx->r)) {
3559 lbm_uint sym_val = lbm_dec_sym(ctx->r);
3560 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
3561 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
3562 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3563 }
3564 }
3565
3566 if (ctx->K.data[ctx->K.sp-1] == READ_DONE(((20) << 2) | 0xF8000001u) &&
3567 lbm_dec_u(ctx->K.data[ctx->K.sp-3]) == 0) {
3568 /* successfully finished reading an expression (CASE 3) */
3569 ctx->app_cont = true1;
3570 } else if (ctx->K.sp > 4 && ctx->K.data[ctx->K.sp - 4] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3571 lbm_value env;
3572 lbm_value s;
3573 lbm_value sym;
3574 lbm_pop_3(&ctx->K, &sym, &env, &s);
3575 ctx->curr_env = env;
3576 ctx->app_cont = true1; // Program evaluated and result is in ctx->r.
3577 } else if (ctx->K.sp > 5 && ctx->K.data[ctx->K.sp - 5] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3578 /* successfully finished reading a program (CASE 2) */
3579 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3580 ctx->app_cont = true1;
3581 } else {
3582 /* Parsing failed */
3583 if (lbm_channel_row(str) == 1 &&
3584 lbm_channel_column(str) == 1 ){
3585 // eof at empty stream.
3586 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3587 ctx->app_cont = true1;
3588 } else {
3589 lbm_set_error_reason((char*)lbm_error_str_parse_eof);
3590 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3591 }
3592 lbm_channel_reader_close(str);
3593 }
3594}
3595
3596/* cont_read_next_token
3597 sp-2 : Stream
3598 sp-1 : Grab row
3599*/
3600static void cont_read_next_token(eval_context_t *ctx) {
3601 lbm_value *sptr = get_stack_ptr(ctx, 2);
3602 lbm_value stream = sptr[0];
3603 lbm_value grab_row0 = sptr[1];
3604
3605 lbm_char_channel_t *chan = lbm_dec_channel(stream);
3606 if (chan == NULL((void*)0) || chan->state == NULL((void*)0)) {
3607 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3608 }
3609
3610 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3611 lbm_stack_drop(&ctx->K, 2);
3612 read_finish(chan, ctx);
3613 return;
3614 }
3615 /* Eat whitespace and comments */
3616 if (!tok_clean_whitespace(chan)) {
3617 sptr[0] = stream;
3618 sptr[1] = lbm_enc_u(0);
3619 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3620 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3621 return;
3622 }
3623 /* After eating whitespace we may be at end of file/stream */
3624 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3625 lbm_stack_drop(&ctx->K, 2);
3626 read_finish(chan, ctx);
3627 return;
3628 }
3629
3630 if (lbm_dec_u(grab_row0)) {
3631 ctx->row0 = (int32_t)lbm_channel_row(chan);
3632 }
3633
3634 /* Attempt to extract tokens from the character stream */
3635 int n = 0;
3636 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3637 unsigned int string_len = 0;
3638
3639 /*
3640 * SYNTAX
3641 */
3642 uint32_t match;
3643 n = tok_syntax(chan, &match);
3644 if (n > 0) {
3645 if (!lbm_channel_drop(chan, (unsigned int)n)) {
3646 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3647 }
3648 ctx->app_cont = true1;
3649 lbm_uint do_next = 0;
3650 switch(match) {
3651 case TOKOPENPAR1u: {
3652 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3653 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3654 lbm_value *rptr = stack_reserve(ctx,5);
3655 rptr[0] = stream;
3656 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3657 rptr[2] = stream;
3658 rptr[3] = lbm_enc_u(0);
3659 rptr[4] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3660 ctx->r = ENC_SYM_OPENPAR(((0x70) << 4) | 0x00000000u);
3661 } return;
3662 case TOKCLOSEPAR2u: {
3663 lbm_stack_drop(&ctx->K, 2);
3664 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3665 } return;
3666 case TOKOPENBRACK3u: {
3667 sptr[0] = stream;
3668 sptr[1] = READ_START_ARRAY(((24) << 2) | 0xF8000001u);
3669 lbm_value *rptr = stack_reserve(ctx, 3);
3670 rptr[0] = stream;
3671 rptr[1] = lbm_enc_u(0);
3672 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3673 ctx->r = ENC_SYM_OPENBRACK(((0x80) << 4) | 0x00000000u);
3674 } return;
3675 case TOKCLOSEBRACK4u:
3676 lbm_stack_drop(&ctx->K, 2);
3677 ctx->r = ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u);
3678 return;
3679 case TOKDOT5u:
3680 lbm_stack_drop(&ctx->K, 2);
3681 ctx->r = ENC_SYM_DOT(((0x76) << 4) | 0x00000000u);
3682 return;
3683 case TOKDONTCARE6u:
3684 lbm_stack_drop(&ctx->K, 2);
3685 ctx->r = ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u);
3686 return;
3687 case TOKQUOTE7u:
3688 do_next = READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u);
3689 break;
3690 case TOKBACKQUOTE8u: {
3691 sptr[0] = QQ_EXPAND_START(((35) << 2) | 0xF8000001u);
3692 sptr[1] = stream;
3693 lbm_value *rptr = stack_reserve(ctx, 2);
3694 rptr[0] = lbm_enc_u(0);
3695 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3696 ctx->app_cont = true1;
3697 } return;
3698 case TOKCOMMAAT9u:
3699 do_next = READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u);
3700 break;
3701 case TOKCOMMA10u:
3702 do_next = READ_COMMA_RESULT(((23) << 2) | 0xF8000001u);
3703 break;
3704 case TOKMATCHANY11u:
3705 lbm_stack_drop(&ctx->K, 2);
3706 ctx->r = ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u);
3707 return;
3708 case TOKOPENCURL12u: {
3709 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3710 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3711 lbm_value *rptr = stack_reserve(ctx,2);
3712 rptr[0] = stream;
3713 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3714 ctx->r = ENC_SYM_PROGN(((0x102) << 4) | 0x00000000u);
3715 } return;
3716 case TOKCLOSECURL13u:
3717 lbm_stack_drop(&ctx->K, 2);
3718 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3719 return;
3720 case TOKCONSTSTART14u: /* fall through */
3721 case TOKCONSTEND15u:
3722 case TOKCONSTSYMSTR16u: {
3723 if (match == TOKCONSTSTART14u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3724 if (match == TOKCONSTEND15u) ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3725 if (match == TOKCONSTSYMSTR16u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04;
3726 sptr[0] = stream;
3727 sptr[1] = lbm_enc_u(0);
3728 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3729 ctx->app_cont = true1;
3730 } return;
3731 default:
3732 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3733 }
3734 sptr[0] = do_next;
3735 sptr[1] = stream;
3736 lbm_value *rptr = stack_reserve(ctx, 2);
3737 rptr[0] = lbm_enc_u(0);
3738 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3739 ctx->app_cont = true1;
3740 return;
3741 } else if (n < 0) goto retry_token;
3742
3743 /*
3744 * STRING
3745 */
3746 n = tok_string(chan, &string_len);
3747 if (n >= 2) {
3748 lbm_channel_drop(chan, (unsigned int)n);
3749 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3750 gc();
3751 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3752 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3753 return; // dead return but static analysis does not know that.
3754 }
3755 }
3756 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(res);
3757 char *data = (char*)arr->data;
3758 memset(data,0, string_len + 1);
3759 memcpy(data, tokpar_sym_str, string_len);
3760 lbm_stack_drop(&ctx->K, 2);
3761 ctx->r = res;
3762 ctx->app_cont = true1;
3763 return;
3764 } else if (n < 0) goto retry_token;
3765
3766 /*
3767 * FLOAT
3768 */
3769 token_float f_val;
3770 n = tok_double(chan, &f_val);
3771 if (n > 0) {
3772 lbm_channel_drop(chan, (unsigned int) n);
3773 switch(f_val.type) {
3774 case TOKTYPEF32107u:
3775 WITH_GC(res, lbm_enc_float((float)f_val.value))(res) = (lbm_enc_float((float)f_val.value)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (lbm_enc_float((float)f_val.value));
if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
3776 break;
3777 case TOKTYPEF64108u:
3778 res = lbm_enc_double(f_val.value);
3779 break;
3780 default:
3781 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3782 }
3783 lbm_stack_drop(&ctx->K, 2);
3784 ctx->r = res;
3785 ctx->app_cont = true1;
3786 return;
3787 } else if (n < 0) goto retry_token;
3788
3789 /*
3790 * INTEGER
3791 */
3792 token_int int_result;
3793 n = tok_integer(chan, &int_result);
3794 if (n > 0) {
3795 lbm_channel_drop(chan, (unsigned int)n);
3796 switch(int_result.type) {
3797 case TOKTYPEBYTE100u:
3798 res = lbm_enc_char((uint8_t)(int_result.negative ? -int_result.value : int_result.value));
3799 break;
3800 case TOKTYPEI101u:
3801 res = lbm_enc_i((lbm_int)(int_result.negative ? -int_result.value : int_result.value));
3802 break;
3803 case TOKTYPEU102u:
3804 res = lbm_enc_u((lbm_uint)(int_result.negative ? -int_result.value : int_result.value));
3805 break;
3806 case TOKTYPEI32103u:
3807 WITH_GC(res, lbm_enc_i32((int32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i32((int32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i32((int32_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3808 break;
3809 case TOKTYPEU32104u:
3810 WITH_GC(res,lbm_enc_u32((uint32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u32((uint32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u32((uint32_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3811 break;
3812 case TOKTYPEI64105u:
3813 WITH_GC(res,lbm_enc_i64((int64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i64((int64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i64((int64_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3814 break;
3815 case TOKTYPEU64106u:
3816 WITH_GC(res,lbm_enc_u64((uint64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u64((uint64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u64((uint64_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3817 break;
3818 default:
3819 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3820 }
3821 lbm_stack_drop(&ctx->K, 2);
3822 ctx->r = res;
3823 ctx->app_cont = true1;
3824 return;
3825 } else if (n < 0) goto retry_token;
3826
3827 /*
3828 * SYMBOL
3829 */
3830 n = tok_symbol(chan);
3831 if (n > 0) {
3832 lbm_channel_drop(chan, (unsigned int) n);
3833 lbm_uint symbol_id;
3834 if (lbm_get_symbol_by_name(tokpar_sym_str, &symbol_id)) {
3835 res = lbm_enc_sym(symbol_id);
3836 } else {
3837 int r = 0;
3838 if (n > 4 &&
3839 tokpar_sym_str[0] == 'e' &&
3840 tokpar_sym_str[1] == 'x' &&
3841 tokpar_sym_str[2] == 't' &&
3842 tokpar_sym_str[3] == '-') {
3843 lbm_uint ext_id;
3844 lbm_uint ext_name_len = (lbm_uint)n + 1;
3845 char *ext_name = lbm_malloc(ext_name_len);
3846 if (!ext_name) {
3847 gc();
3848 ext_name = lbm_malloc(ext_name_len);
3849 }
3850 if (ext_name) {
3851 memcpy(ext_name, tokpar_sym_str, ext_name_len);
3852 r = lbm_add_extension(ext_name, lbm_extensions_default);
3853 if (!lbm_lookup_extension_id(ext_name, &ext_id)) {
3854 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3855 }
3856 symbol_id = ext_id;
3857 } else {
3858 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3859 }
3860 } else {
3861 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04 &&
3862 ctx->flags & EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08) {
3863 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id, true1); //flash
3864 if (!r) {
3865 lbm_set_error_reason((char*)lbm_error_str_flash_error);
3866 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3867 }
3868 } else {
3869 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3870 if (!r) {
3871 gc();
3872 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3873 }
3874 }
3875 }
3876 if (r) {
3877 res = lbm_enc_sym(symbol_id);
3878 } else {
3879 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3880 }
3881 }
3882 lbm_stack_drop(&ctx->K, 2);
3883 ctx->r = res;
3884 ctx->app_cont = true1;
3885 return;
3886 } else if (n == TOKENIZER_NEED_MORE-1) {
3887 goto retry_token;
3888 } else if (n <= TOKENIZER_STRING_ERROR-2) {
3889 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3890 }
3891
3892 /*
3893 * CHAR
3894 */
3895 char c_val;
3896 n = tok_char(chan, &c_val);
3897 if(n > 0) {
3898 lbm_channel_drop(chan,(unsigned int) n);
3899 lbm_stack_drop(&ctx->K, 2);
3900 ctx->r = lbm_enc_char((uint8_t)c_val);
3901 ctx->app_cont = true1;
3902 return;
3903 }else if (n < 0) goto retry_token;
3904
3905 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3906
3907 retry_token:
3908 if (n == TOKENIZER_NEED_MORE-1) {
3909 sptr[0] = stream;
3910 sptr[1] = lbm_enc_u(0);
3911 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3912 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3913 return;
3914 }
3915 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3916}
3917
3918static void cont_read_start_array(eval_context_t *ctx) {
3919 lbm_value *sptr = get_stack_ptr(ctx, 1);
3920 lbm_value stream = sptr[0];
3921
3922 lbm_char_channel_t *str = lbm_dec_channel(stream);
3923 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
3924 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3925 }
3926
3927 lbm_uint num_free = lbm_memory_longest_free();
3928 lbm_uint initial_size = (lbm_uint)((float)num_free * 0.9);
3929 if (initial_size == 0) {
3930 gc();
3931 num_free = lbm_memory_longest_free();
3932 initial_size = (lbm_uint)((float)num_free * 0.9);
3933 if (initial_size == 0) {
3934 lbm_channel_reader_close(str);
3935 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3936 }
3937 }
3938
3939 if (lbm_is_number(ctx->r)) {
3940 lbm_value array;
3941 initial_size = sizeof(lbm_uint) * initial_size;
3942
3943 if (!lbm_heap_allocate_array(&array, initial_size)) {
3944 lbm_set_error_reason("Out of memory while reading.");
3945 lbm_channel_reader_close(str);
3946 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3947 // NOTE: If array is not created evaluation ends here.
3948 // Static analysis seems unaware.
3949 }
3950
3951 sptr[0] = array;
3952 lbm_value *rptr = stack_reserve(ctx, 4);
3953 rptr[0] = lbm_enc_u(initial_size);
3954 rptr[1] = lbm_enc_u(0);
3955 rptr[2] = stream;
3956 rptr[3] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3957 ctx->app_cont = true1;
3958 } else {
3959 lbm_channel_reader_close(str);
3960 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3961 }
3962}
3963
3964static void cont_read_append_array(eval_context_t *ctx) {
3965 lbm_uint *sptr = get_stack_ptr(ctx, 4);
3966
3967 lbm_value array = sptr[0];
3968 lbm_value size = lbm_dec_as_u32(sptr[1]);
3969 lbm_value ix = lbm_dec_as_u32(sptr[2]);
3970 lbm_value stream = sptr[3];
3971
3972 if (ix >= (size - 1)) {
3973 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3974 }
3975
3976 // get_car can return nil. Whose value is 0!
3977 // So static Analysis is right about this being a potential NULL pointer.
3978 // However, if the array was created correcly to begin with, it should be fine.
3979 lbm_value arr_car = get_car(array);
3980 lbm_array_header_t *arr = (lbm_array_header_t*)arr_car;
3981
3982 if (lbm_is_number(ctx->r)) {
3983 ((uint8_t*)arr->data)[ix] = (uint8_t)lbm_dec_as_u32(ctx->r);
3984
3985 sptr[2] = lbm_enc_u(ix + 1);
3986 lbm_value *rptr = stack_reserve(ctx, 4);
3987 rptr[0] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3988 rptr[1] = stream;
3989 rptr[2] = lbm_enc_u(0);
3990 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3991 ctx->app_cont = true1;
3992 } else if (lbm_is_symbol(ctx->r) && ctx->r == ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u)) {
3993 lbm_uint array_size = ix / sizeof(lbm_uint);
3994
3995 if (ix % sizeof(lbm_uint) != 0) {
3996 array_size = array_size + 1;
3997 }
3998 lbm_memory_shrink((lbm_uint*)arr->data, array_size);
3999 arr->size = ix;
4000 lbm_stack_drop(&ctx->K, 4);
4001 ctx->r = array;
4002 ctx->app_cont = true1;
4003 } else {
4004 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
4005 }
4006}
4007
4008static void cont_read_append_continue(eval_context_t *ctx) {
4009 lbm_value *sptr = get_stack_ptr(ctx, 3);
4010
4011 lbm_value first_cell = sptr[0];
4012 lbm_value last_cell = sptr[1];
4013 lbm_value stream = sptr[2];
4014
4015 lbm_char_channel_t *str = lbm_dec_channel(stream);
4016 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4017 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4018 }
4019
4020 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4021
4022 switch(ctx->r) {
4023 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4024 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4025 lbm_set_cdr(last_cell, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate the list
4026 ctx->r = first_cell;
4027 } else {
4028 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4029 }
4030 lbm_stack_drop(&ctx->K, 3);
4031 /* Skip reading another token and apply the continuation */
4032 ctx->app_cont = true1;
4033 return;
4034 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4035 lbm_value *rptr = stack_reserve(ctx, 4);
4036 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4037 rptr[1] = stream;
4038 rptr[2] = lbm_enc_u(0);
4039 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4040 ctx->app_cont = true1;
4041 } return;
4042 }
4043 }
4044 lbm_value new_cell = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4045 if (lbm_is_symbol_merror(new_cell)) {
4046 lbm_channel_reader_close(str);
4047 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4048 return;
4049 }
4050 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4051 lbm_set_cdr(last_cell, new_cell);
4052 last_cell = new_cell;
4053 } else {
4054 first_cell = last_cell = new_cell;
4055 }
4056 sptr[0] = first_cell;
4057 sptr[1] = last_cell;
4058 sptr[2] = stream; // unchanged.
4059 lbm_value *rptr = stack_reserve(ctx, 4);
4060 rptr[0] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
4061 rptr[1] = stream;
4062 rptr[2] = lbm_enc_u(0);
4063 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4064 ctx->app_cont = true1;
4065}
4066
4067static void cont_read_eval_continue(eval_context_t *ctx) {
4068 lbm_value env;
4069 lbm_value stream;
4070 lbm_pop_2(&ctx->K, &env, &stream);
4071
4072 lbm_char_channel_t *str = lbm_dec_channel(stream);
4073 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4074 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4075 }
4076
4077 ctx->row1 = (lbm_int)str->row(str);
4078
4079 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4080
4081 switch(ctx->r) {
4082 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4083 ctx->app_cont = true1;
4084 return;
4085 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4086 // This case is a bit mysterious.
4087 // A dot, may in reality be an error in this location.
4088 lbm_value *rptr = stack_reserve(ctx, 4);
4089 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4090 rptr[1] = stream;
4091 rptr[2] = lbm_enc_u(0);
4092 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4093 ctx->app_cont = true1;
4094 } return;
4095 }
4096 }
4097
4098 lbm_value *rptr = stack_reserve(ctx, 6);
4099 rptr[0] = stream;
4100 rptr[1] = env;
4101 rptr[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
4102 rptr[3] = stream;
4103 rptr[4] = lbm_enc_u(1);
4104 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4105 rptr[6] = lbm_enc_u(ctx->flags);
4106 rptr[7] = POP_READER_FLAGS(((47) << 2) | 0xF8000001u);
4107 ctx->curr_env = env;
4108 ctx->curr_exp = ctx->r;
4109}
4110
4111static void cont_read_expect_closepar(eval_context_t *ctx) {
4112 lbm_value res;
4113 lbm_value stream;
4114
4115 lbm_pop_2(&ctx->K, &res, &stream);
4116
4117 lbm_char_channel_t *str = lbm_dec_channel(stream);
4118 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4119 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4120 }
4121
4122 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4123 ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u)) {
4124 ctx->r = res;
4125 ctx->app_cont = true1;
4126 } else {
4127 lbm_channel_reader_close(str);
4128 lbm_set_error_reason((char*)lbm_error_str_parse_close);
4129 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4130 }
4131}
4132
4133static void cont_read_dot_terminate(eval_context_t *ctx) {
4134 lbm_value *sptr = get_stack_ptr(ctx, 3);
4135
4136 lbm_value first_cell = sptr[0];
4137 lbm_value last_cell = sptr[1];
4138 lbm_value stream = sptr[2];
4139
4140 lbm_char_channel_t *str = lbm_dec_channel(stream);
4141 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4142 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4143 }
4144
4145 lbm_stack_drop(&ctx->K ,3);
4146
4147 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4148 (ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u) ||
4149 ctx->r == ENC_SYM_DOT(((0x76) << 4) | 0x00000000u))) {
4150 lbm_channel_reader_close(str);
4151 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4152 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4153 } else {
4154 if (lbm_is_cons(last_cell)) {
4155 lbm_set_cdr(last_cell, ctx->r);
4156 ctx->r = first_cell;
4157 lbm_value *rptr = stack_reserve(ctx, 6);
4158 rptr[0] = stream;
4159 rptr[1] = ctx->r;
4160 rptr[2] = READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u);
4161 rptr[3] = stream;
4162 rptr[4] = lbm_enc_u(0);
4163 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4164 ctx->app_cont = true1;
4165 } else {
4166 lbm_channel_reader_close(str);
4167 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4168 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4169 }
4170 }
4171}
4172
4173static void cont_read_done(eval_context_t *ctx) {
4174 lbm_value stream;
4175 lbm_value f_val;
4176 lbm_pop_2(&ctx->K, &stream ,&f_val);
4177
4178 uint32_t flags = lbm_dec_as_u32(f_val);
4179 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4180 ctx->flags |= (flags & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4181
4182 lbm_char_channel_t *str = lbm_dec_channel(stream);
4183 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4184 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4185 }
4186
4187 lbm_channel_reader_close(str);
4188 if (lbm_is_symbol(ctx->r)) {
4189 lbm_uint sym_val = lbm_dec_sym(ctx->r);
4190 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
4191 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
4192 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4193 }
4194 }
4195
4196 ctx->row0 = -1;
4197 ctx->row1 = -1;
4198 ctx->app_cont = true1;
4199}
4200
4201static void cont_read_quote_result(eval_context_t *ctx) {
4202 lbm_value cell;
4203 WITH_GC(cell, lbm_heap_allocate_list_init(2,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4204 ENC_SYM_QUOTE,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4205 ctx->r))(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
};
4206 ctx->r = cell;
4207 ctx->app_cont = true1;
4208}
4209
4210static void cont_read_commaat_result(eval_context_t *ctx) {
4211 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4212 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4213 ctx->r = cell1;
4214 ctx->app_cont = true1;
4215}
4216
4217static void cont_read_comma_result(eval_context_t *ctx) {
4218 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u),ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4219 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4220 ctx->r = cell1;
4221 ctx->app_cont = true1;
4222}
4223
4224static void cont_application_start(eval_context_t *ctx) {
4225
4226 /* sptr[0] = env
4227 * sptr[1] = args
4228 * ctx->r = function
4229 */
4230
4231 if (lbm_is_symbol(ctx->r)) {
4232 stack_reserve(ctx,1)[0] = lbm_enc_u(0);
4233 cont_application_args(ctx);
4234 } else if (lbm_is_cons(ctx->r)) {
4235 lbm_uint *sptr = get_stack_ptr(ctx, 2);
4236 lbm_value args = (lbm_value)sptr[1];
4237 switch (get_car(ctx->r)) {
4238 case ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u): {
4239 lbm_value cl[3];
4240 extract_n(get_cdr(ctx->r), cl, 3);
4241 lbm_value arg_env = (lbm_value)sptr[0];
4242 lbm_value arg0, arg_rest;
4243 get_car_and_cdr(args, &arg0, &arg_rest);
4244 sptr[1] = cl[CLO_BODY1];
4245 bool_Bool a_nil = lbm_is_symbol_nil(args);
4246 bool_Bool p_nil = lbm_is_symbol_nil(cl[CLO_PARAMS0]);
4247 lbm_value *reserved = stack_reserve(ctx, 4);
4248
4249 if (!a_nil && !p_nil) {
4250 reserved[0] = cl[CLO_ENV2];
4251 reserved[1] = cl[CLO_PARAMS0];
4252 reserved[2] = arg_rest;
4253 reserved[3] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
4254 ctx->curr_exp = arg0;
4255 ctx->curr_env = arg_env;
4256 } else if (a_nil && p_nil) {
4257 // No params, No args
4258 lbm_stack_drop(&ctx->K, 6);
4259 ctx->curr_exp = cl[CLO_BODY1];
4260 ctx->curr_env = cl[CLO_ENV2];
4261 } else if (p_nil) {
4262 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), cl[CLO_ENV2]);
4263 reserved[0] = rest_binder;
4264 reserved[1] = get_cdr(args);
4265 reserved[2] = get_car(rest_binder);
4266 reserved[3] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
4267 ctx->curr_exp = get_car(args);
4268 ctx->curr_env = arg_env;
4269 } else {
4270 lbm_set_error_reason((char*)lbm_error_str_num_args);
4271 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->r);
4272 }
4273 } break;
4274 case ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u):{
4275 /* Continuation created using call-cc.
4276 * ((SYM_CONT . cont-array) arg0 )
4277 */
4278 lbm_value c = get_cdr(ctx->r); /* should be the continuation array*/
4279
4280 if (!lbm_is_lisp_array_r(c)) {
4281 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4282 }
4283
4284 lbm_uint arg_count = lbm_list_length(args);
4285 lbm_value arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4286 switch (arg_count) {
4287 case 0:
4288 arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4289 break;
4290 case 1:
4291 arg = get_car(args);
4292 break;
4293 default:
4294 lbm_set_error_reason((char*)lbm_error_str_num_args);
4295 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4296 }
4297 lbm_stack_clear(&ctx->K);
4298
4299 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(c);
4300
4301 ctx->K.sp = arr->size / sizeof(lbm_uint);
4302 memcpy(ctx->K.data, arr->data, arr->size);
4303
4304 ctx->curr_exp = arg;
4305 break;
4306 }
4307 case ENC_SYM_MACRO(((0x10D) << 4) | 0x00000000u):{
4308 /*
4309 * Perform macro expansion.
4310 * Macro expansion is really just evaluation in an
4311 * environment augmented with the unevaluated expressions passed
4312 * as arguments.
4313 */
4314 lbm_value env = (lbm_value)sptr[0];
4315
4316 lbm_value curr_param = get_cadr(ctx->r);
4317 lbm_value curr_arg = args;
4318 lbm_value expand_env = env;
4319 while (lbm_is_cons(curr_param) &&
4320 lbm_is_cons(curr_arg)) {
4321 lbm_value car_curr_param, cdr_curr_param;
4322 lbm_value car_curr_arg, cdr_curr_arg;
4323 get_car_and_cdr(curr_param, &car_curr_param, &cdr_curr_param);
4324 get_car_and_cdr(curr_arg, &car_curr_arg, &cdr_curr_arg);
4325
4326 lbm_value entry = cons_with_gc(car_curr_param, car_curr_arg, expand_env);
4327 lbm_value aug_env = cons_with_gc(entry, expand_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4328 expand_env = aug_env;
4329
4330 curr_param = cdr_curr_param;
4331 curr_arg = cdr_curr_arg;
4332 }
4333 /* Two rounds of evaluation is performed.
4334 * First to instantiate the arguments into the macro body.
4335 * Second to evaluate the resulting program.
4336 */
4337 sptr[1] = EVAL_R(((11) << 2) | 0xF8000001u);
4338 lbm_value exp = get_cadr(get_cdr(ctx->r));
4339 ctx->curr_exp = exp;
4340 ctx->curr_env = expand_env;
4341 } break;
4342 default:
4343 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4344 }
4345 } else {
4346 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4347 }
4348}
4349
4350static void cont_eval_r(eval_context_t* ctx) {
4351 lbm_value env;
4352 lbm_pop(&ctx->K, &env);
4353 ctx->curr_exp = ctx->r;
4354 ctx->curr_env = env;
4355}
4356
4357static void cont_progn_var(eval_context_t* ctx) {
4358
4359 lbm_value key;
4360 lbm_value env;
4361
4362 lbm_pop_2(&ctx->K, &key, &env);
4363
4364 if (fill_binding_location(key, ctx->r, env) < 0) {
4365 lbm_set_error_reason("Incorrect type of name/key in let-binding");
4366 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
4367 }
4368
4369 ctx->app_cont = true1;
4370}
4371
4372static void cont_setq(eval_context_t *ctx) {
4373 lbm_value sym;
4374 lbm_value env;
4375 lbm_pop_2(&ctx->K, &sym, &env);
4376 lbm_value res;
4377 WITH_GC(res, perform_setvar(sym, ctx->r, env))(res) = (perform_setvar(sym, ctx->r, env)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (perform_setvar(sym, ctx->r, env)
); if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
4378 ctx->r = res;
4379 ctx->app_cont = true1;
4380}
4381
4382lbm_flash_status request_flash_storage_cell(lbm_value val, lbm_value *res) {
4383
4384 lbm_value flash_cell;
4385 lbm_flash_status s = lbm_allocate_const_cell(&flash_cell);
4386 if (s != LBM_FLASH_WRITE_OK)
4387 return s;
4388 lbm_value new_val = val;
4389 new_val &= ~LBM_PTR_VAL_MASK0x03FFFFFCu; // clear the value part of the ptr
4390 new_val |= (flash_cell & LBM_PTR_VAL_MASK0x03FFFFFCu);
4391 new_val |= LBM_PTR_TO_CONSTANT_BIT0x04000000u;
4392 *res = new_val;
4393 return s;
4394}
4395
4396static void cont_move_to_flash(eval_context_t *ctx) {
4397
4398 lbm_value args;
4399 lbm_pop(&ctx->K, &args);
4400
4401 if (lbm_is_symbol_nil(args)) {
4402 // Done looping over arguments. return true.
4403 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
4404 ctx->app_cont = true1;
4405 return;
4406 }
4407
4408 lbm_value first_arg, rest;
4409 get_car_and_cdr(args, &first_arg, &rest);
4410
4411 lbm_value val;
4412 if (lbm_is_symbol(first_arg) && lbm_global_env_lookup(&val, first_arg)) {
4413 // Prepare to copy the rest of the arguments when done with first.
4414 lbm_value *rptr = stack_reserve(ctx, 2);
4415 rptr[0] = rest;
4416 rptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
4417 if (lbm_is_ptr(val) &&
4418 (!(val & LBM_PTR_TO_CONSTANT_BIT0x04000000u))) {
4419 lbm_value * rptr1 = stack_reserve(ctx, 3);
4420 rptr1[0] = first_arg;
4421 rptr1[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
4422 rptr1[2] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4423 ctx->r = val;
4424 }
4425 ctx->app_cont = true1;
4426 return;
4427 }
4428 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4429}
4430
4431static void cont_move_val_to_flash_dispatch(eval_context_t *ctx) {
4432
4433 lbm_value val = ctx->r;
4434
4435 if (lbm_is_cons(val)) {
4436 lbm_value *rptr = stack_reserve(ctx, 5);
4437 rptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // fst cell of list
4438 rptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last cell of list
4439 rptr[2] = get_cdr(val);
4440 rptr[3] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4441 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4442 ctx->r = get_car(val);
4443 ctx->app_cont = true1;
4444 return;
4445 }
4446
4447 if (lbm_is_ptr(val) && (val & LBM_PTR_TO_CONSTANT_BIT0x04000000u)) {
4448 ctx->r = val;
4449 ctx->app_cont = true1;
4450 return;
4451 }
4452
4453 if (lbm_is_ptr(val)) {
4454 lbm_cons_t *ref = lbm_ref_cell(val);
4455 if (lbm_type_of(ref->cdr) == LBM_TYPE_SYMBOL0x00000000u) {
4456 switch (ref->cdr) {
4457 case ENC_SYM_RAW_I_TYPE(((0x31) << 4) | 0x00000000u): /* fall through */
4458 case ENC_SYM_RAW_U_TYPE(((0x32) << 4) | 0x00000000u):
4459 case ENC_SYM_RAW_F_TYPE(((0x33) << 4) | 0x00000000u): {
4460 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4461 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4462 handle_flash_status(write_const_car(flash_cell, ref->car));
4463 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4464 ctx->r = flash_cell;
4465 } break;
4466 case ENC_SYM_IND_I_TYPE(((0x34) << 4) | 0x00000000u): /* fall through */
4467 case ENC_SYM_IND_U_TYPE(((0x35) << 4) | 0x00000000u):
4468 case ENC_SYM_IND_F_TYPE(((0x36) << 4) | 0x00000000u): {
4469#ifndef LBM64
4470 /* 64 bit values are in lbm mem on 32bit platforms. */
4471 lbm_uint *lbm_mem_ptr = (lbm_uint*)ref->car;
4472 lbm_uint flash_ptr;
4473
4474 handle_flash_status(lbm_write_const_raw(lbm_mem_ptr, 2, &flash_ptr));
4475 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4476 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4477 handle_flash_status(write_const_car(flash_cell, flash_ptr));
4478 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4479 ctx->r = flash_cell;
4480#else
4481 // There are no indirect types in LBM64
4482 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4483#endif
4484 } break;
4485 case ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u): {
4486 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4487 lbm_uint size = arr->size / sizeof(lbm_uint);
4488 lbm_uint flash_addr;
4489 lbm_value *arrdata = (lbm_value *)arr->data;
4490 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4491 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4492 handle_flash_status(lbm_allocate_const_raw(size, &flash_addr));
4493 lift_array_flash(flash_cell,
4494 false0,
4495 (char *)flash_addr,
4496 arr->size);
4497 // Move array contents to flash recursively
4498 lbm_value *rptr = stack_reserve(ctx, 5);
4499 rptr[0] = flash_cell;
4500 rptr[1] = lbm_enc_u(0);
4501 rptr[2] = val;
4502 rptr[3] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4503 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4504 ctx->r = arrdata[0];
4505 ctx->app_cont = true1;
4506 return;
4507 }
4508 case ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u): {
4509 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4510 // arbitrary address: flash_arr.
4511 lbm_uint flash_arr;
4512 handle_flash_status(lbm_write_const_array_padded((uint8_t*)arr->data, arr->size, &flash_arr));
4513 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4514 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4515 lift_array_flash(flash_cell,
4516 true1,
4517 (char *)flash_arr,
4518 arr->size);
4519 ctx->r = flash_cell;
4520 } break;
4521 case ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u): /* fall through */
4522 case ENC_SYM_CUSTOM_TYPE(((0x38) << 4) | 0x00000000u):
4523 lbm_set_error_reason((char *)lbm_error_str_flash_not_possible);
4524 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4525 }
4526 } else {
4527 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4528 }
4529 ctx->app_cont = true1;
4530 return;
4531 }
4532 ctx->r = val;
4533 ctx->app_cont = true1;
4534}
4535
4536static void cont_move_list_to_flash(eval_context_t *ctx) {
4537
4538 // ctx->r holds the value that should go in car
4539
4540 lbm_value *sptr = get_stack_ptr(ctx, 3);
4541
4542 lbm_value fst = sptr[0];
4543 lbm_value lst = sptr[1];
4544 lbm_value val = sptr[2];
4545
4546
4547 lbm_value new_lst = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4548 // Allocate element ptr storage after storing the element to flash.
4549 handle_flash_status(request_flash_storage_cell(lbm_enc_cons_ptr(LBM_PTR_NULL(0x03FFFFFCu >> 2)), &new_lst));
4550
4551 if (lbm_is_symbol_nil(fst)) {
4552 lst = new_lst;
4553 fst = new_lst;
4554 handle_flash_status(write_const_car(lst, ctx->r));
4555 } else {
4556 handle_flash_status(write_const_cdr(lst, new_lst)); // low before high
4557 handle_flash_status(write_const_car(new_lst, ctx->r));
4558 lst = new_lst;
4559 }
4560
4561 if (lbm_is_cons(val)) {
4562 sptr[0] = fst;
4563 sptr[1] = lst;//rest_cell;
4564 sptr[2] = get_cdr(val);
4565 lbm_value *rptr = stack_reserve(ctx, 2);
4566 rptr[0] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4567 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4568 ctx->r = get_car(val);
4569 } else {
4570 sptr[0] = fst;
4571 sptr[1] = lst;
4572 sptr[2] = CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u);
4573 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4574 ctx->r = val;
4575 }
4576 ctx->app_cont = true1;
4577}
4578
4579static void cont_close_list_in_flash(eval_context_t *ctx) {
4580 lbm_value fst;
4581 lbm_value lst;
4582 lbm_pop_2(&ctx->K, &lst, &fst);
4583 lbm_value val = ctx->r;
4584 handle_flash_status(write_const_cdr(lst, val));
4585 ctx->r = fst;
4586 ctx->app_cont = true1;
4587}
4588
4589static void cont_move_array_elts_to_flash(eval_context_t *ctx) {
4590 lbm_value *sptr = get_stack_ptr(ctx, 3);
4591 // sptr[2] = source array in RAM
4592 // sptr[1] = current index
4593 // sptr[0] = target array in flash
4594 lbm_array_header_t *src_arr = (lbm_array_header_t*)get_car(sptr[2]);
4595 lbm_uint size = src_arr->size / sizeof(lbm_uint);
4596 lbm_value *srcdata = (lbm_value *)src_arr->data;
4597
4598 lbm_array_header_t *tgt_arr = (lbm_array_header_t*)get_car(sptr[0]);
4599 lbm_uint *tgtdata = (lbm_value *)tgt_arr->data;
4600 lbm_uint ix = lbm_dec_as_u32(sptr[1]);
4601 handle_flash_status(lbm_const_write(&tgtdata[ix], ctx->r));
4602 if (ix >= size-1) {
4603 ctx->r = sptr[0];
4604 lbm_stack_drop(&ctx->K, 3);
4605 ctx->app_cont = true1;
4606 return;
4607 }
4608 sptr[1] = lbm_enc_u(ix + 1);
4609 lbm_value *rptr = stack_reserve(ctx, 2);
4610 rptr[0] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4611 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4612 ctx->r = srcdata[ix+1];
4613 ctx->app_cont = true1;
4614 return;
4615}
4616
4617static void cont_qq_expand_start(eval_context_t *ctx) {
4618 lbm_value *rptr = stack_reserve(ctx, 2);
4619 rptr[0] = ctx->r;
4620 rptr[1] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4621 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4622 ctx->app_cont = true1;
4623}
4624
4625lbm_value quote_it(lbm_value qquoted) {
4626 if (lbm_is_symbol(qquoted) &&
4627 lbm_is_special(qquoted)) return qquoted;
4628
4629 lbm_value val = cons_with_gc(qquoted, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4630 return cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4631}
4632
4633bool_Bool is_append(lbm_value a) {
4634 return (lbm_is_cons(a) &&
4635 lbm_is_symbol(get_car(a)) &&
4636 (get_car(a) == ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u)));
4637}
4638
4639lbm_value append(lbm_value front, lbm_value back) {
4640 if (lbm_is_symbol_nil(front)) return back;
4641 if (lbm_is_symbol_nil(back)) return front;
4642
4643 if (lbm_is_quoted_list(front) &&
4644 lbm_is_quoted_list(back)) {
4645 lbm_value f = get_cadr(front);
4646 lbm_value b = get_cadr(back);
4647 return quote_it(lbm_list_append(f, b));
4648 }
4649
4650 if (is_append(back) &&
4651 lbm_is_quoted_list(get_cadr(back)) &&
4652 lbm_is_quoted_list(front)) {
4653 lbm_value ql = get_cadr(back);
4654 lbm_value f = get_cadr(front);
4655 lbm_value b = get_cadr(ql);
4656
4657 lbm_value v = lbm_list_append(f, b);
4658 lbm_set_car(get_cdr(ql), v);
4659 return back;
4660 }
4661
4662 if (is_append(back)) {
4663 back = get_cdr(back);
4664 lbm_value new = cons_with_gc(front, back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4665 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), new, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4666 }
4667
4668 lbm_value t0, t1;
4669
4670 t0 = cons_with_gc(back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), front);
4671 t1 = cons_with_gc(front, t0, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4672 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), t1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4673}
4674
4675/* Bawden's qq-expand implementation
4676(define (qq-expand x)
4677 (cond ((tag-comma? x)
4678 (tag-data x))
4679 ((tag-comma-atsign? x)
4680 (error "Illegal"))
4681 ((tag-backquote? x)
4682 (qq-expand
4683 (qq-expand (tag-data x))))
4684 ((pair? x)
4685 `(append
4686 ,(qq-expand-list (car x))
4687 ,(qq-expand (cdr x))))
4688 (else `',x)))
4689 */
4690static void cont_qq_expand(eval_context_t *ctx) {
4691 lbm_value qquoted;
4692 lbm_pop(&ctx->K, &qquoted);
4693
4694 switch(lbm_type_of(qquoted)) {
4695 case LBM_TYPE_CONS0x10000000u: {
4696 lbm_value car_val = get_car(qquoted);
4697 lbm_value cdr_val = get_cdr(qquoted);
4698 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4699 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4700 ctx->r = append(ctx->r, get_car(cdr_val));
4701 ctx->app_cont = true1;
4702 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4703 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4704 error_ctx(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u));
4705 } else {
4706 lbm_value *rptr = stack_reserve(ctx, 6);
4707 rptr[0] = ctx->r;
4708 rptr[1] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4709 rptr[2] = cdr_val;
4710 rptr[3] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4711 rptr[4] = car_val;
4712 rptr[5] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4713 ctx->app_cont = true1;
4714 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4715 }
4716
4717 } break;
4718 default: {
4719 lbm_value res = quote_it(qquoted);
4720 ctx->r = append(ctx->r, res);
4721 ctx->app_cont = true1;
4722 }
4723 }
4724}
4725
4726static void cont_qq_append(eval_context_t *ctx) {
4727 lbm_value head;
4728 lbm_pop(&ctx->K, &head);
4729 ctx->r = append(head, ctx->r);
4730 ctx->app_cont = true1;
4731}
4732
4733/* Bawden's qq-expand-list implementation
4734(define (qq-expand-list x)
4735 (cond ((tag-comma? x)
4736 `(list ,(tag-data x)))
4737 ((tag-comma-atsign? x)
4738 (tag-data x))
4739 ((tag-backquote? x)
4740 (qq-expand-list
4741 (qq-expand (tag-data x))))
4742 ((pair? x)
4743 `(list
4744 (append
4745 ,(qq-expand-list (car x))
4746 ,(qq-expand (cdr x)))))
4747 (else `'(,x))))
4748*/
4749
4750static void cont_qq_expand_list(eval_context_t* ctx) {
4751 lbm_value l;
4752 lbm_pop(&ctx->K, &l);
4753
4754 ctx->app_cont = true1;
4755 switch(lbm_type_of(l)) {
4756 case LBM_TYPE_CONS0x10000000u: {
4757 lbm_value car_val = get_car(l);
4758 lbm_value cdr_val = get_cdr(l);
4759 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4760 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4761 lbm_value tl = cons_with_gc(get_car(cdr_val), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4762 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4763 ctx->r = append(ctx->r, tmp);
4764 return;
4765 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4766 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4767 ctx->r = get_car(cdr_val);
4768 return;
4769 } else {
4770 lbm_value *rptr = stack_reserve(ctx, 7);
4771 rptr[0] = QQ_LIST(((39) << 2) | 0xF8000001u);
4772 rptr[1] = ctx->r;
4773 rptr[2] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4774 rptr[3] = cdr_val;
4775 rptr[4] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4776 rptr[5] = car_val;
4777 rptr[6] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4778 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4779 }
4780
4781 } break;
4782 default: {
4783 lbm_value a_list = cons_with_gc(l, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4784 lbm_value tl = cons_with_gc(a_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4785 lbm_value tmp = cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4786 ctx->r = append(ctx->r, tmp);
4787 }
4788 }
4789}
4790
4791static void cont_qq_list(eval_context_t *ctx) {
4792 lbm_value val = ctx->r;
4793 lbm_value apnd_app = cons_with_gc(val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4794 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), apnd_app, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4795 ctx->r = tmp;
4796 ctx->app_cont = true1;
4797}
4798
4799static void cont_kill(eval_context_t *ctx) {
4800 (void) ctx;
4801 finish_ctx();
4802}
4803
4804static void cont_pop_reader_flags(eval_context_t *ctx) {
4805 lbm_value flags;
4806 lbm_pop(&ctx->K, &flags);
4807 ctx->flags = ctx->flags & ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4808 ctx->flags |= (lbm_dec_as_u32(flags) & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4809 // r is unchanged.
4810 ctx->app_cont = true1;
4811}
4812
4813static void cont_exception_handler(eval_context_t *ctx) {
4814 lbm_value *sptr = pop_stack_ptr(ctx, 2);
4815 lbm_value retval = sptr[0];
4816 lbm_value flags = sptr[1];
4817 lbm_set_car(get_cdr(retval), ctx->r);
4818 ctx->flags = flags;
4819 ctx->r = retval;
4820 ctx->app_cont = true1;
4821}
4822
4823/*********************************************************/
4824/* Continuations table */
4825typedef void (*cont_fun)(eval_context_t *);
4826
4827static const cont_fun continuations[NUM_CONTINUATIONS49] =
4828 { advance_ctx, // CONT_DONE
4829 cont_set_global_env,
4830 cont_bind_to_key_rest,
4831 cont_if,
4832 cont_progn_rest,
4833 cont_application_args,
4834 cont_and,
4835 cont_or,
4836 cont_wait,
4837 cont_match,
4838 cont_application_start,
4839 cont_eval_r,
4840 cont_resume,
4841 cont_closure_application_args,
4842 cont_exit_atomic,
4843 cont_read_next_token,
4844 cont_read_append_continue,
4845 cont_read_eval_continue,
4846 cont_read_expect_closepar,
4847 cont_read_dot_terminate,
4848 cont_read_done,
4849 cont_read_quote_result,
4850 cont_read_commaat_result,
4851 cont_read_comma_result,
4852 cont_read_start_array,
4853 cont_read_append_array,
4854 cont_map,
4855 cont_match_guard,
4856 cont_terminate,
4857 cont_progn_var,
4858 cont_setq,
4859 cont_move_to_flash,
4860 cont_move_val_to_flash_dispatch,
4861 cont_move_list_to_flash,
4862 cont_close_list_in_flash,
4863 cont_qq_expand_start,
4864 cont_qq_expand,
4865 cont_qq_append,
4866 cont_qq_expand_list,
4867 cont_qq_list,
4868 cont_kill,
4869 cont_loop,
4870 cont_loop_condition,
4871 cont_merge_rest,
4872 cont_merge_layer,
4873 cont_closure_args_rest,
4874 cont_move_array_elts_to_flash,
4875 cont_pop_reader_flags,
4876 cont_exception_handler
4877 };
4878
4879/*********************************************************/
4880/* Evaluators lookup table (special forms) */
4881typedef void (*evaluator_fun)(eval_context_t *);
4882
4883static const evaluator_fun evaluators[] =
4884 {
4885 eval_quote,
4886 eval_define,
4887 eval_progn,
4888 eval_lambda,
4889 eval_if,
4890 eval_let,
4891 eval_and,
4892 eval_or,
4893 eval_match,
4894 eval_receive,
4895 eval_receive_timeout,
4896 eval_callcc,
4897 eval_atomic,
4898 eval_selfevaluating, // macro
4899 eval_selfevaluating, // cont
4900 eval_selfevaluating, // closure
4901 eval_cond,
4902 eval_app_cont,
4903 eval_var,
4904 eval_setq,
4905 eval_move_to_flash,
4906 eval_loop,
4907 eval_trap
4908 };
4909
4910
4911/*********************************************************/
4912/* Evaluator step function */
4913
4914static void evaluation_step(void){
4915 eval_context_t *ctx = ctx_running;
4916#ifdef VISUALIZE_HEAP
4917 heap_vis_gen_image();
4918#endif
4919
4920 if (ctx->app_cont) {
12
←
Assuming field 'app_cont' is false
→
13
←
Taking false branch
→
4921 lbm_value k;
4922 lbm_pop(&ctx->K, &k);
4923 ctx->app_cont = false0;
4924
4925 lbm_uint decoded_k = DEC_CONTINUATION(k)(((k) & ~0xF8000001u) >> 2);
4926
4927 if (decoded_k < NUM_CONTINUATIONS49) {
4928 continuations[decoded_k](ctx);
4929 } else {
4930 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4931 }
4932 return;
4933 }
4934
4935 if (lbm_is_symbol(ctx->curr_exp)) {
14
←
Taking true branch
→
4936 eval_symbol(ctx);
15
←
Calling 'eval_symbol'
→
4937 return;
4938 }
4939 if (lbm_is_cons(ctx->curr_exp)) {
4940 lbm_cons_t *cell = lbm_ref_cell(ctx->curr_exp);
4941 lbm_value h = cell->car;
4942 if (lbm_is_symbol(h) && ((h & ENC_SPECIAL_FORMS_MASK0xFFFFF000) == ENC_SPECIAL_FORMS_BIT0x00001000)) {
4943 lbm_uint eval_index = lbm_dec_sym(h) & SPECIAL_FORMS_INDEX_MASK0x000000FF;
4944 evaluators[eval_index](ctx);
4945 return;
4946 }
4947 /*
4948 * At this point head can be anything. It should evaluate
4949 * into a form that can be applied (closure, symbol, ...) though.
4950 */
4951 lbm_value *reserved = stack_reserve(ctx, 3);
4952 reserved[0] = ctx->curr_env;
4953 reserved[1] = cell->cdr;
4954 reserved[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
4955 ctx->curr_exp = h; // evaluate the function
4956 return;
4957 }
4958
4959 eval_selfevaluating(ctx);
4960 return;
4961}
4962
4963void lbm_pause_eval(void ) {
4964 eval_cps_next_state_arg = 0;
4965 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4966 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4967}
4968
4969void lbm_pause_eval_with_gc(uint32_t num_free) {
4970 eval_cps_next_state_arg = num_free;
4971 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4972 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4973}
4974
4975void lbm_continue_eval(void) {
4976 eval_cps_next_state = EVAL_CPS_STATE_RUNNING2;
4977 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4978}
4979
4980void lbm_kill_eval(void) {
4981 eval_cps_next_state = EVAL_CPS_STATE_KILL4;
4982 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4983}
4984
4985uint32_t lbm_get_eval_state(void) {
4986 return eval_cps_run_state;
4987}
4988
4989// Will wake up thread that is sleeping as well.
4990// Not sure this is good behavior.
4991static void handle_event_unblock_ctx(lbm_cid cid, lbm_value v) {
4992 eval_context_t *found = NULL((void*)0);
4993 mutex_lock(&qmutex);
4994
4995 found = lookup_ctx_nm(&blocked, cid);
4996 if (found) {
4997 drop_ctx_nm(&blocked,found);
4998 if (lbm_is_error(v)) {
4999 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
5000 found->app_cont = true1;
5001 }
5002 found->r = v;
5003 enqueue_ctx_nm(&queue,found);
5004 }
5005 mutex_unlock(&qmutex);
5006}
5007
5008static void handle_event_define(lbm_value key, lbm_value val) {
5009 lbm_uint dec_key = lbm_dec_sym(key);
5010 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
5011 lbm_value *global_env = lbm_get_global_env();
5012 lbm_uint orig_env = global_env[ix_key];
5013 lbm_value new_env;
5014 // A key is a symbol and should not need to be remembered.
5015 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
5016
5017 global_env[ix_key] = new_env;
5018}
5019
5020static lbm_value get_event_value(lbm_event_t *e) {
5021 lbm_value v;
5022 if (e->buf_len > 0) {
5023 lbm_flat_value_t fv;
5024 fv.buf = (uint8_t*)e->buf_ptr;
5025 fv.buf_size = e->buf_len;
5026 fv.buf_pos = 0;
5027 if (!lbm_unflatten_value(&fv, &v)) {
5028 lbm_set_flags(LBM_FLAG_HANDLER_EVENT_DELIVERY_FAILED(1 << 1));
5029 v = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
5030 }
5031 // Free the flat value buffer. GC is unaware of its existence.
5032 lbm_free(fv.buf);
5033 } else {
5034 v = (lbm_value)e->buf_ptr;
5035 }
5036 return v;
5037}
5038
5039static void process_events(void) {
5040
5041 if (!lbm_events) return;
5042 lbm_event_t e;
5043
5044 while (lbm_event_pop(&e)) {
5045
5046 lbm_value event_val = get_event_value(&e);
5047 switch(e.type) {
5048 case LBM_EVENT_UNBLOCK_CTX:
5049 handle_event_unblock_ctx((lbm_cid)e.parameter, event_val);
5050 break;
5051 case LBM_EVENT_DEFINE:
5052 handle_event_define((lbm_value)e.parameter, event_val);
5053 break;
5054 case LBM_EVENT_FOR_HANDLER:
5055 if (lbm_event_handler_pid >= 0) {
5056 lbm_find_receiver_and_send(lbm_event_handler_pid, event_val);
5057 }
5058 break;
5059 }
5060 }
5061}
5062
5063/* eval_cps_run can be paused
5064 I think it would be better use a mailbox for
5065 communication between other threads and the run_eval
5066 but for now a set of variables will be used. */
5067void lbm_run_eval(void){
5068
5069 if (setjmp(critical_error_jmp_buf)_setjmp (critical_error_jmp_buf) > 0) {
1
Assuming the condition is false
→
2
←
Taking false branch
→
5070 printf_callback("GC stack overflow!\n");
5071 critical_error_callback();
5072 // terminate evaluation thread.
5073 return;
5074 }
5075
5076 setjmp(error_jmp_buf)_setjmp (error_jmp_buf);
5077
5078 while (eval_running) {
3
←
Loop condition is true. Entering loop body
→
5079 if (eval_cps_state_changed || eval_cps_run_state == EVAL_CPS_STATE_PAUSED1) {
4
←
Assuming 'eval_cps_state_changed' is true
→
5080 eval_cps_state_changed = false0;
5081 switch (eval_cps_next_state) {
5
←
Control jumps to the 'default' case at line 5096
→
5082 case EVAL_CPS_STATE_PAUSED1:
5083 if (eval_cps_run_state != EVAL_CPS_STATE_PAUSED1) {
5084 if (lbm_heap_num_free() < eval_cps_next_state_arg) {
5085 gc();
5086 }
5087 eval_cps_next_state_arg = 0;
5088 }
5089 eval_cps_run_state = EVAL_CPS_STATE_PAUSED1;
5090 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5091 continue; /* jump back to start of eval_running loop */
5092 case EVAL_CPS_STATE_KILL4:
5093 eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
5094 eval_running = false0;
5095 continue;
5096 default: // running state
5097 eval_cps_run_state = eval_cps_next_state;
5098 break;
6
←
 Execution continues on line 5101
→
5099 }
5100 }
5101 while (true1) {
7
←
Loop condition is true. Entering loop body
→
5102 if (eval_steps_quota && ctx_running) {
8
←
Assuming 'eval_steps_quota' is not equal to 0
→
9
←
Assuming 'ctx_running' is non-null
→
10
←
Taking true branch
→
5103 eval_steps_quota--;
5104 evaluation_step();
11
←
Calling 'evaluation_step'
→
5105 } else {
5106 if (eval_cps_state_changed) break;
5107 eval_steps_quota = eval_steps_refill;
5108 if (is_atomic) {
5109 if (!ctx_running) {
5110 lbm_set_flags(LBM_FLAG_ATOMIC_MALFUNCTION(1 << 0));
5111 is_atomic = 0;
5112 }
5113 } else {
5114 if (gc_requested) {
5115 gc();
5116 }
5117 process_events();
5118 mutex_lock(&qmutex);
5119 if (ctx_running) {
5120 enqueue_ctx_nm(&queue, ctx_running);
5121 ctx_running = NULL((void*)0);
5122 }
5123 wake_up_ctxs_nm();
5124 ctx_running = dequeue_ctx_nm(&queue);
5125 mutex_unlock(&qmutex);
5126 if (!ctx_running) {
5127 lbm_system_sleeping = true1;
5128 //Fixed sleep interval to poll events regularly.
5129 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5130 lbm_system_sleeping = false0;
5131 }
5132 }
5133 }
5134 }
5135 }
5136}
5137
5138lbm_cid lbm_eval_program(lbm_value lisp) {
5139 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), 256, NULL((void*)0));
5140}
5141
5142lbm_cid lbm_eval_program_ext(lbm_value lisp, unsigned int stack_size) {
5143 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), stack_size, NULL((void*)0));
5144}
5145
5146int lbm_eval_init() {
5147 if (!qmutex_initialized) {
5148 mutex_init(&qmutex);
5149 qmutex_initialized = true1;
5150 }
5151 if (!lbm_events_mutex_initialized) {
5152 mutex_init(&lbm_events_mutex);
5153 lbm_events_mutex_initialized = true1;
5154 }
5155 if (!blocking_extension_mutex_initialized) {
5156 mutex_init(&blocking_extension_mutex);
5157 blocking_extension_mutex_initialized = true1;
5158 }
5159
5160 mutex_lock(&qmutex);
5161 mutex_lock(&lbm_events_mutex);
5162
5163 blocked.first = NULL((void*)0);
5164 blocked.last = NULL((void*)0);
5165 queue.first = NULL((void*)0);
5166 queue.last = NULL((void*)0);
5167 ctx_running = NULL((void*)0);
5168
5169 eval_cps_run_state = EVAL_CPS_STATE_RUNNING2;
5170
5171 mutex_unlock(&lbm_events_mutex);
5172 mutex_unlock(&qmutex);
5173
5174 if (!lbm_init_env()) return 0;
5175 eval_running = true1;
5176 return 1;
5177}
5178
5179bool_Bool lbm_eval_init_events(unsigned int num_events) {
5180
5181 mutex_lock(&lbm_events_mutex);
5182 lbm_events = (lbm_event_t*)lbm_malloc(num_events * sizeof(lbm_event_t));
5183 bool_Bool r = false0;
5184 if (lbm_events) {
5185 lbm_events_max = num_events;
5186 lbm_events_head = 0;
5187 lbm_events_tail = 0;
5188 lbm_events_full = false0;
5189 lbm_event_handler_pid = -1;
5190 r = true1;
5191 }
5192 mutex_unlock(&lbm_events_mutex);
5193 return r;
5194}
diff --git a/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-4accd4.html b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-4accd4.html new file mode 100644 index 00000000..0a72c2c5 --- /dev/null +++ b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-4accd4.html @@ -0,0 +1,5548 @@ + + + +src/eval_cps.c + + + + + + + + + + + + + + + + + + + + + + + + + + +

Bug Summary

+ + + + +
File:eval_cps.c
Warning:line 2989, column 16
1st function call argument is an uninitialized value
+ +

Annotated Source Code

+

Press '?' + to see keyboard shortcuts

+ + +
clang -cc1 -triple i386-pc-linux-gnu -analyze -disable-free -disable-llvm-verifier -discard-value-names -main-file-name eval_cps.c -analyzer-store=region -analyzer-opt-analyze-nested-blocks -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -mrelocation-model static -mthread-model posix -mframe-pointer=none -fmath-errno -fno-rounding-math -masm-verbose -mconstructor-aliases -target-cpu i686 -dwarf-column-info -fno-split-dwarf-inlining -debugger-tuning=gdb -resource-dir /usr/lib/llvm-10/lib/clang/10.0.0 -I ./include -I ./include/extensions -I platform/linux/include -D _PRELUDE -internal-isystem /usr/local/include -internal-isystem /usr/lib/llvm-10/lib/clang/10.0.0/include -internal-externc-isystem /usr/include/i386-linux-gnu -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -std=c99 -fdebug-compilation-dir /home/joels/Current/lispbm -ferror-limit 19 -fmessage-length 0 -fgnuc-version=4.2.1 -fobjc-runtime=gcc -fdiagnostics-show-option -vectorize-loops -vectorize-slp -analyzer-output=html -faddrsig -o /home/joels/Current/lispbm/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1 -x c src/eval_cps.c +
+ + + +
+ + +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1/*
2 Copyright 2018, 2020 - 2024 Joel Svensson svenssonjoel@yahoo.se
3
4 This program is free software: you can redistribute it and/or modify
5 it under the terms of the GNU General Public License as published by
6 the Free Software Foundation, either version 3 of the License, or
7 (at your option) any later version.
8
9 This program is distributed in the hope that it will be useful,
10 but WITHOUT ANY WARRANTY; without even the implied warranty of
11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 GNU General Public License for more details.
13
14 You should have received a copy of the GNU General Public License
15 along with this program. If not, see <http://www.gnu.org/licenses/>.
16*/
17
18#include <lbm_memory.h>
19#include <lbm_types.h>
20#include "symrepr.h"
21#include "heap.h"
22#include "env.h"
23#include "eval_cps.h"
24#include "stack.h"
25#include "fundamental.h"
26#include "extensions.h"
27#include "tokpar.h"
28#include "lbm_channel.h"
29#include "print.h"
30#include "platform_mutex.h"
31#include "lbm_flat_value.h"
32#include "lbm_flags.h"
33
34#ifdef VISUALIZE_HEAP
35#include "heap_vis.h"
36#endif
37
38#include <setjmp.h>
39#include <stdarg.h>
40
41static jmp_buf error_jmp_buf;
42static jmp_buf critical_error_jmp_buf;
43
44#define S_TO_US(X)(lbm_uint)((X) * 1000000) (lbm_uint)((X) * 1000000)
45
46#define DEC_CONTINUATION(x)(((x) & ~0xF8000001u) >> 2) (((x) & ~LBM_CONTINUATION_INTERNAL0xF8000001u) >> LBM_ADDRESS_SHIFT2)
47#define IS_CONTINUATION(x)(((x) & 0xF8000001u) == 0xF8000001u) (((x) & LBM_CONTINUATION_INTERNAL0xF8000001u) == LBM_CONTINUATION_INTERNAL0xF8000001u)
48#define CONTINUATION(x)(((x) << 2) | 0xF8000001u) (((x) << LBM_ADDRESS_SHIFT2) | LBM_CONTINUATION_INTERNAL0xF8000001u)
49
50#define DONE(((0) << 2) | 0xF8000001u) CONTINUATION(0)(((0) << 2) | 0xF8000001u)
51#define SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u) CONTINUATION(1)(((1) << 2) | 0xF8000001u)
52#define BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u) CONTINUATION(2)(((2) << 2) | 0xF8000001u)
53#define IF(((3) << 2) | 0xF8000001u) CONTINUATION(3)(((3) << 2) | 0xF8000001u)
54#define PROGN_REST(((4) << 2) | 0xF8000001u) CONTINUATION(4)(((4) << 2) | 0xF8000001u)
55#define APPLICATION_ARGS(((5) << 2) | 0xF8000001u) CONTINUATION(5)(((5) << 2) | 0xF8000001u)
56#define AND(((6) << 2) | 0xF8000001u) CONTINUATION(6)(((6) << 2) | 0xF8000001u)
57#define OR(((7) << 2) | 0xF8000001u) CONTINUATION(7)(((7) << 2) | 0xF8000001u)
58#define WAIT(((8) << 2) | 0xF8000001u) CONTINUATION(8)(((8) << 2) | 0xF8000001u)
59#define MATCH(((9) << 2) | 0xF8000001u) CONTINUATION(9)(((9) << 2) | 0xF8000001u)
60#define APPLICATION_START(((10) << 2) | 0xF8000001u) CONTINUATION(10)(((10) << 2) | 0xF8000001u)
61#define EVAL_R(((11) << 2) | 0xF8000001u) CONTINUATION(11)(((11) << 2) | 0xF8000001u)
62#define RESUME(((12) << 2) | 0xF8000001u) CONTINUATION(12)(((12) << 2) | 0xF8000001u)
63#define CLOSURE_ARGS(((13) << 2) | 0xF8000001u) CONTINUATION(13)(((13) << 2) | 0xF8000001u)
64#define EXIT_ATOMIC(((14) << 2) | 0xF8000001u) CONTINUATION(14)(((14) << 2) | 0xF8000001u)
65#define READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u) CONTINUATION(15)(((15) << 2) | 0xF8000001u)
66#define READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u) CONTINUATION(16)(((16) << 2) | 0xF8000001u)
67#define READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u) CONTINUATION(17)(((17) << 2) | 0xF8000001u)
68#define READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u) CONTINUATION(18)(((18) << 2) | 0xF8000001u)
69#define READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u) CONTINUATION(19)(((19) << 2) | 0xF8000001u)
70#define READ_DONE(((20) << 2) | 0xF8000001u) CONTINUATION(20)(((20) << 2) | 0xF8000001u)
71#define READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u) CONTINUATION(21)(((21) << 2) | 0xF8000001u)
72#define READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u) CONTINUATION(22)(((22) << 2) | 0xF8000001u)
73#define READ_COMMA_RESULT(((23) << 2) | 0xF8000001u) CONTINUATION(23)(((23) << 2) | 0xF8000001u)
74#define READ_START_ARRAY(((24) << 2) | 0xF8000001u) CONTINUATION(24)(((24) << 2) | 0xF8000001u)
75#define READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u) CONTINUATION(25)(((25) << 2) | 0xF8000001u)
76#define MAP(((26) << 2) | 0xF8000001u) CONTINUATION(26)(((26) << 2) | 0xF8000001u)
77#define MATCH_GUARD(((27) << 2) | 0xF8000001u) CONTINUATION(27)(((27) << 2) | 0xF8000001u)
78#define TERMINATE(((28) << 2) | 0xF8000001u) CONTINUATION(28)(((28) << 2) | 0xF8000001u)
79#define PROGN_VAR(((29) << 2) | 0xF8000001u) CONTINUATION(29)(((29) << 2) | 0xF8000001u)
80#define SETQ(((30) << 2) | 0xF8000001u) CONTINUATION(30)(((30) << 2) | 0xF8000001u)
81#define MOVE_TO_FLASH(((31) << 2) | 0xF8000001u) CONTINUATION(31)(((31) << 2) | 0xF8000001u)
82#define MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u) CONTINUATION(32)(((32) << 2) | 0xF8000001u)
83#define MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u) CONTINUATION(33)(((33) << 2) | 0xF8000001u)
84#define CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u) CONTINUATION(34)(((34) << 2) | 0xF8000001u)
85#define QQ_EXPAND_START(((35) << 2) | 0xF8000001u) CONTINUATION(35)(((35) << 2) | 0xF8000001u)
86#define QQ_EXPAND(((36) << 2) | 0xF8000001u) CONTINUATION(36)(((36) << 2) | 0xF8000001u)
87#define QQ_APPEND(((37) << 2) | 0xF8000001u) CONTINUATION(37)(((37) << 2) | 0xF8000001u)
88#define QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u) CONTINUATION(38)(((38) << 2) | 0xF8000001u)
89#define QQ_LIST(((39) << 2) | 0xF8000001u) CONTINUATION(39)(((39) << 2) | 0xF8000001u)
90#define KILL(((40) << 2) | 0xF8000001u) CONTINUATION(40)(((40) << 2) | 0xF8000001u)
91#define LOOP(((41) << 2) | 0xF8000001u) CONTINUATION(41)(((41) << 2) | 0xF8000001u)
92#define LOOP_CONDITION(((42) << 2) | 0xF8000001u) CONTINUATION(42)(((42) << 2) | 0xF8000001u)
93#define MERGE_REST(((43) << 2) | 0xF8000001u) CONTINUATION(43)(((43) << 2) | 0xF8000001u)
94#define MERGE_LAYER(((44) << 2) | 0xF8000001u) CONTINUATION(44)(((44) << 2) | 0xF8000001u)
95#define CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u) CONTINUATION(45)(((45) << 2) | 0xF8000001u)
96#define MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u) CONTINUATION(46)(((46) << 2) | 0xF8000001u)
97#define POP_READER_FLAGS(((47) << 2) | 0xF8000001u) CONTINUATION(47)(((47) << 2) | 0xF8000001u)
98#define EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u) CONTINUATION(48)(((48) << 2) | 0xF8000001u)
99#define NUM_CONTINUATIONS49 49
100
101#define FM_NEED_GC-1 -1
102#define FM_NO_MATCH-2 -2
103#define FM_PATTERN_ERROR-3 -3
104
105typedef enum {
106 BL_OK = 0,
107 BL_NO_MEMORY,
108 BL_INCORRECT_KEY
109} binding_location_status;
110
111#define FB_OK0 0
112#define FB_TYPE_ERROR-1 -1
113
114const char* lbm_error_str_parse_eof = "End of parse stream.";
115const char* lbm_error_str_parse_dot = "Incorrect usage of '.'.";
116const char* lbm_error_str_parse_close = "Expected closing parenthesis.";
117const char* lbm_error_str_num_args = "Incorrect number of arguments.";
118const char* lbm_error_str_forbidden_in_atomic = "Operation is forbidden in an atomic block.";
119const char* lbm_error_str_no_number = "Argument(s) must be a number.";
120const char* lbm_error_str_not_a_boolean = "Argument must be t or nil (true or false).";
121const char* lbm_error_str_incorrect_arg = "Incorrect argument.";
122const char* lbm_error_str_var_outside_progn = "Usage of var outside of progn.";
123const char* lbm_error_str_flash_not_possible = "Value cannot be written to flash.";
124const char* lbm_error_str_flash_error = "Error writing to flash.";
125const char* lbm_error_str_flash_full = "Flash memory is full.";
126const char* lbm_error_str_variable_not_bound = "Variable not bound.";
127
128static lbm_value lbm_error_suspect;
129static bool_Bool lbm_error_has_suspect = false0;
130#ifdef LBM_ALWAYS_GC
131
132#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
133 gc(); \
134 (y) = (x); \
135 if (lbm_is_symbol_merror((y))) { \
136 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
137 }
138
139#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
140 lbm_gc_mark_phase(r); \
141 gc(); \
142 (y) = (x); \
143 if (lbm_is_symbol_merror((y))) { \
144 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
145 }
146
147#else
148
149#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
150 (y) = (x); \
151 if (lbm_is_symbol_merror((y))) { \
152 gc(); \
153 (y) = (x); \
154 if (lbm_is_symbol_merror((y))) { \
155 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
156 } \
157 /* continue executing statements below */ \
158 }
159#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
160 (y) = (x); \
161 if (lbm_is_symbol_merror((y))) { \
162 lbm_gc_mark_phase(r); \
163 gc(); \
164 (y) = (x); \
165 if (lbm_is_symbol_merror((y))) { \
166 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
167 } \
168 /* continue executing statements below */ \
169 }
170
171#endif
172
173typedef struct {
174 eval_context_t *first;
175 eval_context_t *last;
176} eval_context_queue_t;
177
178#ifdef CLEAN_UP_CLOSURES
179static lbm_value clean_cl_env_symbol = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
180#endif
181
182static int gc(void);
183static void error_ctx(lbm_value);
184static void error_at_ctx(lbm_value err_val, lbm_value at);
185static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx);
186static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail);
187
188// The currently executing context.
189eval_context_t *ctx_running = NULL((void*)0);
190volatile bool_Bool lbm_system_sleeping = false0;
191
192static volatile bool_Bool gc_requested = false0;
193void lbm_request_gc(void) {
194 gc_requested = true1;
195}
196
197/*
198 On ChibiOs the CH_CFG_ST_FREQUENCY setting in chconf.h sets the
199 resolution of the timer used for sleep operations. If this is set
200 to 10KHz the resolution is 100us.
201
202 The CH_CFG_ST_TIMEDELTA specifies the minimum number of ticks that
203 can be safely specified in a timeout directive (wonder if that
204 means sleep-period). The timedelta is set to 2.
205
206 If I have understood these correctly it means that the minimum
207 sleep duration possible is 2 * 100us = 200us.
208*/
209
210#define EVAL_CPS_DEFAULT_STACK_SIZE256 256
211#define EVAL_CPS_MIN_SLEEP200 200
212#define EVAL_STEPS_QUOTA10 10
213
214static volatile uint32_t eval_steps_refill = EVAL_STEPS_QUOTA10;
215static uint32_t eval_steps_quota = EVAL_STEPS_QUOTA10;
216
217void lbm_set_eval_step_quota(uint32_t quota) {
218 eval_steps_refill = quota;
219}
220
221static uint32_t eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
222static volatile uint32_t eval_cps_next_state = EVAL_CPS_STATE_NONE0;
223static volatile uint32_t eval_cps_next_state_arg = 0;
224static volatile bool_Bool eval_cps_state_changed = false0;
225
226static void usleep_nonsense(uint32_t us) {
227 (void) us;
228}
229
230static bool_Bool dynamic_load_nonsense(const char *sym, const char **code) {
231 (void) sym;
232 (void) code;
233 return false0;
234}
235
236static uint32_t timestamp_nonsense(void) {
237 return 0;
238}
239
240static int printf_nonsense(const char *fmt, ...) {
241 (void) fmt;
242 return 0;
243}
244
245static void ctx_done_nonsense(eval_context_t *ctx) {
246 (void) ctx;
247}
248
249static void critical_nonsense(void) {
250 return;
251}
252
253static void (*critical_error_callback)(void) = critical_nonsense;
254static void (*usleep_callback)(uint32_t) = usleep_nonsense;
255static uint32_t (*timestamp_us_callback)(void) = timestamp_nonsense;
256static void (*ctx_done_callback)(eval_context_t *) = ctx_done_nonsense;
257static int (*printf_callback)(const char *, ...) = printf_nonsense;
258static bool_Bool (*dynamic_load_callback)(const char *, const char **) = dynamic_load_nonsense;
259
260void lbm_set_critical_error_callback(void (*fptr)(void)) {
261 if (fptr == NULL((void*)0)) critical_error_callback = critical_nonsense;
262 else critical_error_callback = fptr;
263}
264
265void lbm_set_usleep_callback(void (*fptr)(uint32_t)) {
266 if (fptr == NULL((void*)0)) usleep_callback = usleep_nonsense;
267 else usleep_callback = fptr;
268}
269
270void lbm_set_timestamp_us_callback(uint32_t (*fptr)(void)) {
271 if (fptr == NULL((void*)0)) timestamp_us_callback = timestamp_nonsense;
272 else timestamp_us_callback = fptr;
273}
274
275void lbm_set_ctx_done_callback(void (*fptr)(eval_context_t *)) {
276 if (fptr == NULL((void*)0)) ctx_done_callback = ctx_done_nonsense;
277 else ctx_done_callback = fptr;
278}
279
280void lbm_set_printf_callback(int (*fptr)(const char*, ...)){
281 if (fptr == NULL((void*)0)) printf_callback = printf_nonsense;
282 else printf_callback = fptr;
283}
284
285void lbm_set_dynamic_load_callback(bool_Bool (*fptr)(const char *, const char **)) {
286 if (fptr == NULL((void*)0)) dynamic_load_callback = dynamic_load_nonsense;
287 else dynamic_load_callback = fptr;
288}
289
290static volatile lbm_event_t *lbm_events = NULL((void*)0);
291static unsigned int lbm_events_head = 0;
292static unsigned int lbm_events_tail = 0;
293static unsigned int lbm_events_max = 0;
294static bool_Bool lbm_events_full = false0;
295static mutex_t lbm_events_mutex;
296static bool_Bool lbm_events_mutex_initialized = false0;
297static volatile lbm_cid lbm_event_handler_pid = -1;
298
299lbm_cid lbm_get_event_handler_pid(void) {
300 return lbm_event_handler_pid;
301}
302
303void lbm_set_event_handler_pid(lbm_cid pid) {
304 lbm_event_handler_pid = pid;
305}
306
307bool_Bool lbm_event_handler_exists(void) {
308 return(lbm_event_handler_pid > 0);
309}
310
311
312static bool_Bool event_internal(lbm_event_type_t event_type, lbm_uint parameter, lbm_uint buf_ptr, lbm_uint buf_len) {
313 bool_Bool r = false0;
314 if (lbm_events) {
315 mutex_lock(&lbm_events_mutex);
316 if (!lbm_events_full) {
317 lbm_event_t event;
318 event.type = event_type;
319 event.parameter = parameter;
320 event.buf_ptr = buf_ptr;
321 event.buf_len = buf_len;
322 lbm_events[lbm_events_head] = event;
323 lbm_events_head = (lbm_events_head + 1) % lbm_events_max;
324 lbm_events_full = lbm_events_head == lbm_events_tail;
325 r = true1;
326 }
327 mutex_unlock(&lbm_events_mutex);
328 }
329 return r;
330}
331
332bool_Bool lbm_event_define(lbm_value key, lbm_flat_value_t *fv) {
333 return event_internal(LBM_EVENT_DEFINE, key, (lbm_uint)fv->buf, fv->buf_size);
334}
335
336bool_Bool lbm_event_unboxed(lbm_value unboxed) {
337 lbm_uint t = lbm_type_of(unboxed);
338 if (t == LBM_TYPE_SYMBOL0x00000000u ||
339 t == LBM_TYPE_I0x00000008u ||
340 t == LBM_TYPE_U0x0000000Cu ||
341 t == LBM_TYPE_CHAR0x00000004u) {
342 if (lbm_event_handler_pid > 0) {
343 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)unboxed, 0);
344 }
345 }
346 return false0;
347}
348
349bool_Bool lbm_event(lbm_flat_value_t *fv) {
350 if (lbm_event_handler_pid > 0) {
351 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)fv->buf, fv->buf_size);
352 }
353 return false0;
354}
355
356static bool_Bool lbm_event_pop(lbm_event_t *event) {
357 mutex_lock(&lbm_events_mutex);
358 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
359 mutex_unlock(&lbm_events_mutex);
360 return false0;
361 }
362 *event = lbm_events[lbm_events_tail];
363 lbm_events_tail = (lbm_events_tail + 1) % lbm_events_max;
364 lbm_events_full = false0;
365 mutex_unlock(&lbm_events_mutex);
366 return true1;
367}
368
369bool_Bool lbm_event_queue_is_empty(void) {
370 mutex_lock(&lbm_events_mutex);
371 bool_Bool empty = false0;
372 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
373 empty = true1;
374 }
375 mutex_unlock(&lbm_events_mutex);
376 return empty;
377}
378
379static bool_Bool eval_running = false0;
380static volatile bool_Bool blocking_extension = false0;
381static mutex_t blocking_extension_mutex;
382static bool_Bool blocking_extension_mutex_initialized = false0;
383static lbm_uint blocking_extension_timeout_us = 0;
384static bool_Bool blocking_extension_timeout = false0;
385
386static uint32_t is_atomic = 0;
387
388/* Process queues */
389static eval_context_queue_t blocked = {NULL((void*)0), NULL((void*)0)};
390static eval_context_queue_t queue = {NULL((void*)0), NULL((void*)0)};
391
392/* one mutex for all queue operations */
393mutex_t qmutex;
394bool_Bool qmutex_initialized = false0;
395
396
397// MODES
398static volatile bool_Bool lbm_verbose = false0;
399
400void lbm_toggle_verbose(void) {
401 lbm_verbose = !lbm_verbose;
402}
403
404void lbm_set_verbose(bool_Bool verbose) {
405 lbm_verbose = verbose;
406}
407
408lbm_cid lbm_get_current_cid(void) {
409 if (ctx_running)
410 return ctx_running->id;
411 else
412 return -1;
413}
414
415eval_context_t *lbm_get_current_context(void) {
416 return ctx_running;
417}
418
419/****************************************************/
420/* Utilities used locally in this file */
421
422static lbm_value cons_with_gc(lbm_value head, lbm_value tail, lbm_value remember) {
423#ifdef LBM_ALWAYS_GC
424 lbm_value roots[3] = {head, tail, remember};
425 lbm_gc_mark_roots(roots, 3);
426 gc();
427 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
428 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
429 if (lbm_is_symbol_merror(res)) {
430 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
431 }
432 return res;
433#else
434 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
435 if (lbm_is_symbol_merror(res)) {
436 lbm_value roots[3] = {head, tail, remember};
437 lbm_gc_mark_roots(roots,3);
438 gc();
439 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
440 if (lbm_is_symbol_merror(res)) {
441 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
442 }
443 }
444 return res;
445#endif
446}
447
448static lbm_uint *get_stack_ptr(eval_context_t *ctx, unsigned int n) {
449 if (n <= ctx->K.sp) {
450 lbm_uint index = ctx->K.sp - n;
451 return &ctx->K.data[index];
452 }
453 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
454 return 0; // dead code cannot be reached, but C compiler doesn't realise.
455}
456
457// pop_stack_ptr is safe when no GC is performed and
458// the values of the stack will be dropped.
459static lbm_uint *pop_stack_ptr(eval_context_t *ctx, unsigned int n) {
460 if (n <= ctx->K.sp) {
461 ctx->K.sp -= n;
462 return &ctx->K.data[ctx->K.sp];
463 }
464 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
465 return 0; // dead code cannot be reached, but C compiler doesn't realise.
466}
467
468static inline lbm_uint *stack_reserve(eval_context_t *ctx, unsigned int n) {
469 if (ctx->K.sp + n < ctx->K.size) {
470 lbm_uint *ptr = &ctx->K.data[ctx->K.sp];
471 ctx->K.sp += n;
472 return ptr;
473 }
474 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
475 return 0; // dead code cannot be reached, but C compiler doesn't realise.
476}
477
478static void handle_flash_status(lbm_flash_status s) {
479 if ( s == LBM_FLASH_FULL) {
480 lbm_set_error_reason((char*)lbm_error_str_flash_full);
481 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
482 }
483 if (s == LBM_FLASH_WRITE_ERROR) {
484 lbm_set_error_reason((char*)lbm_error_str_flash_error);
485 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
486 }
487}
488
489static void lift_array_flash(lbm_value flash_cell, bool_Bool bytearray, char *data, lbm_uint num_elt) {
490
491 lbm_array_header_t flash_array_header;
492 flash_array_header.size = num_elt;
493 flash_array_header.data = (lbm_uint*)data;
494 lbm_uint flash_array_header_ptr;
495 handle_flash_status(lbm_write_const_raw((lbm_uint*)&flash_array_header,
496 sizeof(lbm_array_header_t) / sizeof(lbm_uint),
497 &flash_array_header_ptr));
498 handle_flash_status(write_const_car(flash_cell, flash_array_header_ptr));
499 lbm_uint t = bytearray ? ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u) : ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u);
500 handle_flash_status(write_const_cdr(flash_cell, t));
501}
502
503static void get_car_and_cdr(lbm_value a, lbm_value *a_car, lbm_value *a_cdr) {
504 if (lbm_is_ptr(a)) {
3
←
Assuming the condition is false
→
4
←
Taking false branch
→
505 lbm_cons_t *cell = lbm_ref_cell(a);
506 *a_car = cell->car;
507 *a_cdr = cell->cdr;
508 } else if (lbm_is_symbol_nil(a)) {
5
←
Taking false branch
→
509 *a_car = *a_cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
510 } else {
511 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
512 }
513}
6
←
Returning without writing to '*a_cdr'
→
514
515/* car cdr caar cadr replacements that are evaluator safe. */
516static lbm_value get_car(lbm_value a) {
517 if (lbm_is_ptr(a)) {
518 lbm_cons_t *cell = lbm_ref_cell(a);
519 return cell->car;
520 } else if (lbm_is_symbol_nil(a)) {
521 return a;
522 }
523 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
524 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
525}
526
527static lbm_value get_cdr(lbm_value a) {
528 if (lbm_is_ptr(a)) {
529 lbm_cons_t *cell = lbm_ref_cell(a);
530 return cell->cdr;
531 } else if (lbm_is_symbol_nil(a)) {
532 return a;
533 }
534 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
535 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
536}
537
538static lbm_value get_cadr(lbm_value a) {
539 if (lbm_is_ptr(a)) {
540 lbm_cons_t *cell = lbm_ref_cell(a);
541 lbm_value tmp = cell->cdr;
542 if (lbm_is_ptr(tmp)) {
543 return lbm_ref_cell(tmp)->car;
544 } else if (lbm_is_symbol_nil(tmp)) {
545 return tmp;
546 }
547 } else if (lbm_is_symbol_nil(a)) {
548 return a;
549 }
550 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
551 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
552}
553
554static lbm_value allocate_closure(lbm_value params, lbm_value body, lbm_value env) {
555
556#ifdef LBM_ALWAYS_GC
557 gc();
558 if (lbm_heap_num_free() < 4) {
559 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
560 }
561#else
562 if (lbm_heap_num_free() < 4) {
563 gc();
564 if (lbm_heap_num_free() < 4) {
565 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
566 }
567 }
568#endif
569 // The freelist will always contain just plain heap-cells.
570 // So dec_ptr is sufficient.
571 lbm_value res = lbm_heap_state.freelist;
572 if (lbm_type_of(res) == LBM_TYPE_CONS0x10000000u) {
573 lbm_cons_t *heap = lbm_heap_state.heap;
574 lbm_uint ix = lbm_dec_ptr(res);
575 heap[ix].car = ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u);
576 ix = lbm_dec_ptr(heap[ix].cdr);
577 heap[ix].car = params;
578 ix = lbm_dec_ptr(heap[ix].cdr);
579 heap[ix].car = body;
580 ix = lbm_dec_ptr(heap[ix].cdr);
581 heap[ix].car = env;
582 lbm_heap_state.freelist = heap[ix].cdr;
583 heap[ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
584 lbm_heap_state.num_alloc+=4;
585 } else {
586 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
587 }
588 return res;
589}
590
591// Allocate a binding and attach it to a list (if so desired)
592static lbm_value allocate_binding(lbm_value key, lbm_value val, lbm_value the_cdr) {
593 if (lbm_heap_num_free() < 2) {
594 gc();
595 if (lbm_heap_num_free() < 2) {
596 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
597 }
598 }
599 lbm_cons_t* heap = lbm_heap_state.heap;
600 lbm_value binding_cell = lbm_heap_state.freelist;
601 lbm_uint binding_cell_ix = lbm_dec_ptr(binding_cell);
602 lbm_value list_cell = heap[binding_cell_ix].cdr;
603 lbm_uint list_cell_ix = lbm_dec_ptr(list_cell);
604 lbm_heap_state.freelist = heap[list_cell_ix].cdr;
605 lbm_heap_state.num_alloc += 2;
606 heap[binding_cell_ix].car = key;
607 heap[binding_cell_ix].cdr = val;
608 heap[list_cell_ix].car = binding_cell;
609 heap[list_cell_ix].cdr = the_cdr;
610 return list_cell;
611}
612
613#define CLO_PARAMS0 0
614#define CLO_BODY1 1
615#define CLO_ENV2 2
616#define LOOP_BINDS0 0
617#define LOOP_COND1 1
618#define LOOP_BODY2 2
619
620// (a b c) -> [a b c]
621static lbm_value extract_n(lbm_value curr, lbm_value *res, unsigned int n) {
622 for (unsigned int i = 0; i < n; i ++) {
623 if (lbm_is_ptr(curr)) {
624 lbm_cons_t *cell = lbm_ref_cell(curr);
625 res[i] = cell->car;
626 curr = cell->cdr;
627 } else {
628 res[i] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
629 }
630 }
631 return curr; // Rest of list is returned here.
632}
633
634static void call_fundamental(lbm_uint fundamental, lbm_value *args, lbm_uint arg_count, eval_context_t *ctx) {
635 lbm_value res;
636 res = fundamental_table[fundamental](args, arg_count, ctx);
637 if (lbm_is_error(res)) {
638 if (lbm_is_symbol_merror(res)) {
639 gc();
640 res = fundamental_table[fundamental](args, arg_count, ctx);
641 }
642 if (lbm_is_error(res)) {
643 error_at_ctx(res, lbm_enc_sym(FUNDAMENTAL_SYMBOLS_START0x20000 | fundamental));
644 }
645 }
646 lbm_stack_drop(&ctx->K, arg_count+1);
647 ctx->app_cont = true1;
648 ctx->r = res;
649}
650
651// block_current_ctx blocks a context until it is
652// woken up externally or a timeout period of time passes.
653static void block_current_ctx(uint32_t state, lbm_uint sleep_us, bool_Bool do_cont) {
654 ctx_running->timestamp = timestamp_us_callback();
655 ctx_running->sleep_us = sleep_us;
656 ctx_running->state = state;
657 ctx_running->app_cont = do_cont;
658 enqueue_ctx(&blocked, ctx_running);
659 ctx_running = NULL((void*)0);
660}
661
662lbm_flash_status lbm_write_const_array_padded(uint8_t *data, lbm_uint n, lbm_uint *res) {
663 lbm_uint full_words = n / sizeof(lbm_uint);
664 lbm_uint n_mod = n % sizeof(lbm_uint);
665
666 if (n_mod == 0) { // perfect fit.
667 return lbm_write_const_raw((lbm_uint*)data, full_words, res);
668 } else {
669 lbm_uint last_word = 0;
670 memcpy(&last_word, &data[full_words * sizeof(lbm_uint)], n_mod);
671 if (full_words >= 1) {
672 lbm_flash_status s = lbm_write_const_raw((lbm_uint*)data, full_words, res);
673 if ( s == LBM_FLASH_WRITE_OK) {
674 lbm_uint dummy;
675 s = lbm_write_const_raw(&last_word, 1, &dummy);
676 }
677 return s;
678 } else {
679 return lbm_write_const_raw(&last_word, 1, res);
680 }
681 }
682}
683
684/****************************************************/
685/* Error message creation */
686
687#define ERROR_MESSAGE_BUFFER_SIZE_BYTES256 256
688
689void print_environments(char *buf, unsigned int size) {
690
691 lbm_value curr_l = ctx_running->curr_env;
692 printf_callback("\tCurrent local environment:\n");
693 while (lbm_type_of(curr_l) == LBM_TYPE_CONS0x10000000u) {
694 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_l));
695 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_l)));
696 printf_callback("\t%s = %s\n", buf, buf+(size/2));
697 curr_l = lbm_cdr(curr_l);
698 }
699 printf_callback("\n\n");
700 printf_callback("\tCurrent global environment:\n");
701 lbm_value *glob_env = lbm_get_global_env();
702
703 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
704 lbm_value curr_g = glob_env[i];;
705 while (lbm_type_of(curr_g) == LBM_TYPE_CONS0x10000000u) {
706
707 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_g));
708 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_g)));
709 printf_callback("\t%s = %s\n", buf, buf+(size/2));
710 curr_g = lbm_cdr(curr_g);
711 }
712 }
713}
714
715void print_error_message(lbm_value error, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int col, lbm_int row0, lbm_int row1) {
716 if (!printf_callback) return;
717
718 /* try to allocate a lbm_print_value buffer on the lbm_memory */
719 char *buf = lbm_malloc_reserve(ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
720 if (!buf) {
721 printf_callback("Error: Not enough free memory to create a human readable error message\n");
722 return;
723 }
724
725 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, error);
726 printf_callback( "*** Error: %s\n", buf);
727 if (has_at) {
728 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, at);
729 printf_callback("*** In: %s\n",buf);
730 if (lbm_error_has_suspect) {
731 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, lbm_error_suspect);
732 lbm_error_has_suspect = false0;
733 printf_callback("*** At: %s\n", buf);
734 } else {
735 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
736 printf_callback("*** After: %s\n",buf);
737 }
738 } else {
739 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
740 printf_callback("*** Near: %s\n",buf);
741 }
742
743 printf_callback("\n");
744
745 if (lbm_is_symbol(error) &&
746 error == ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u)) {
747 printf_callback("*** Line: %u\n", row);
748 printf_callback("*** Column: %u\n", col);
749 } else if (row0 != -1 || row1 != -1 ) {
750 printf_callback("*** Between rows: (-1 unknown) \n");
751 printf_callback("*** Start: %d\n", (int32_t)row0);
752 printf_callback("*** End: %d\n", (int32_t)row1);
753 }
754
755 printf_callback("\n");
756
757 if (ctx_running->error_reason) {
758 printf_callback("Reason:\n %s\n\n", ctx_running->error_reason);
759 }
760 if (lbm_verbose) {
761 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
762 printf_callback(" In context: %d\n", ctx_running->id);
763 printf_callback(" Current intermediate result: %s\n\n", buf);
764
765 print_environments(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
766 printf_callback("\n\n");
767
768 printf_callback(" Stack:\n");
769 for (unsigned int i = 0; i < ctx_running->K.sp; i ++) {
770 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->K.data[i]);
771 printf_callback(" %s\n", buf);
772 }
773 }
774 lbm_free(buf);
775}
776
777/****************************************************/
778/* Tokenizing and parsing */
779
780bool_Bool create_string_channel(char *str, lbm_value *res) {
781
782 lbm_char_channel_t *chan = NULL((void*)0);
783 lbm_string_channel_state_t *st = NULL((void*)0);
784
785 st = (lbm_string_channel_state_t*)lbm_memory_allocate(sizeof(lbm_string_channel_state_t) / sizeof(lbm_uint) +1);
786 if (st == NULL((void*)0)) {
787 return false0;
788 }
789 chan = (lbm_char_channel_t*)lbm_memory_allocate(sizeof(lbm_char_channel_t) / sizeof(lbm_uint) + 1);
790 if (chan == NULL((void*)0)) {
791 lbm_memory_free((lbm_uint*)st);
792 return false0;
793 }
794
795 lbm_create_string_char_channel(st, chan, str);
796 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
797 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
798 lbm_memory_free((lbm_uint*)st);
799 lbm_memory_free((lbm_uint*)chan);
800 return false0;
801 }
802
803 *res = cell;
804 return true1;
805}
806
807bool_Bool lift_char_channel(lbm_char_channel_t *chan , lbm_value *res) {
808 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
809 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
810 return false0;
811 }
812 *res = cell;
813 return true1;
814}
815
816
817/****************************************************/
818/* Queue functions */
819
820static void queue_iterator_nm(eval_context_queue_t *q, ctx_fun f, void *arg1, void *arg2) {
821 eval_context_t *curr;
822 curr = q->first;
823
824 while (curr != NULL((void*)0)) {
825 f(curr, arg1, arg2);
826 curr = curr->next;
827 }
828}
829
830void lbm_running_iterator(ctx_fun f, void *arg1, void *arg2){
831 mutex_lock(&qmutex);
832 queue_iterator_nm(&queue, f, arg1, arg2);
833 mutex_unlock(&qmutex);
834}
835
836void lbm_blocked_iterator(ctx_fun f, void *arg1, void *arg2){
837 mutex_lock(&qmutex);
838 queue_iterator_nm(&blocked, f, arg1, arg2);
839 mutex_unlock(&qmutex);
840}
841
842static void enqueue_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
843 if (q->last == NULL((void*)0)) {
844 ctx->prev = NULL((void*)0);
845 ctx->next = NULL((void*)0);
846 q->first = ctx;
847 q->last = ctx;
848 } else {
849 ctx->prev = q->last;
850 ctx->next = NULL((void*)0);
851 q->last->next = ctx;
852 q->last = ctx;
853 }
854}
855
856static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx) {
857 mutex_lock(&qmutex);
858 enqueue_ctx_nm(q,ctx);
859 mutex_unlock(&qmutex);
860}
861
862static eval_context_t *lookup_ctx_nm(eval_context_queue_t *q, lbm_cid cid) {
863 eval_context_t *curr;
864 curr = q->first;
865 while (curr != NULL((void*)0)) {
866 if (curr->id == cid) {
867 return curr;
868 }
869 curr = curr->next;
870 }
871 return NULL((void*)0);
872}
873
874static bool_Bool drop_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
875
876 bool_Bool res = false0;
877 if (q->first == NULL((void*)0) || q->last == NULL((void*)0)) {
878 if (!(q->last == NULL((void*)0) && q->first == NULL((void*)0))) {
879 /* error state that should not happen */
880 return res;
881 }
882 /* Queue is empty */
883 return res;
884 }
885
886 eval_context_t *curr = q->first;
887 while (curr) {
888 if (curr->id == ctx->id) {
889 res = true1;
890 eval_context_t *tmp = curr->next;
891 if (curr->prev == NULL((void*)0)) {
892 if (curr->next == NULL((void*)0)) {
893 q->last = NULL((void*)0);
894 q->first = NULL((void*)0);
895 } else {
896 q->first = tmp;
897 tmp->prev = NULL((void*)0);
898 }
899 } else { /* curr->prev != NULL */
900 if (curr->next == NULL((void*)0)) {
901 q->last = curr->prev;
902 q->last->next = NULL((void*)0);
903 } else {
904 curr->prev->next = tmp;
905 tmp->prev = curr->prev;
906 }
907 }
908 break;
909 }
910 curr = curr->next;
911 }
912 return res;
913}
914
915/* End execution of the running context. */
916static void finish_ctx(void) {
917
918 if (!ctx_running) {
919 return;
920 }
921 /* Drop the continuation stack immediately to free up lbm_memory */
922 lbm_stack_free(&ctx_running->K);
923 ctx_done_callback(ctx_running);
924 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->name)) {
925 lbm_free(ctx_running->name);
926 }
927 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->error_reason)) {
928 lbm_memory_free((lbm_uint*)ctx_running->error_reason);
929 }
930 lbm_memory_free((lbm_uint*)ctx_running->mailbox);
931 lbm_memory_free((lbm_uint*)ctx_running);
932 ctx_running = NULL((void*)0);
933}
934
935static void context_exists(eval_context_t *ctx, void *cid, void *b) {
936 if (ctx->id == *(lbm_cid*)cid) {
937 *(bool_Bool*)b = true1;
938 }
939}
940
941bool_Bool lbm_wait_ctx(lbm_cid cid, lbm_uint timeout_ms) {
942
943 bool_Bool exists;
944 uint32_t i = 0;
945
946 do {
947 exists = false0;
948 lbm_blocked_iterator(context_exists, &cid, &exists);
949 lbm_running_iterator(context_exists, &cid, &exists);
950
951 if (ctx_running &&
952 ctx_running->id == cid) {
953 exists = true1;
954 }
955
956 if (exists) {
957 if (usleep_callback) {
958 usleep_callback(1000);
959 }
960 if (timeout_ms > 0) i ++;
961 }
962 } while (exists && i < timeout_ms);
963
964 if (exists) return false0;
965 return true1;
966}
967
968void lbm_set_error_suspect(lbm_value suspect) {
969 lbm_error_suspect = suspect;
970 lbm_error_has_suspect = true1;
971}
972
973void lbm_set_error_reason(char *error_str) {
974 if (ctx_running != NULL((void*)0)) {
975 ctx_running->error_reason = error_str;
976 }
977}
978
979// Not possible to CONS_WITH_GC in error_ctx_base (potential loop)
980static void error_ctx_base(lbm_value err_val, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int column) {
981
982 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
983 if (lbm_heap_num_free() < 3) {
984 gc();
985 }
986
987 if (lbm_heap_num_free() >= 3) {
988 lbm_value msg = lbm_cons(err_val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
989 msg = lbm_cons(lbm_enc_i(ctx_running->id), msg);
990 msg = lbm_cons(ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u), msg);
991 if (!lbm_is_symbol_merror(msg)) {
992 lbm_find_receiver_and_send(ctx_running->parent, msg);
993 goto error_ctx_base_done;
994 }
995 }
996 }
997 if ((ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10) &&
998 (err_val != ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u))) {
999 lbm_uint v;
1000 while (ctx_running->K.sp > 0) {
1001 lbm_pop(&ctx_running->K, &v);
1002 if (v == EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u)) {
1003 lbm_value *sptr = get_stack_ptr(ctx_running, 2);
1004 lbm_set_car(sptr[0], ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
1005 stack_reserve(ctx_running, 1)[0] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1006 ctx_running->app_cont = true1;
1007 ctx_running->r = err_val;
1008 longjmp(error_jmp_buf, 1);
1009 }
1010 }
1011 err_val = ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u);
1012 }
1013 print_error_message(err_val,
1014 has_at,
1015 at,
1016 row,
1017 column,
1018 ctx_running->row0,
1019 ctx_running->row1);
1020 error_ctx_base_done:
1021 ctx_running->r = err_val;
1022 finish_ctx();
1023 longjmp(error_jmp_buf, 1);
1024}
1025
1026static void error_at_ctx(lbm_value err_val, lbm_value at) {
1027 error_ctx_base(err_val, true1, at, 0, 0);
1028}
1029
1030static void error_ctx(lbm_value err_val) {
1031 error_ctx_base(err_val, false0, 0, 0, 0);
1032}
1033
1034static void read_error_ctx(unsigned int row, unsigned int column) {
1035 error_ctx_base(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u), false0, 0, row, column);
1036}
1037
1038void lbm_critical_error(void) {
1039 longjmp(critical_error_jmp_buf, 1);
1040}
1041
1042// successfully finish a context
1043static void ok_ctx(void) {
1044 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
1045 lbm_value msg;
1046 WITH_GC(msg, lbm_heap_allocate_list_init(3,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1047 ENC_SYM_EXIT_OK,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1048 lbm_enc_i(ctx_running->id),(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1049 ctx_running->r))(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
1050 lbm_find_receiver_and_send(ctx_running->parent, msg);
1051 }
1052 finish_ctx();
1053}
1054
1055static eval_context_t *dequeue_ctx_nm(eval_context_queue_t *q) {
1056 if (q->last == NULL((void*)0)) {
1057 return NULL((void*)0);
1058 }
1059 // q->first should only be NULL if q->last is.
1060 eval_context_t *res = q->first;
1061
1062 if (q->first == q->last) { // One thing in queue
1063 q->first = NULL((void*)0);
1064 q->last = NULL((void*)0);
1065 } else {
1066 q->first = q->first->next;
1067 q->first->prev = NULL((void*)0);
1068 }
1069 res->prev = NULL((void*)0);
1070 res->next = NULL((void*)0);
1071 return res;
1072}
1073
1074static void wake_up_ctxs_nm(void) {
1075 lbm_uint t_now;
1076
1077 if (timestamp_us_callback) {
1078 t_now = timestamp_us_callback();
1079 } else {
1080 t_now = 0;
1081 }
1082
1083 eval_context_queue_t *q = &blocked;
1084 eval_context_t *curr = q->first;
1085
1086 while (curr != NULL((void*)0)) {
1087 lbm_uint t_diff;
1088 eval_context_t *next = curr->next;
1089 if (curr->state != LBM_THREAD_STATE_BLOCKED(uint32_t)1) {
1090 if ( curr->timestamp > t_now) {
1091 /* There was an overflow on the counter */
1092#ifndef LBM64
1093 t_diff = (0xFFFFFFFF - curr->timestamp) + t_now;
1094#else
1095 t_diff = (0xFFFFFFFFFFFFFFFF - curr->timestamp) + t_now;
1096#endif
1097 } else {
1098 t_diff = t_now - curr->timestamp;
1099 }
1100
1101 if (t_diff >= curr->sleep_us) {
1102 eval_context_t *wake_ctx = curr;
1103 if (curr == q->last) {
1104 if (curr->prev) {
1105 q->last = curr->prev;
1106 q->last->next = NULL((void*)0);
1107 } else {
1108 q->first = NULL((void*)0);
1109 q->last = NULL((void*)0);
1110 }
1111 } else if (curr->prev == NULL((void*)0)) {
1112 q->first = curr->next;
1113 q->first->prev = NULL((void*)0);
1114 } else {
1115 curr->prev->next = curr->next;
1116 if (curr->next) {
1117 curr->next->prev = curr->prev;
1118 }
1119 }
1120 wake_ctx->next = NULL((void*)0);
1121 wake_ctx->prev = NULL((void*)0);
1122 if (curr->state == LBM_THREAD_STATE_TIMEOUT(uint32_t)2) {
1123 mailbox_add_mail(wake_ctx, ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u));
1124 wake_ctx->r = ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u);
1125 }
1126 wake_ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1127 enqueue_ctx_nm(&queue, wake_ctx);
1128 }
1129 }
1130 curr = next;
1131 }
1132}
1133
1134static void yield_ctx(lbm_uint sleep_us) {
1135 if (timestamp_us_callback) {
1136 ctx_running->timestamp = timestamp_us_callback();
1137 ctx_running->sleep_us = sleep_us;
1138 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1139 } else {
1140 ctx_running->timestamp = 0;
1141 ctx_running->sleep_us = 0;
1142 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1143 }
1144 ctx_running->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1145 ctx_running->app_cont = true1;
1146 enqueue_ctx(&blocked,ctx_running);
1147 ctx_running = NULL((void*)0);
1148}
1149
1150static lbm_cid lbm_create_ctx_parent(lbm_value program, lbm_value env, lbm_uint stack_size, lbm_cid parent, uint32_t context_flags, char *name) {
1151
1152 if (!lbm_is_cons(program)) return -1;
1153
1154 eval_context_t *ctx = NULL((void*)0);
1155
1156 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1157 if (ctx == NULL((void*)0)) {
1158 lbm_uint roots[2] = {program, env};
1159 lbm_gc_mark_roots(roots, 2);
1160 gc();
1161 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1162 }
1163 if (ctx == NULL((void*)0)) return -1;
1164
1165 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1166 lbm_uint roots[2] = {program, env};
1167 lbm_gc_mark_roots(roots, 2);
1168 gc();
1169 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1170 lbm_memory_free((lbm_uint*)ctx);
1171 return -1;
1172 }
1173 }
1174
1175 lbm_value *mailbox = NULL((void*)0);
1176 mailbox = (lbm_value*)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1177 if (mailbox == NULL((void*)0)) {
1178 lbm_value roots[2] = {program, env};
1179 lbm_gc_mark_roots(roots,2);
1180 gc();
1181 mailbox = (lbm_value *)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1182 }
1183 if (mailbox == NULL((void*)0)) {
1184 lbm_stack_free(&ctx->K);
1185 lbm_memory_free((lbm_uint*)ctx);
1186 return -1;
1187 }
1188
1189 // TODO: Limit names to 19 chars + 1 char for 0? (or something similar).
1190 if (name) {
1191 lbm_uint name_len = strlen(name) + 1;
1192 ctx->name = lbm_malloc(strlen(name) + 1);
1193 if (ctx->name == NULL((void*)0)) {
1194 lbm_value roots[2] = {program, env};
1195 lbm_gc_mark_roots(roots, 2);
1196 gc();
1197 ctx->name = lbm_malloc(strlen(name) + 1);
1198 }
1199 if (ctx->name == NULL((void*)0)) {
1200 lbm_stack_free(&ctx->K);
1201 lbm_memory_free((lbm_uint*)mailbox);
1202 lbm_memory_free((lbm_uint*)ctx);
1203 return -1;
1204 }
1205 memcpy(ctx->name, name, name_len+1);
1206 } else {
1207 ctx->name = NULL((void*)0);
1208 }
1209
1210 lbm_int cid = lbm_memory_address_to_ix((lbm_uint*)ctx);
1211
1212 ctx->program = lbm_cdr(program);
1213 ctx->curr_exp = lbm_car(program);
1214 ctx->curr_env = env;
1215 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1216 ctx->error_reason = NULL((void*)0);
1217 ctx->mailbox = mailbox;
1218 ctx->mailbox_size = EVAL_CPS_DEFAULT_MAILBOX_SIZE10;
1219 ctx->flags = context_flags;
1220 ctx->num_mail = 0;
1221 ctx->app_cont = false0;
1222 ctx->timestamp = 0;
1223 ctx->sleep_us = 0;
1224 ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1225 ctx->prev = NULL((void*)0);
1226 ctx->next = NULL((void*)0);
1227
1228 ctx->row0 = -1;
1229 ctx->row1 = -1;
1230
1231 ctx->id = cid;
1232 ctx->parent = parent;
1233
1234 if (!lbm_push(&ctx->K, DONE(((0) << 2) | 0xF8000001u))) {
1235 lbm_memory_free((lbm_uint*)ctx->mailbox);
1236 lbm_stack_free(&ctx->K);
1237 lbm_memory_free((lbm_uint*)ctx);
1238 return -1;
1239 }
1240
1241 enqueue_ctx(&queue,ctx);
1242
1243 return ctx->id;
1244}
1245
1246lbm_cid lbm_create_ctx(lbm_value program, lbm_value env, lbm_uint stack_size, char *name) {
1247 // Creates a parentless context.
1248 return lbm_create_ctx_parent(program,
1249 env,
1250 stack_size,
1251 -1,
1252 EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00,
1253 name);
1254}
1255
1256bool_Bool lbm_mailbox_change_size(eval_context_t *ctx, lbm_uint new_size) {
1257
1258 lbm_value *mailbox = NULL((void*)0);
1259 mailbox = (lbm_value*)lbm_memory_allocate(new_size);
1260 if (mailbox == NULL((void*)0)) {
1261 gc();
1262 mailbox = (lbm_value *)lbm_memory_allocate(new_size);
1263 }
1264 if (mailbox == NULL((void*)0)) {
1265 return false0;
1266 }
1267
1268 for (lbm_uint i = 0; i < ctx->num_mail; i ++ ) {
1269 mailbox[i] = ctx->mailbox[i];
1270 }
1271 lbm_memory_free(ctx->mailbox);
1272 ctx->mailbox = mailbox;
1273 ctx->mailbox_size = (uint32_t)new_size;
1274 return true1;
1275}
1276
1277static void mailbox_remove_mail(eval_context_t *ctx, lbm_uint ix) {
1278
1279 for (lbm_uint i = ix; i < ctx->num_mail-1; i ++) {
1280 ctx->mailbox[i] = ctx->mailbox[i+1];
1281 }
1282 ctx->num_mail --;
1283}
1284
1285static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail) {
1286
1287 if (ctx->num_mail >= ctx->mailbox_size) {
1288 mailbox_remove_mail(ctx, 0);
1289 }
1290
1291 ctx->mailbox[ctx->num_mail] = mail;
1292 ctx->num_mail ++;
1293 return true1;
1294}
1295
1296/* Advance execution to the next expression in the program */
1297static void advance_ctx(eval_context_t *ctx) {
1298 if (lbm_is_cons(ctx->program)) {
1299 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);;
1300 get_car_and_cdr(ctx->program, &ctx->curr_exp, &ctx->program);
1301 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1302 } else {
1303 if (ctx_running == ctx) { // This should always be the case because of odd historical reasons.
1304 ok_ctx();
1305 }
1306 }
1307}
1308
1309bool_Bool lbm_unblock_ctx(lbm_cid cid, lbm_flat_value_t *fv) {
1310 return event_internal(LBM_EVENT_UNBLOCK_CTX, (lbm_uint)cid, (lbm_uint)fv->buf, fv->buf_size);
1311}
1312
1313bool_Bool lbm_unblock_ctx_r(lbm_cid cid) {
1314 mutex_lock(&blocking_extension_mutex);
1315 bool_Bool r = false0;
1316 eval_context_t *found = NULL((void*)0);
1317 mutex_lock(&qmutex);
1318 found = lookup_ctx_nm(&blocked, cid);
1319 if (found) {
1320 drop_ctx_nm(&blocked,found);
1321 enqueue_ctx_nm(&queue,found);
1322 r = true1;
1323 }
1324 mutex_unlock(&qmutex);
1325 mutex_unlock(&blocking_extension_mutex);
1326 return r;
1327}
1328
1329// unblock unboxed is also safe for rmbr:ed things.
1330bool_Bool lbm_unblock_ctx_unboxed(lbm_cid cid, lbm_value unboxed) {
1331 mutex_lock(&blocking_extension_mutex);
1332 bool_Bool r = false0;
1333 eval_context_t *found = NULL((void*)0);
1334 mutex_lock(&qmutex);
1335 found = lookup_ctx_nm(&blocked, cid);
1336 if (found) {
1337 drop_ctx_nm(&blocked,found);
1338 found->r = unboxed;
1339 if (lbm_is_error(unboxed)) {
1340 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
1341 found->app_cont = true1;
1342 }
1343 enqueue_ctx_nm(&queue,found);
1344 r = true1;
1345 }
1346 mutex_unlock(&qmutex);
1347 mutex_unlock(&blocking_extension_mutex);
1348 return r;
1349}
1350
1351static bool_Bool lbm_block_ctx_base(bool_Bool timeout, float t_s) {
1352 mutex_lock(&blocking_extension_mutex);
1353 blocking_extension = true1;
1354 if (timeout) {
1355 blocking_extension_timeout_us = S_TO_US(t_s)(lbm_uint)((t_s) * 1000000);
1356 blocking_extension_timeout = true1;
1357 } else {
1358 blocking_extension_timeout = false0;
1359 }
1360 return true1;
1361}
1362
1363void lbm_block_ctx_from_extension_timeout(float s) {
1364 lbm_block_ctx_base(true1, s);
1365}
1366
1367void lbm_block_ctx_from_extension(void) {
1368 lbm_block_ctx_base(false0, 0);
1369}
1370
1371// todo: May need to pop rmbrs from stack, if present.
1372// Suspect that the letting the discard cont run is really not a problem.
1373// Either way will be quite confusing what happens to allocated things when undoing block.
1374void lbm_undo_block_ctx_from_extension(void) {
1375 blocking_extension = false0;
1376 blocking_extension_timeout_us = 0;
1377 blocking_extension_timeout = false0;
1378 mutex_unlock(&blocking_extension_mutex);
1379}
1380
1381lbm_value lbm_find_receiver_and_send(lbm_cid cid, lbm_value msg) {
1382 mutex_lock(&qmutex);
1383 eval_context_t *found = NULL((void*)0);
1384 bool_Bool found_blocked = false0;
1385
1386 found = lookup_ctx_nm(&blocked, cid);
1387 if (found) found_blocked = true1;
1388
1389 if (found == NULL((void*)0)) {
1390 found = lookup_ctx_nm(&queue, cid);
1391 }
1392
1393 if (found) {
1394 if (!mailbox_add_mail(found, msg)) {
1395 mutex_unlock(&qmutex);
1396 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1397 }
1398
1399 if (found_blocked){
1400 drop_ctx_nm(&blocked,found);
1401 enqueue_ctx_nm(&queue,found);
1402 }
1403 mutex_unlock(&qmutex);
1404 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1405 }
1406
1407 /* check the current context */
1408 if (ctx_running && ctx_running->id == cid) {
1409 if (!mailbox_add_mail(ctx_running, msg)) {
1410 mutex_unlock(&qmutex);
1411 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1412 }
1413 mutex_unlock(&qmutex);
1414 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1415 }
1416 mutex_unlock(&qmutex);
1417 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1418}
1419
1420/* Pattern matching is currently implemented as a recursive
1421 function and make use of stack relative to the size of
1422 expressions that are being matched. */
1423static bool_Bool match(lbm_value p, lbm_value e, lbm_value *env, bool_Bool *gc) {
1424
1425 lbm_value binding;
1426
1427 if (lbm_is_match_binder(p)) {
1428 lbm_value var = get_cadr(p);
1429 lbm_value bindertype = get_car(p);
1430
1431 if (!lbm_is_symbol(var)) return false0;
1432
1433 switch (bindertype) {
1434 case ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u):
1435 if ( var == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) {
1436 return true1;
1437 }
1438 break;
1439 default: /* this should be an error case */
1440 return false0;
1441 }
1442 binding = lbm_cons(var, e);
1443 if ( lbm_type_of(binding) == LBM_TYPE_SYMBOL0x00000000u ) {
1444 *gc = true1;
1445 return false0;
1446 }
1447 *env = lbm_cons(binding, *env);
1448 if ( lbm_type_of(*env) == LBM_TYPE_SYMBOL0x00000000u ) {
1449 *gc = true1;
1450 return false0;
1451 }
1452 return true1;
1453 }
1454
1455 if (lbm_is_symbol(p)) {
1456 if (p == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return true1;
1457 return (p == e);
1458 }
1459 if (lbm_is_cons(p) &&
1460 lbm_is_cons(e) ) {
1461
1462 lbm_value headp, tailp;
1463 lbm_value heade, taile;
1464 get_car_and_cdr(p, &headp, &tailp);
1465 get_car_and_cdr(e, &heade, &taile); // Static analysis warns, but execution does not
1466 // past this point unless head and tail get initialized.
1467 if (!match(headp, heade, env, gc)) {
1468 return false0;
1469 }
1470 return match (tailp, taile, env, gc);
1471 }
1472 return struct_eq(p, e);
1473}
1474
1475// Find match is not very picky about syntax.
1476// A completely malformed recv form is most likely to
1477// just return no_match.
1478static int find_match(lbm_value plist, lbm_value *earr, lbm_uint num, lbm_value *e, lbm_value *env) {
1479
1480 // A pattern list is a list of pattern, expression lists.
1481 // ( (p1 e1) (p2 e2) ... (pn en))
1482 lbm_value curr_p = plist;
1483 int n = 0;
1484 bool_Bool gc = false0;
1485 for (int i = 0; i < (int)num; i ++ ) {
1486 lbm_value curr_e = earr[i];
1487 while (!lbm_is_symbol_nil(curr_p)) {
1488 lbm_value me = get_car(curr_p);
1489 if (match(get_car(me), curr_e, env, &gc)) {
1490 if (gc) return FM_NEED_GC-1;
1491 *e = get_cadr(me);
1492
1493 if (!lbm_is_symbol_nil(get_cadr(get_cdr(me)))) {
1494 return FM_PATTERN_ERROR-3;
1495 }
1496 return n;
1497 }
1498 curr_p = get_cdr(curr_p);
1499 }
1500 curr_p = plist; /* search all patterns against next exp */
1501 n ++;
1502 }
1503
1504 return FM_NO_MATCH-2;
1505}
1506
1507/****************************************************/
1508/* Garbage collection */
1509
1510static void mark_context(eval_context_t *ctx, void *arg1, void *arg2) {
1511 (void) arg1;
1512 (void) arg2;
1513 lbm_value roots[3] = {ctx->curr_exp, ctx->program, ctx->r };
1514 lbm_gc_mark_env(ctx->curr_env);
1515 lbm_gc_mark_roots(roots, 3);
1516 lbm_gc_mark_roots(ctx->mailbox, ctx->num_mail);
1517 lbm_gc_mark_aux(ctx->K.data, ctx->K.sp);
1518}
1519
1520static int gc(void) {
1521 if (ctx_running) {
1522 ctx_running->state = ctx_running->state | LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1523 }
1524
1525 gc_requested = false0;
1526 lbm_gc_state_inc();
1527
1528 // The freelist should generally be NIL when GC runs.
1529 lbm_nil_freelist();
1530 lbm_value *env = lbm_get_global_env();
1531 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
1532 lbm_gc_mark_env(env[i]);
1533 }
1534
1535 mutex_lock(&qmutex); // Lock the queues.
1536 // Any concurrent messing with the queues
1537 // while doing GC cannot possibly be good.
1538 queue_iterator_nm(&queue, mark_context, NULL((void*)0), NULL((void*)0));
1539 queue_iterator_nm(&blocked, mark_context, NULL((void*)0), NULL((void*)0));
1540
1541 if (ctx_running) {
1542 mark_context(ctx_running, NULL((void*)0), NULL((void*)0));
1543 }
1544 mutex_unlock(&qmutex);
1545
1546#ifdef VISUALIZE_HEAP
1547 heap_vis_gen_image();
1548#endif
1549
1550 int r = lbm_gc_sweep_phase();
1551 lbm_heap_new_freelist_length();
1552
1553 if (ctx_running) {
1554 ctx_running->state = ctx_running->state & ~LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1555 }
1556 return r;
1557}
1558
1559int lbm_perform_gc(void) {
1560 return gc();
1561}
1562
1563/****************************************************/
1564/* Evaluation functions */
1565
1566
1567static void eval_symbol(eval_context_t *ctx) {
1568 lbm_uint s = lbm_dec_sym(ctx->curr_exp);
1569 if (s >= RUNTIME_SYMBOLS_START0x40000) {
1570 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1571 if (lbm_env_lookup_b(&res, ctx->curr_exp, ctx->curr_env) ||
1572 lbm_global_env_lookup(&res, ctx->curr_exp)) {
1573 ctx->r = res;
1574 ctx->app_cont = true1;
1575 return;
1576 }
1577 // Dynamic load attempt
1578 // Only symbols of kind RUNTIME can be dynamically loaded.
1579 const char *sym_str = lbm_get_name_by_symbol(s);
1580 const char *code_str = NULL((void*)0);
1581 if (!dynamic_load_callback(sym_str, &code_str)) {
1582 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), ctx->curr_exp);
1583 }
1584 lbm_value *sptr = stack_reserve(ctx, 3);
1585 sptr[0] = ctx->curr_exp;
1586 sptr[1] = ctx->curr_env;
1587 sptr[2] = RESUME(((12) << 2) | 0xF8000001u);
1588
1589 lbm_value chan;
1590 if (!create_string_channel((char *)code_str, &chan)) {
1591 gc();
1592 if (!create_string_channel((char *)code_str, &chan)) {
1593 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1594 }
1595 }
1596
1597 lbm_value loader;
1598 WITH_GC_RMBR_1(loader, lbm_heap_allocate_list_init(2,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1599 ENC_SYM_READ,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1600 chan), chan)(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} };
1601 lbm_value evaluator;
1602 WITH_GC_RMBR_1(evaluator, lbm_heap_allocate_list_init(2,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1603 ENC_SYM_EVAL,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1604 loader), loader)(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } };
1605 ctx->curr_exp = evaluator;
1606 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // dynamics should be evaluable in empty local env
1607 } else {
1608 //special symbols and extensions can be handled the same way.
1609 ctx->r = ctx->curr_exp;
1610 ctx->app_cont = true1;
1611 }
1612}
1613
1614static void eval_quote(eval_context_t *ctx) {
1615 ctx->r = get_cadr(ctx->curr_exp);
1616 ctx->app_cont = true1;
1617}
1618
1619static void eval_selfevaluating(eval_context_t *ctx) {
1620 ctx->r = ctx->curr_exp;
1621 ctx->app_cont = true1;
1622}
1623
1624static void eval_progn(eval_context_t *ctx) {
1625 lbm_value exps = get_cdr(ctx->curr_exp);
1626
1627 if (lbm_is_cons(exps)) {
1628 lbm_uint *sptr = stack_reserve(ctx, 4);
1629 sptr[0] = ctx->curr_env; // env to restore between expressions in progn
1630 sptr[1] = lbm_enc_u(0); // Has env been copied (needed for progn local bindings)
1631 sptr[3] = PROGN_REST(((4) << 2) | 0xF8000001u);
1632 get_car_and_cdr(exps, &ctx->curr_exp, &sptr[2]);
1633 if (lbm_is_symbol(sptr[2])) /* The only symbol it can be is nil */
1634 lbm_stack_drop(&ctx->K, 4);
1635 } else if (lbm_is_symbol_nil(exps)) {
1636 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1637 ctx->app_cont = true1;
1638 } else {
1639 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1640 }
1641}
1642
1643static void eval_atomic(eval_context_t *ctx) {
1644 if (is_atomic) {
1645 lbm_set_error_reason("Atomic blocks cannot be nested!");
1646 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1647 }
1648 stack_reserve(ctx, 1)[0] = EXIT_ATOMIC(((14) << 2) | 0xF8000001u);
1649 is_atomic ++;
1650 eval_progn(ctx);
1651}
1652
1653/* (call-cc (lambda (k) .... )) */
1654static void eval_callcc(eval_context_t *ctx) {
1655 lbm_value cont_array;
1656 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1657 gc();
1658 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1659 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1660 return; // dead return but static analysis doesn't know :)
1661 }
1662 }
1663 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(cont_array);
1664 memcpy(arr->data, ctx->K.data, ctx->K.sp * sizeof(lbm_uint));
1665
1666 lbm_value acont = cons_with_gc(ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u), cont_array, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1667 lbm_value arg_list = cons_with_gc(acont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1668 // Go directly into application evaluation without passing go
1669 lbm_uint *sptr = stack_reserve(ctx, 3);
1670 sptr[0] = ctx->curr_env;
1671 sptr[1] = arg_list;
1672 sptr[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
1673 ctx->curr_exp = get_cadr(ctx->curr_exp);
1674}
1675
1676// (define sym exp)
1677#define KEY1 1
1678#define VAL2 2
1679static void eval_define(eval_context_t *ctx) {
1680 lbm_value parts[3];
1681 lbm_value rest = extract_n(ctx->curr_exp, parts, 3);
1682 lbm_uint *sptr = stack_reserve(ctx, 2);
1683 if (lbm_is_symbol(parts[KEY1]) && lbm_is_symbol_nil(rest)) {
1684 lbm_uint sym_val = lbm_dec_sym(parts[KEY1]);
1685 sptr[0] = parts[KEY1];
1686 if (sym_val >= RUNTIME_SYMBOLS_START0x40000) {
1687 sptr[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
1688 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02) {
1689 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
1690 }
1691 ctx->curr_exp = parts[VAL2];
1692 return;
1693 }
1694 }
1695 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
1696}
1697
1698
1699/* Eval lambda is cheating, a lot! It does this
1700 for performance reasons. The cheats are that
1701 1. When closure is created, a reference to the local env
1702 in which the lambda was evaluated is added to the closure.
1703 Ideally it should have created a list of free variables in the function
1704 and then looked up the values of these creating a new environment.
1705 2. The global env is considered global constant. As there is no copying
1706 of environment bindings into the closure, undefine may break closures.
1707
1708 Correct closure creation is a lot more expensive than what happens here.
1709 However, one can try to write programs in such a way that closures are created
1710 seldomly. If one does that the space-usage benefits of "correct" closures
1711 may outweigh the performance gain of "incorrect" ones.
1712
1713 some obscure programs such as test_setq_local_closure.lisp does not
1714 work properly due to this cheating.
1715 */
1716// (lambda param-list body-exp) -> (closure param-list body-exp env)
1717static void eval_lambda(eval_context_t *ctx) {
1718 lbm_value vals[3];
1719 extract_n(ctx->curr_exp, vals, 3);
1720 ctx->r = allocate_closure(vals[1],vals[2], ctx->curr_env);
1721#ifdef CLEAN_UP_CLOSURES
1722 lbm_uint sym_id = 0;
1723 if (clean_cl_env_symbol) {
1724 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1725 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1726 ctx->curr_exp = app;
1727 } else if (lbm_get_symbol_by_name("clean-cl-env", &sym_id)) {
1728 clean_cl_env_symbol = lbm_enc_sym(sym_id);
1729 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1730 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1731 ctx->curr_exp = app;
1732 } else {
1733 ctx->app_cont = true1;
1734 }
1735#else
1736 ctx->app_cont = true1;
1737#endif
1738}
1739
1740// (if cond-expr then-expr else-expr)
1741static void eval_if(eval_context_t *ctx) {
1742 lbm_value cdr = get_cdr(ctx->curr_exp);
1743 lbm_value *sptr = stack_reserve(ctx, 3);
1744 sptr[0] = get_cdr(cdr);
1745 sptr[1] = ctx->curr_env;
1746 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1747 ctx->curr_exp = get_car(cdr);
1748}
1749
1750// (cond (cond-expr-1 expr-1)
1751// ...
1752// (cond-expr-N expr-N))
1753static void eval_cond(eval_context_t *ctx) {
1754 lbm_value cond1[2];
1755 lbm_value rest_conds = extract_n(ctx->curr_exp, cond1, 2);
1756
1757 // end recursion at (cond )
1758 if (lbm_is_symbol_nil(cond1[1])) {
1759 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1760 ctx->app_cont = true1;
1761 } else {
1762 // Cond is one of the few places where a bit of syntax checking takes place at runtime..
1763 // Maybe dont bother?
1764 lbm_uint len = lbm_list_length(cond1[1]);
1765 if (len != 2) {
1766 lbm_set_error_reason("Incorrect syntax in cond");
1767 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1768 }
1769 lbm_value cond_expr[2];
1770 extract_n(cond1[1], cond_expr, 2);
1771 lbm_value rest;
1772 WITH_GC(rest, lbm_heap_allocate_list_init(2,(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1773 cond_expr[1], // Then branch(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1774 cons_with_gc(ENC_SYM_COND, rest_conds , ENC_SYM_NIL)))(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
1775 lbm_value *sptr = stack_reserve(ctx, 3);
1776 sptr[0] = rest;
1777 sptr[1] = ctx->curr_env;
1778 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1779 ctx->curr_exp = cond_expr[0]; //condition;
1780 }
1781}
1782
1783static void eval_app_cont(eval_context_t *ctx) {
1784 lbm_stack_drop(&ctx->K, 1);
1785 ctx->app_cont = true1;
1786}
1787
1788// Create a named location in an environment to later receive a value.
1789static binding_location_status create_binding_location_internal(lbm_value key, lbm_value *env) {
1790
1791 if (lbm_is_symbol(key) &&
1792 (key == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u) ||
1793 key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)))
1794 return BL_OK;
1795
1796 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) { // default case
1797 lbm_value binding;
1798 lbm_value new_env_tmp;
1799 binding = lbm_cons(key, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1800 new_env_tmp = lbm_cons(binding, *env);
1801 if (lbm_is_symbol(binding) || lbm_is_symbol(new_env_tmp)) {
1802 return BL_NO_MEMORY;
1803 }
1804 *env = new_env_tmp;
1805 } else if (lbm_is_cons(key)) { // deconstruct case
1806 int r = create_binding_location_internal(get_car(key), env);
1807 if (r == BL_OK) {
1808 r = create_binding_location_internal(get_cdr(key), env);
1809 }
1810 return r;
1811 }
1812 return BL_OK;
1813}
1814
1815static void create_binding_location(lbm_value key, lbm_value *env) {
1816
1817 lbm_value env_tmp = *env;
1818 binding_location_status r = create_binding_location_internal(key, &env_tmp);
1819 if (r != BL_OK) {
1820 if (r == BL_NO_MEMORY) {
1821 env_tmp = *env;
1822 lbm_gc_mark_phase(env_tmp);
1823 gc();
1824 r = create_binding_location_internal(key, &env_tmp);
1825 }
1826 switch(r) {
1827 case BL_OK:
1828 break;
1829 case BL_NO_MEMORY:
1830 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1831 break;
1832 case BL_INCORRECT_KEY:
1833 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
1834 break;
1835 }
1836 }
1837 *env = env_tmp;
1838}
1839
1840static void let_bind_values_eval(lbm_value binds, lbm_value exp, lbm_value env, eval_context_t *ctx) {
1841
1842 if (!lbm_is_cons(binds)) {
1843 // binds better be nil or there is a programmer error.
1844 ctx->curr_exp = exp;
1845 return;
1846 }
1847
1848 // Preallocate binding locations.
1849 lbm_value curr = binds;
1850 while (lbm_is_cons(curr)) {
1851 lbm_value new_env_tmp = env;
1852 lbm_value car_curr, cdr_curr;
1853 get_car_and_cdr(curr, &car_curr, &cdr_curr);
1854 lbm_value key = get_car(car_curr);
1855 create_binding_location(key, &new_env_tmp);
1856 env = new_env_tmp;
1857 curr = cdr_curr;
1858 }
1859
1860 lbm_value car_binds;
1861 lbm_value cdr_binds;
1862 get_car_and_cdr(binds, &car_binds, &cdr_binds);
1863 lbm_value key_val[2];
1864 extract_n(car_binds, key_val, 2);
1865
1866 lbm_uint *sptr = stack_reserve(ctx, 5);
1867 sptr[0] = exp;
1868 sptr[1] = cdr_binds;
1869 sptr[2] = env;
1870 sptr[3] = key_val[0];
1871 sptr[4] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
1872 ctx->curr_exp = key_val[1];
1873 ctx->curr_env = env;
1874}
1875
1876// (var x (...)) - local binding inside of an progn
1877// var has to take, place root-level nesting within progn.
1878// (progn ... (var a 10) ...) OK!
1879// (progn ... (something (var a 10)) ... ) NOT OK!
1880/* progn stack
1881 sp-4 : env
1882 sp-3 : 0
1883 sp-2 : rest
1884 sp-1 : PROGN_REST
1885*/
1886static void eval_var(eval_context_t *ctx) {
1887
1888 if (ctx->K.sp >= 4) { // Possibly in progn
1889 lbm_value sv = ctx->K.data[ctx->K.sp - 1];
1890 if (IS_CONTINUATION(sv)(((sv) & 0xF8000001u) == 0xF8000001u) && (sv == PROGN_REST(((4) << 2) | 0xF8000001u))) {
1891 lbm_uint sp = ctx->K.sp;
1892 uint32_t is_copied = lbm_dec_as_u32(ctx->K.data[sp-3]);
1893 if (is_copied == 0) {
1894 lbm_value env;
1895 WITH_GC(env, lbm_env_copy_spine(ctx->K.data[sp-4]))(env) = (lbm_env_copy_spine(ctx->K.data[sp-4])); if (lbm_is_symbol_merror
((env))) { gc(); (env) = (lbm_env_copy_spine(ctx->K.data[sp
-4])); if (lbm_is_symbol_merror((env))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1896 ctx->K.data[sp-3] = lbm_enc_u(1);
1897 ctx->K.data[sp-4] = env;
1898 }
1899 lbm_value new_env = ctx->K.data[sp-4];
1900 lbm_value args = get_cdr(ctx->curr_exp);
1901 lbm_value key = get_car(args);
1902 create_binding_location(key, &new_env);
1903 ctx->K.data[sp-4] = new_env;
1904
1905 lbm_value v_exp = get_cadr(args);
1906 lbm_value *sptr = stack_reserve(ctx, 3);
1907 sptr[0] = new_env;
1908 sptr[1] = key;
1909 sptr[2] = PROGN_VAR(((29) << 2) | 0xF8000001u);
1910 // Activating the new environment before the evaluation of the value to be bound,
1911 // means that other variables with same name will be shadowed already in the value
1912 // body.
1913 // The way closures work, the var-variable needs to be in scope during val evaluation
1914 // for a recursive closure to be possible.
1915 ctx->curr_env = new_env;
1916 ctx->curr_exp = v_exp;
1917 return;
1918 }
1919 }
1920 lbm_set_error_reason((char*)lbm_error_str_var_outside_progn);
1921 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1922}
1923
1924// (setq x (...)) - same as (set 'x (...)) or (setvar 'x (...))
1925static void eval_setq(eval_context_t *ctx) {
1926 lbm_value parts[3];
1927 extract_n(ctx->curr_exp, parts, 3);
1928 lbm_value *sptr = stack_reserve(ctx, 3);
1929 sptr[0] = ctx->curr_env;
1930 sptr[1] = parts[1];
1931 sptr[2] = SETQ(((30) << 2) | 0xF8000001u);
1932 ctx->curr_exp = parts[2];
1933}
1934
1935static void eval_move_to_flash(eval_context_t *ctx) {
1936 lbm_value args = get_cdr(ctx->curr_exp);
1937 lbm_value *sptr = stack_reserve(ctx,2);
1938 sptr[0] = args;
1939 sptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
1940 ctx->app_cont = true1;
1941}
1942
1943// (loop list-of-local-bindings
1944// condition-exp
1945// body-exp)
1946static void eval_loop(eval_context_t *ctx) {
1947 lbm_value env = ctx->curr_env;
1948 lbm_value parts[3];
1949 extract_n(get_cdr(ctx->curr_exp), parts, 3);
1950 lbm_value *sptr = stack_reserve(ctx, 3);
1951 sptr[0] = parts[LOOP_BODY2];
1952 sptr[1] = parts[LOOP_COND1];
1953 sptr[2] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
1954 let_bind_values_eval(parts[LOOP_BINDS0], parts[LOOP_COND1], env, ctx);
1955}
1956
1957/* (trap expression)
1958 *
1959 * suggested use:
1960 * (match (trap expression)
1961 * ((exit-error (? err)) (error-handler err))
1962 * ((exit-ok (? v)) (value-handler v)))
1963 */
1964static void eval_trap(eval_context_t *ctx) {
1965
1966 lbm_value expr = get_cadr(ctx->curr_exp);
1967 lbm_value retval;
1968 WITH_GC(retval, lbm_heap_allocate_list(2))(retval) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((retval))) { gc(); (retval) = (lbm_heap_allocate_list(2)); if
(lbm_is_symbol_merror((retval))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1969 lbm_set_car(retval, ENC_SYM_EXIT_OK(((0x3000B) << 4) | 0x00000000u)); // Assume things will go well.
1970 lbm_uint *sptr = stack_reserve(ctx,3);
1971 sptr[0] = retval;
1972 sptr[1] = ctx->flags;
1973 sptr[2] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1974 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10;
1975 ctx->curr_exp = expr;
1976}
1977
1978// (let list-of-binding s
1979// body-exp)
1980static void eval_let(eval_context_t *ctx) {
1981 lbm_value env = ctx->curr_env;
1982 lbm_value parts[3];
1983 extract_n(ctx->curr_exp, parts, 3);
1984 let_bind_values_eval(parts[1], parts[2], env, ctx);
1985}
1986
1987// (and exp0 ... expN)
1988static void eval_and(eval_context_t *ctx) {
1989 lbm_value rest = get_cdr(ctx->curr_exp);
1990 if (lbm_is_symbol_nil(rest)) {
1991 ctx->app_cont = true1;
1992 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1993 } else {
1994 lbm_value *sptr = stack_reserve(ctx, 3);
1995 sptr[0] = ctx->curr_env;
1996 sptr[1] = get_cdr(rest);
1997 sptr[2] = AND(((6) << 2) | 0xF8000001u);
1998 ctx->curr_exp = get_car(rest);
1999 }
2000}
2001
2002// (or exp0 ... expN)
2003static void eval_or(eval_context_t *ctx) {
2004 lbm_value rest = get_cdr(ctx->curr_exp);
2005 if (lbm_is_symbol_nil(rest)) {
2006 ctx->app_cont = true1;
2007 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2008 } else {
2009 lbm_value *sptr = stack_reserve(ctx, 3);
2010 sptr[0] = ctx->curr_env;
2011 sptr[1] = get_cdr(rest);
2012 sptr[2] = OR(((7) << 2) | 0xF8000001u);
2013 ctx->curr_exp = get_car(rest);
2014 }
2015}
2016
2017// Pattern matching
2018// format:
2019// (match e (pattern body)
2020// (pattern body)
2021// ... )
2022//
2023// There can be an optional pattern guard:
2024// (match e (pattern guard body)
2025// ... )
2026// a guard is a boolean expression.
2027// Guards make match, pattern matching more complicated
2028// than the recv pattern matching and requires staged execution
2029// via the continuation system rather than a while loop over a list.
2030static void eval_match(eval_context_t *ctx) {
2031
2032 lbm_value rest = get_cdr(ctx->curr_exp);
2033 if (lbm_type_of(rest) == LBM_TYPE_SYMBOL0x00000000u &&
2034 rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
2035 // Someone wrote the program (match)
2036 ctx->app_cont = true1;
2037 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2038 } else {
2039 lbm_value cdr_rest;
2040 get_car_and_cdr(rest, &ctx->curr_exp, &cdr_rest);
2041 lbm_value *sptr = stack_reserve(ctx, 3);
2042 sptr[0] = cdr_rest;
2043 sptr[1] = ctx->curr_env;
2044 sptr[2] = MATCH(((9) << 2) | 0xF8000001u);
2045 }
2046}
2047
2048static void receive_base(eval_context_t *ctx, lbm_value pats, float timeout_time, bool_Bool timeout) {
2049 if (ctx->num_mail == 0) {
2050 if (timeout) {
2051 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000), false0);
2052 } else {
2053 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1,0,false0);
2054 }
2055 } else {
2056 lbm_value *msgs = ctx->mailbox;
2057 lbm_uint num = ctx->num_mail;
2058
2059 if (lbm_is_symbol_nil(pats)) {
2060 /* A receive statement without any patterns */
2061 ctx->app_cont = true1;
2062 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2063 } else {
2064 /* The common case */
2065 lbm_value e;
2066 lbm_value new_env = ctx->curr_env;
2067 int n = find_match(pats, msgs, num, &e, &new_env);
2068 if (n == FM_NEED_GC-1) {
2069 gc();
2070 new_env = ctx->curr_env;
2071 n = find_match(pats, msgs, num, &e, &new_env);
2072 if (n == FM_NEED_GC-1) {
2073 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2074 }
2075 }
2076 if (n == FM_PATTERN_ERROR-3) {
2077 lbm_set_error_reason("Incorrect pattern format for recv");
2078 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),pats);
2079 } else if (n >= 0 ) { /* Match */
2080 mailbox_remove_mail(ctx, (lbm_uint)n);
2081 ctx->curr_env = new_env;
2082 ctx->curr_exp = e;
2083 } else { /* No match go back to sleep */
2084 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
2085 if (timeout) {
2086 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2,S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000),false0);
2087 } else {
2088 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,false0);
2089 }
2090 }
2091 }
2092 }
2093 return;
2094}
2095
2096static void eval_receive_timeout(eval_context_t *ctx) {
2097 if (is_atomic) {
2098 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2099 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2100 }
2101 lbm_value timeout_val = get_cadr(ctx->curr_exp);
2102 if (!lbm_is_number(timeout_val)) {
2103 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2104 }
2105 float timeout_time = lbm_dec_as_float(timeout_val);
2106 lbm_value pats = get_cdr(get_cdr(ctx->curr_exp));
2107 receive_base(ctx, pats, timeout_time, true1);
2108}
2109
2110// Receive
2111// (recv (pattern expr)
2112// (pattern expr))
2113static void eval_receive(eval_context_t *ctx) {
2114
2115 if (is_atomic) {
2116 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2117 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
2118 }
2119 lbm_value pats = get_cdr(ctx->curr_exp);
2120 receive_base(ctx, pats, 0, false0);
2121}
2122
2123/*********************************************************/
2124/* Continuation functions */
2125
2126/* cont_set_global_env
2127 sp-1 : Key-symbol
2128 */
2129static void cont_set_global_env(eval_context_t *ctx){
2130
2131 lbm_value key;
2132 lbm_value val = ctx->r;
2133
2134 lbm_pop(&ctx->K, &key);
2135 lbm_uint dec_key = lbm_dec_sym(key);
2136 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
2137 lbm_value *global_env = lbm_get_global_env();
2138 lbm_uint orig_env = global_env[ix_key];
2139 lbm_value new_env;
2140 // A key is a symbol and should not need to be remembered.
2141 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2142
2143 global_env[ix_key] = new_env;
2144 ctx->r = val;
2145
2146 ctx->app_cont = true1;
2147
2148 return;
2149}
2150
2151static void cont_resume(eval_context_t *ctx) {
2152 lbm_pop_2(&ctx->K, &ctx->curr_env, &ctx->curr_exp);
2153}
2154
2155static void cont_progn_rest(eval_context_t *ctx) {
2156 lbm_value *sptr = get_stack_ptr(ctx, 3);
2157
2158 lbm_value rest = sptr[2];
2159 lbm_value env = sptr[0];
2160
2161 lbm_value rest_car, rest_cdr;
2162 get_car_and_cdr(rest, &rest_car, &rest_cdr);
2163 ctx->curr_exp = rest_car;
2164 ctx->curr_env = env;
2165 if (lbm_is_symbol_nil(rest_cdr)) {
2166 // allow for tail recursion
2167 lbm_stack_drop(&ctx->K, 3);
2168 } else {
2169 sptr[2] = rest_cdr;
2170 stack_reserve(ctx, 1)[0] = PROGN_REST(((4) << 2) | 0xF8000001u);
2171 }
2172}
2173
2174static void cont_wait(eval_context_t *ctx) {
2175
2176 lbm_value cid_val;
2177 lbm_pop(&ctx->K, &cid_val);
2178 lbm_cid cid = (lbm_cid)lbm_dec_i(cid_val);
2179
2180 bool_Bool exists = false0;
2181
2182 lbm_blocked_iterator(context_exists, &cid, &exists);
2183 lbm_running_iterator(context_exists, &cid, &exists);
2184
2185 if (ctx_running->id == cid) {
2186 exists = true1;
2187 }
2188
2189 if (exists) {
2190 lbm_value *sptr = stack_reserve(ctx, 2);
2191 sptr[0] = lbm_enc_i(cid);
2192 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2193 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2194 ctx->app_cont = true1;
2195 yield_ctx(50000);
2196 } else {
2197 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2198 ctx->app_cont = true1;
2199 }
2200}
2201
2202static lbm_value perform_setvar(lbm_value key, lbm_value val, lbm_value env) {
2203
2204 lbm_uint s = lbm_dec_sym(key);
2205 if (s >= RUNTIME_SYMBOLS_START0x40000) {
2206 lbm_value new_env = lbm_env_modify_binding(env, key, val);
2207 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2208 lbm_uint ix_key = lbm_dec_sym(key) & GLOBAL_ENV_MASK0x1F;
2209 lbm_value *glob_env = lbm_get_global_env();
2210 new_env = lbm_env_modify_binding(glob_env[ix_key], key, val);
2211 glob_env[ix_key] = new_env;
2212 }
2213 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2214 lbm_set_error_reason((char*)lbm_error_str_variable_not_bound);
2215 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), key);
2216 }
2217 return val;
2218 }
2219 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2220 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // unreachable
2221}
2222
2223static void apply_setvar(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2224 if (nargs == 2 && lbm_is_symbol(args[0])) {
2225 lbm_value res;
2226 WITH_GC(res, perform_setvar(args[0], args[1], ctx->curr_env))(res) = (perform_setvar(args[0], args[1], ctx->curr_env));
if (lbm_is_symbol_merror((res))) { gc(); (res) = (perform_setvar
(args[0], args[1], ctx->curr_env)); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2227 ctx->r = args[1];
2228 lbm_stack_drop(&ctx->K, nargs+1);
2229 ctx->app_cont = true1;
2230 } else {
2231 if (nargs == 2) lbm_set_error_reason((char*)lbm_error_str_incorrect_arg);
2232 else lbm_set_error_reason((char*)lbm_error_str_num_args);
2233 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2234 }
2235}
2236
2237static void apply_read_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, bool_Bool program, bool_Bool incremental) {
2238 if (nargs == 1) {
2239 lbm_value chan = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2240 if (lbm_type_of_functional(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2241 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2242 gc();
2243 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2244 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2245 }
2246 }
2247 } else if (lbm_type_of(args[0]) == LBM_TYPE_CHANNEL0x90000000u) {
2248 chan = args[0];
2249 } else {
2250 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2251 }
2252 lbm_value *sptr = get_stack_ptr(ctx, 2);
2253
2254 // If we are inside a reader, its settings are stored.
2255 sptr[0] = lbm_enc_u(ctx->flags); // flags stored.
2256 sptr[1] = chan;
2257 lbm_value *rptr = stack_reserve(ctx,1);
2258 rptr[0] = READ_DONE(((20) << 2) | 0xF8000001u);
2259
2260 // Each reader starts in a fresh situation
2261 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
2262
2263 if (program) {
2264 if (incremental) {
2265 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2266 lbm_value *rptr1 = stack_reserve(ctx,3);
2267 rptr1[0] = chan;
2268 rptr1[1] = ctx->curr_env;
2269 rptr1[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
2270 } else {
2271 ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2272 lbm_value *rptr1 = stack_reserve(ctx,4);
2273 rptr1[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2274 rptr1[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2275 rptr1[2] = chan;
2276 rptr1[3] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
2277 }
2278 }
2279 rptr = stack_reserve(ctx,3); // reuse of variable rptr
2280 rptr[0] = chan;
2281 rptr[1] = lbm_enc_u(1);
2282 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
2283 ctx->app_cont = true1;
2284 } else {
2285 lbm_set_error_reason((char*)lbm_error_str_num_args);
2286 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2287 }
2288}
2289
2290static void apply_read_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2291 apply_read_base(args,nargs,ctx,true1,false0);
2292}
2293
2294static void apply_read_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2295 apply_read_base(args,nargs,ctx,true1,true1);
2296}
2297
2298static void apply_read(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2299 apply_read_base(args,nargs,ctx,false0,false0);
2300}
2301
2302static void apply_spawn_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, uint32_t context_flags) {
2303
2304 lbm_uint stack_size = EVAL_CPS_DEFAULT_STACK_SIZE256;
2305 lbm_uint closure_pos = 0;
2306 char *name = NULL((void*)0);
2307
2308 if (nargs >= 1 &&
2309 lbm_is_closure(args[0])) {
2310 closure_pos = 0;
2311 } else if (nargs >= 2 &&
2312 lbm_is_number(args[0]) &&
2313 lbm_is_closure(args[1])) {
2314 stack_size = lbm_dec_as_u32(args[0]);
2315 closure_pos = 1;
2316 } else if (nargs >= 2 &&
2317 lbm_is_array_r(args[0]) &&
2318 lbm_is_closure(args[1])) {
2319 name = lbm_dec_str(args[0]);
2320 closure_pos = 1;
2321 }else if (nargs >= 3 &&
2322 lbm_is_array_r(args[0]) &&
2323 lbm_is_number(args[1]) &&
2324 lbm_is_closure(args[2])) {
2325 stack_size = lbm_dec_as_u32(args[1]);
2326 closure_pos = 2;
2327 name = lbm_dec_str(args[0]);
2328 } else {
2329 if (context_flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01)
2330 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN_TRAP(((0x30005) << 4) | 0x00000000u));
2331 else
2332 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN(((0x30004) << 4) | 0x00000000u));
2333 }
2334
2335 lbm_value cl[3];
2336 extract_n(get_cdr(args[closure_pos]), cl, 3);
2337 lbm_value curr_param = cl[CLO_PARAMS0];
2338 lbm_value clo_env = cl[CLO_ENV2];
2339 lbm_uint i = closure_pos + 1;
2340 while (lbm_is_cons(curr_param) && i <= nargs) {
2341 lbm_value entry = cons_with_gc(get_car(curr_param), args[i], clo_env);
2342 lbm_value aug_env = cons_with_gc(entry, clo_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2343 clo_env = aug_env;
2344 curr_param = get_cdr(curr_param);
2345 i ++;
2346 }
2347
2348 lbm_stack_drop(&ctx->K, nargs+1);
2349
2350 lbm_value program = cons_with_gc(cl[CLO_BODY1], ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), clo_env);
2351
2352 lbm_cid cid = lbm_create_ctx_parent(program,
2353 clo_env,
2354 stack_size,
2355 lbm_get_current_cid(),
2356 context_flags,
2357 name);
2358 ctx->r = lbm_enc_i(cid);
2359 ctx->app_cont = true1;
2360}
2361
2362static void apply_spawn(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2363 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00);
2364}
2365
2366static void apply_spawn_trap(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2367 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01);
2368}
2369
2370static void apply_yield(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2371 if (is_atomic) {
2372 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2373 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2374 }
2375 if (nargs == 1 && lbm_is_number(args[0])) {
2376 lbm_uint ts = lbm_dec_as_u32(args[0]);
2377 lbm_stack_drop(&ctx->K, nargs+1);
2378 yield_ctx(ts);
2379 } else {
2380 lbm_set_error_reason((char*)lbm_error_str_no_number);
2381 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2382 }
2383}
2384
2385static void apply_sleep(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2386 if (is_atomic) {
2387 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2388 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2389 }
2390 if (nargs == 1 && lbm_is_number(args[0])) {
2391 lbm_uint ts = (lbm_uint)(1000000.0f * lbm_dec_as_float(args[0]));
2392 lbm_stack_drop(&ctx->K, nargs+1);
2393 yield_ctx(ts);
2394 } else {
2395 lbm_set_error_reason((char*)lbm_error_str_no_number);
2396 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2397 }
2398}
2399
2400static void apply_wait(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2401 if (nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2402 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2403 lbm_value *sptr = get_stack_ptr(ctx, 2);
2404 sptr[0] = lbm_enc_i(cid);
2405 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2406 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2407 ctx->app_cont = true1;
2408 yield_ctx(50000);
2409 } else {
2410 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_WAIT(((0x30007) << 4) | 0x00000000u));
2411 }
2412}
2413
2414/* (eval expr)
2415 (eval env expr) */
2416static void apply_eval(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2417 if ( nargs == 1) {
2418 ctx->curr_exp = args[0];
2419 } else if (nargs == 2) {
2420 ctx->curr_exp = args[1];
2421 ctx->curr_env = args[0];
2422 } else {
2423 lbm_set_error_reason((char*)lbm_error_str_num_args);
2424 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL(((0x30008) << 4) | 0x00000000u));
2425 }
2426 lbm_stack_drop(&ctx->K, nargs+1);
2427}
2428
2429static void apply_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2430 int prg_pos = 0;
2431 if (nargs == 2) {
2432 prg_pos = 1;
2433 ctx->curr_env = args[0];
2434 }
2435 if (nargs == 1 || nargs == 2) {
2436 lbm_value prg = args[prg_pos];
2437 lbm_value app_cont;
2438 lbm_value app_cont_prg;
2439 lbm_value new_prg;
2440 lbm_value prg_copy;
2441
2442 int len = -1;
2443 WITH_GC(prg_copy, lbm_list_copy(&len, prg))(prg_copy) = (lbm_list_copy(&len, prg)); if (lbm_is_symbol_merror
((prg_copy))) { gc(); (prg_copy) = (lbm_list_copy(&len, prg
)); if (lbm_is_symbol_merror((prg_copy))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2444 lbm_stack_drop(&ctx->K, nargs+1);
2445
2446 if (ctx->K.sp > nargs+2) { // if there is a continuation
2447 app_cont = cons_with_gc(ENC_SYM_APP_CONT(((0x111) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2448 app_cont_prg = cons_with_gc(app_cont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2449 new_prg = lbm_list_append(app_cont_prg, ctx->program);
2450 new_prg = lbm_list_append(prg_copy, new_prg);
2451 } else {
2452 new_prg = lbm_list_append(prg_copy, ctx->program);
2453 }
2454 if (!lbm_is_list(new_prg)) {
2455 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2456 }
2457 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);
2458 ctx->program = get_cdr(new_prg);
2459 ctx->curr_exp = get_car(new_prg);
2460 } else {
2461 lbm_set_error_reason((char*)lbm_error_str_num_args);
2462 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2463 }
2464}
2465
2466static void apply_send(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2467 if (nargs == 2) {
2468 if (lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2469 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2470 lbm_value msg = args[1];
2471 lbm_value status = lbm_find_receiver_and_send(cid, msg);
2472 /* return the status */
2473 lbm_stack_drop(&ctx->K, nargs+1);
2474 ctx->r = status;
2475 ctx->app_cont = true1;
2476 } else {
2477 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2478 }
2479 } else {
2480 lbm_set_error_reason((char*)lbm_error_str_num_args);
2481 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2482 }
2483}
2484
2485static void apply_ok(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2486 lbm_value ok_val = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2487 if (nargs >= 1) {
2488 ok_val = args[0];
2489 }
2490 ctx->r = ok_val;
2491 ok_ctx();
2492}
2493
2494static void apply_error(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2495 (void) ctx;
2496 lbm_value err_val = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
2497 if (nargs >= 1) {
2498 err_val = args[0];
2499 }
2500 error_at_ctx(err_val, ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
2501}
2502
2503// (map f arg-list)
2504static void apply_map(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2505 if (nargs == 2 && lbm_is_cons(args[1])) {
2506 lbm_value *sptr = get_stack_ptr(ctx, 3);
2507
2508 lbm_value f = args[0];
2509 lbm_value h = get_car(args[1]);
2510 lbm_value t = get_cdr(args[1]);
2511
2512 lbm_value appli_1;
2513 lbm_value appli;
2514 WITH_GC(appli_1, lbm_heap_allocate_list(2))(appli_1) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli_1))) { gc(); (appli_1) = (lbm_heap_allocate_list(2));
if (lbm_is_symbol_merror((appli_1))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2515 WITH_GC_RMBR_1(appli, lbm_heap_allocate_list(2), appli_1)(appli) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli))) { lbm_gc_mark_phase(appli_1); gc(); (appli) = (lbm_heap_allocate_list
(2)); if (lbm_is_symbol_merror((appli))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2516
2517 lbm_value appli_0 = get_cdr(appli_1);
2518
2519 lbm_set_car_and_cdr(appli_0, h, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2520 lbm_set_car(appli_1, ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u));
2521
2522 lbm_set_car_and_cdr(get_cdr(appli), appli_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2523 lbm_set_car(appli, f);
2524
2525 lbm_value elt = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), appli);
2526 sptr[0] = t; // reuse stack space
2527 sptr[1] = ctx->curr_env;
2528 sptr[2] = elt;
2529 lbm_value *rptr = stack_reserve(ctx,4);
2530 rptr[0] = elt;
2531 rptr[1] = appli;
2532 rptr[2] = appli_0;
2533 rptr[3] = MAP(((26) << 2) | 0xF8000001u);
2534 ctx->curr_exp = appli;
2535 } else if (nargs == 2 && lbm_is_symbol_nil(args[1])) {
2536 lbm_stack_drop(&ctx->K, 3);
2537 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2538 ctx->app_cont = true1;
2539 return;
2540 } else {
2541 lbm_set_error_reason((char*)lbm_error_str_num_args);
2542 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_MAP(((0x3000D) << 4) | 0x00000000u));
2543 }
2544}
2545
2546static void apply_reverse(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2547 if (nargs == 1 && lbm_is_list(args[0])) {
2548 lbm_value curr = args[0];
2549
2550 lbm_value new_list = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2551 while (lbm_is_cons(curr)) {
2552 lbm_value tmp = cons_with_gc(get_car(curr), new_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2553 new_list = tmp;
2554 curr = get_cdr(curr);
2555 }
2556 lbm_stack_drop(&ctx->K, 2);
2557 ctx->r = new_list;
2558 ctx->app_cont = true1;
2559 } else {
2560 lbm_set_error_reason("Reverse requires a list argument");
2561 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_REVERSE(((0x3000E) << 4) | 0x00000000u));
2562 }
2563}
2564
2565static void apply_flatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2566 if (nargs == 1) {
2567
2568 lbm_value v = flatten_value(args[0]);
2569 if ( v == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)) {
2570 gc();
2571 v = flatten_value(args[0]);
2572 }
2573
2574 if (lbm_is_symbol(v)) {
2575 error_at_ctx(v, ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2576 } else {
2577 lbm_stack_drop(&ctx->K, 2);
2578 ctx->r = v;
2579 ctx->app_cont = true1;
2580 }
2581 return;
2582 }
2583 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2584}
2585
2586static void apply_unflatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2587 if(nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2588 lbm_array_header_t *array;
2589 array = (lbm_array_header_t *)get_car(args[0]);
2590
2591 lbm_flat_value_t fv;
2592 fv.buf = (uint8_t*)array->data;
2593 fv.buf_size = array->size;
2594 fv.buf_pos = 0;
2595
2596 lbm_value res;
2597
2598 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2599 if (lbm_unflatten_value(&fv, &res)) {
2600 ctx->r = res;
2601 }
2602 lbm_stack_drop(&ctx->K, 2);
2603 ctx->app_cont = true1;
2604 return;
2605 }
2606 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_UNFLATTEN(((0x30010) << 4) | 0x00000000u));
2607}
2608
2609static void apply_kill(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2610 if (nargs == 2 && lbm_is_number(args[0])) {
2611 lbm_cid cid = lbm_dec_as_i32(args[0]);
2612
2613 if (ctx->id == cid) {
2614 ctx->r = args[1];
2615 finish_ctx();
2616 return;
2617 }
2618 mutex_lock(&qmutex);
2619 eval_context_t *found = NULL((void*)0);
2620 found = lookup_ctx_nm(&blocked, cid);
2621 if (found)
2622 drop_ctx_nm(&blocked, found);
2623 else
2624 found = lookup_ctx_nm(&queue, cid);
2625 if (found)
2626 drop_ctx_nm(&queue, found);
2627
2628 if (found) {
2629 found->K.data[found->K.sp - 1] = KILL(((40) << 2) | 0xF8000001u);
2630 found->r = args[1];
2631 found->app_cont = true1;
2632 enqueue_ctx_nm(&queue,found);
2633 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2634 } else {
2635 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2636 }
2637 lbm_stack_drop(&ctx->K, 3);
2638 ctx->app_cont = true1;
2639 mutex_unlock(&qmutex);
2640 return;
2641 }
2642 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_KILL(((0x30011) << 4) | 0x00000000u));
2643}
2644
2645// (merge comparator list1 list2)
2646static void apply_merge(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2647 if (nargs == 3 && lbm_is_list(args[1]) && lbm_is_list(args[2])) {
2648
2649 if (!lbm_is_closure(args[0])) {
2650 lbm_value closure;
2651 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2652 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2653 lbm_value cl1 = lbm_cdr(closure);
2654 lbm_value par;
2655 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2656 lbm_set_car(cl1, par);
2657 lbm_value cl2 = lbm_cdr(cl1);
2658 lbm_value body;
2659 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2660 lbm_set_car(cl2, body);
2661 lbm_value cl3 = lbm_cdr(cl2);
2662 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2663
2664 // Replace operator on stack with closure and rest of the code is
2665 // compatible.
2666 args[0] = closure;
2667 }
2668
2669 // Copy input lists for functional behaviour at top-level
2670 // merge itself is in-place in the copied lists.
2671 lbm_value a;
2672 lbm_value b;
2673 int len_a = -1;
2674 int len_b = -1;
2675 WITH_GC(a, lbm_list_copy(&len_a, args[1]))(a) = (lbm_list_copy(&len_a, args[1])); if (lbm_is_symbol_merror
((a))) { gc(); (a) = (lbm_list_copy(&len_a, args[1])); if
(lbm_is_symbol_merror((a))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } };
2676 WITH_GC_RMBR_1(b, lbm_list_copy(&len_b, args[2]), a)(b) = (lbm_list_copy(&len_b, args[2])); if (lbm_is_symbol_merror
((b))) { lbm_gc_mark_phase(a); gc(); (b) = (lbm_list_copy(&
len_b, args[2])); if (lbm_is_symbol_merror((b))) { error_ctx(
(((0x23) << 4) | 0x00000000u)); } };
2677
2678 if (len_a == 0) {
2679 ctx->r = b;
2680 lbm_stack_drop(&ctx->K, 4);
2681 ctx->app_cont = true1;
2682 return;
2683 }
2684 if (len_b == 0) {
2685 ctx->r = a;
2686 lbm_stack_drop(&ctx->K, 4);
2687 ctx->app_cont = true1;
2688 return;
2689 }
2690
2691 args[1] = a; // keep safe by replacing the original on stack.
2692 args[2] = b;
2693
2694 lbm_value a_1 = a;
2695 lbm_value a_rest = lbm_cdr(a);
2696 lbm_value b_1 = b;
2697 lbm_value b_rest = lbm_cdr(b);
2698
2699 lbm_value cl[3]; // Comparator closure
2700 extract_n(lbm_cdr(args[0]), cl, 3);
2701 lbm_value cmp_env = cl[CLO_ENV2];
2702 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2703 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2704 lbm_uint len = lbm_list_length(cl[CLO_PARAMS0]);
2705 if (len == 2) {
2706 par1 = get_car(cl[CLO_PARAMS0]);
2707 par2 = get_cadr(cl[CLO_PARAMS0]);
2708 lbm_value new_env0;
2709 lbm_value new_env;
2710 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a_1)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a_1))); if (
lbm_is_symbol_merror((new_env0))) { gc(); (new_env0) = (lbm_env_set
(cmp_env, par1, lbm_car(a_1))); if (lbm_is_symbol_merror((new_env0
))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2711 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b_1)),new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1))); if (
lbm_is_symbol_merror((new_env))) { lbm_gc_mark_phase(new_env0
); gc(); (new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1
))); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2712 cmp_env = new_env;
2713 } else {
2714 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2715 }
2716 lbm_set_cdr(a_1, b_1);
2717 lbm_set_cdr(b_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2718 lbm_value cmp = cl[CLO_BODY1];
2719
2720 lbm_stack_drop(&ctx->K, 4); // TODO: Optimize drop 4 alloc 10 into alloc 6
2721 lbm_uint *sptr = stack_reserve(ctx, 10);
2722 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged list
2723 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged list
2724 sptr[2] = a_1;
2725 sptr[3] = a_rest;
2726 sptr[4] = b_rest;
2727 sptr[5] = cmp;
2728 sptr[6] = cmp_env;
2729 sptr[7] = par1;
2730 sptr[8] = par2;
2731 sptr[9] = MERGE_REST(((43) << 2) | 0xF8000001u);
2732 ctx->curr_exp = cl[CLO_BODY1];
2733 ctx->curr_env = cmp_env;
2734 return;
2735 }
2736 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MERGE(((0x30013) << 4) | 0x00000000u));
2737}
2738
2739// (sort comparator list)
2740static void apply_sort(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2741 if (nargs == 2 && lbm_is_list(args[1])) {
2742
2743 if (!lbm_is_closure(args[0])) {
2744 lbm_value closure;
2745 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2746 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2747 lbm_value cl1 = lbm_cdr(closure);
2748 lbm_value par;
2749 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2750 lbm_set_car(cl1, par);
2751 lbm_value cl2 = lbm_cdr(cl1);
2752 lbm_value body;
2753 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2754 lbm_set_car(cl2, body);
2755 lbm_value cl3 = lbm_cdr(cl2);
2756 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2757
2758 // Replace operator on stack with closure and rest of the code is
2759 // compatible.
2760 args[0] = closure;
2761 }
2762
2763 int len = -1;
2764 lbm_value list_copy;
2765 WITH_GC(list_copy, lbm_list_copy(&len, args[1]))(list_copy) = (lbm_list_copy(&len, args[1])); if (lbm_is_symbol_merror
((list_copy))) { gc(); (list_copy) = (lbm_list_copy(&len,
args[1])); if (lbm_is_symbol_merror((list_copy))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2766 if (len <= 1) {
2767 lbm_stack_drop(&ctx->K, 3);
2768 ctx->r = list_copy;
2769 ctx->app_cont = true1;
2770 return;
2771 }
2772
2773 args[1] = list_copy; // Keep safe, original replaced on stack.
2774
2775 // Take the headmost 2, 1-element sublists.
2776 lbm_value a = list_copy;
2777 lbm_value b = lbm_cdr(a);
2778 lbm_value rest = lbm_cdr(b);
2779 // Do not terminate b. keep rest of list safe from GC in the following
2780 // closure extraction.
2781 //lbm_set_cdr(a, b); // This is void
2782
2783 lbm_value cl[3]; // Comparator closure
2784 extract_n(lbm_cdr(args[0]), cl, 3);
2785 lbm_value cmp_env = cl[CLO_ENV2];
2786 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2787 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2788 lbm_uint cl_len = lbm_list_length(cl[CLO_PARAMS0]);
2789 if (cl_len == 2) {
2790 par1 = get_car(cl[CLO_PARAMS0]);
2791 par2 = get_cadr(cl[CLO_PARAMS0]);
2792 lbm_value new_env0;
2793 lbm_value new_env;
2794 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a))); if (lbm_is_symbol_merror
((new_env0))) { gc(); (new_env0) = (lbm_env_set(cmp_env, par1
, lbm_car(a))); if (lbm_is_symbol_merror((new_env0))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2795 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b)), new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { lbm_gc_mark_phase(new_env0); gc(); (new_env) =
(lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { error_ctx((((0x23) << 4) | 0x00000000u))
; } };
2796 cmp_env = new_env;
2797 } else {
2798 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2799 }
2800 lbm_value cmp = cl[CLO_BODY1];
2801
2802 // Terminate the comparator argument list.
2803 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2804
2805 lbm_stack_drop(&ctx->K, 3); //TODO: optimize drop 3, alloc 20 into alloc 17
2806 lbm_uint *sptr = stack_reserve(ctx, 20);
2807 sptr[0] = cmp;
2808 sptr[1] = cmp_env;
2809 sptr[2] = par1;
2810 sptr[3] = par2;
2811 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged accumulation of sublists
2812 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged accumulation of sublists
2813 sptr[6] = rest;
2814 sptr[7] = lbm_enc_i(1);
2815 sptr[8] = lbm_enc_i(len); //TODO: 28 bit i vs 32 bit i
2816 sptr[9] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
2817 sptr[10] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged sublist
2818 sptr[11] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged sublist
2819 sptr[12] = a;
2820 sptr[13] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no a_rest, 1 element lists in layer 1.
2821 sptr[14] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no b_rest, 1 element lists in layer 1.
2822 sptr[15] = cmp;
2823 sptr[16] = cmp_env;
2824 sptr[17] = par1;
2825 sptr[18] = par2;
2826 sptr[19] = MERGE_REST(((43) << 2) | 0xF8000001u);
2827 ctx->curr_exp = cmp;
2828 ctx->curr_env = cmp_env;
2829 return;
2830 }
2831 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
2832}
2833
2834static void apply_rest_args(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2835 lbm_value res;
2836 if (lbm_env_lookup_b(&res, ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ctx->curr_env)) {
2837 if (nargs == 1 && lbm_is_number(args[0])) {
2838 int32_t ix = lbm_dec_as_i32(args[0]);
2839 res = lbm_index_list(res, ix);
2840 }
2841 ctx->r = res;
2842 } else {
2843 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2844 }
2845 lbm_stack_drop(&ctx->K, nargs+1);
2846 ctx->app_cont = true1;
2847}
2848
2849/* (rotate list-expr dist/dir-expr) */
2850static void apply_rotate(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2851 if (nargs == 2 && lbm_is_list(args[0]) && lbm_is_number(args[1])) {
2852 int len = -1;
2853 lbm_value ls = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2854 WITH_GC(ls, lbm_list_copy(&len, args[0]))(ls) = (lbm_list_copy(&len, args[0])); if (lbm_is_symbol_merror
((ls))) { gc(); (ls) = (lbm_list_copy(&len, args[0])); if
(lbm_is_symbol_merror((ls))) { error_ctx((((0x23) << 4
) | 0x00000000u)); } };
2855 int dist = lbm_dec_as_i32(args[1]);
2856 if (len > 0 && dist != 0) {
2857 int d = dist;
2858 if (dist > 0) {
2859 ls = lbm_list_destructive_reverse(ls);
2860 } else {
2861 d = -dist;
2862 }
2863
2864 lbm_value start = ls;
2865 lbm_value end = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2866 lbm_value curr = start;
2867 while (lbm_is_cons(curr)) {
2868 end = curr;
2869 curr = get_cdr(curr);
2870 }
2871
2872 for (int i = 0; i < d; i ++) {
2873 lbm_value a = start;
2874 start = lbm_cdr(start);
2875 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2876 lbm_set_cdr(end, a);
2877 end = a;
2878 }
2879 ls = start;
2880 if (dist > 0) {
2881 ls = lbm_list_destructive_reverse(ls);
2882 }
2883 }
2884 lbm_stack_drop(&ctx->K, nargs+1);
2885 ctx->app_cont = true1;
2886 ctx->r = ls;
2887 return;
2888 }
2889 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2890}
2891
2892/***************************************************/
2893/* Application lookup table */
2894
2895typedef void (*apply_fun)(lbm_value *, lbm_uint, eval_context_t *);
2896static const apply_fun fun_table[] =
2897 {
2898 apply_setvar,
2899 apply_read,
2900 apply_read_program,
2901 apply_read_eval_program,
2902 apply_spawn,
2903 apply_spawn_trap,
2904 apply_yield,
2905 apply_wait,
2906 apply_eval,
2907 apply_eval_program,
2908 apply_send,
2909 apply_ok,
2910 apply_error,
2911 apply_map,
2912 apply_reverse,
2913 apply_flatten,
2914 apply_unflatten,
2915 apply_kill,
2916 apply_sleep,
2917 apply_merge,
2918 apply_sort,
2919 apply_rest_args,
2920 apply_rotate,
2921 };
2922
2923/***************************************************/
2924/* Application of function that takes arguments */
2925/* passed over the stack. */
2926
2927static void application(eval_context_t *ctx, lbm_value *fun_args, lbm_uint arg_count) {
2928 /* If arriving here, we know that the fun is a symbol.
2929 * and can be a built in operation or an extension.
2930 */
2931 lbm_value fun = fun_args[0];
2932
2933 lbm_uint fun_val = lbm_dec_sym(fun);
2934 lbm_uint fun_kind = SYMBOL_KIND(fun_val)((fun_val) >> 16);
2935
2936 switch (fun_kind) {
2937 case SYMBOL_KIND_EXTENSION1: {
2938 extension_fptr f = extension_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)].fptr;
2939
2940 lbm_value ext_res;
2941 WITH_GC(ext_res, f(&fun_args[1], arg_count))(ext_res) = (f(&fun_args[1], arg_count)); if (lbm_is_symbol_merror
((ext_res))) { gc(); (ext_res) = (f(&fun_args[1], arg_count
)); if (lbm_is_symbol_merror((ext_res))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2942 if (lbm_is_error(ext_res)) { //Error other than merror
2943 error_at_ctx(ext_res, fun);
2944 }
2945 lbm_stack_drop(&ctx->K, arg_count + 1);
2946
2947 ctx->app_cont = true1;
2948 ctx->r = ext_res;
2949
2950 if (blocking_extension) {
2951 blocking_extension = false0;
2952 if (blocking_extension_timeout) {
2953 blocking_extension_timeout = false0;
2954 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, blocking_extension_timeout_us,true1);
2955 } else {
2956 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,true1);
2957 }
2958 mutex_unlock(&blocking_extension_mutex);
2959 }
2960 } break;
2961 case SYMBOL_KIND_FUNDAMENTAL2:
2962 call_fundamental(SYMBOL_IX(fun_val)((fun_val) & 0xFFFF), &fun_args[1], arg_count, ctx);
2963 break;
2964 case SYMBOL_KIND_APPFUN3:
2965 fun_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)](&fun_args[1], arg_count, ctx);
2966 break;
2967 default:
2968 // Symbols that are "special" but not in the way caught above
2969 // ends up here.
2970 lbm_set_error_reason("Symbol does not represent a function");
2971 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),fun_args[0]);
2972 break;
2973 }
2974}
2975
2976static void cont_closure_application_args(eval_context_t *ctx) {
2977 lbm_uint* sptr = get_stack_ptr(ctx, 5);
2978
2979 lbm_value arg_env = (lbm_value)sptr[0];
2980 lbm_value exp = (lbm_value)sptr[1];
2981 lbm_value clo_env = (lbm_value)sptr[2];
2982 lbm_value params = (lbm_value)sptr[3];
2983 lbm_value args = (lbm_value)sptr[4];
2984
2985 lbm_value car_params, cdr_params;
1
'cdr_params' declared without an initial value
→
2986 get_car_and_cdr(params, &car_params, &cdr_params);
2
←
Calling 'get_car_and_cdr'
→
7
←
Returning from 'get_car_and_cdr'
→
2987
2988 bool_Bool a_nil = lbm_is_symbol_nil(args);
2989 bool_Bool p_nil = lbm_is_symbol_nil(cdr_params);
8
←
1st function call argument is an uninitialized value
2990
2991 lbm_value binder = allocate_binding(car_params, ctx->r, clo_env);
2992
2993 if (!a_nil && !p_nil) {
2994 lbm_value car_args, cdr_args;
2995 get_car_and_cdr(args, &car_args, &cdr_args);
2996 sptr[2] = binder;
2997 sptr[3] = cdr_params;
2998 sptr[4] = cdr_args;
2999 stack_reserve(ctx,1)[0] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
3000 ctx->curr_exp = car_args;
3001 ctx->curr_env = arg_env;
3002 } else if (a_nil && p_nil) {
3003 // Arguments and parameters match up in number
3004 lbm_stack_drop(&ctx->K, 5);
3005 ctx->curr_env = binder;
3006 ctx->curr_exp = exp;
3007 } else if (p_nil) {
3008 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), binder);
3009 sptr[2] = rest_binder;
3010 sptr[3] = get_cdr(args);
3011 sptr[4] = get_car(rest_binder); // last element of rest_args so far
3012 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3013 ctx->curr_exp = get_car(args);
3014 ctx->curr_env = arg_env;
3015 } else {
3016 lbm_set_error_reason((char*)lbm_error_str_num_args);
3017 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
3018 }
3019}
3020
3021
3022static void cont_closure_args_rest(eval_context_t *ctx) {
3023 lbm_uint* sptr = get_stack_ptr(ctx, 5);
3024 lbm_value arg_env = (lbm_value)sptr[0];
3025 lbm_value exp = (lbm_value)sptr[1];
3026 lbm_value clo_env = (lbm_value)sptr[2];
3027 lbm_value args = (lbm_value)sptr[3];
3028 lbm_value last = (lbm_value)sptr[4];
3029 lbm_cons_t* heap = lbm_heap_state.heap;
3030
3031 lbm_value binding = lbm_heap_state.freelist;
3032 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3033 gc();
3034 binding = lbm_heap_state.freelist;
3035 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3036 }
3037 lbm_uint binding_ix = lbm_dec_ptr(binding);
3038 lbm_heap_state.freelist = heap[binding_ix].cdr;
3039 lbm_heap_state.num_alloc += 1;
3040 heap[binding_ix].car = ctx->r;
3041 heap[binding_ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3042
3043
3044 lbm_set_cdr(last, binding);
3045 sptr[4] = binding;
3046
3047 if (args == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3048 lbm_stack_drop(&ctx->K, 5);
3049 ctx->curr_env = clo_env;
3050 ctx->curr_exp = exp;
3051 } else {
3052 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3053 sptr[3] = get_cdr(args);
3054 ctx->curr_exp = get_car(args);
3055 ctx->curr_env = arg_env;
3056 }
3057}
3058
3059static void cont_application_args(eval_context_t *ctx) {
3060 lbm_uint *sptr = get_stack_ptr(ctx, 3);
3061
3062 lbm_value env = sptr[0];
3063 lbm_value rest = sptr[1];
3064 lbm_value count = sptr[2];
3065
3066 ctx->curr_env = env;
3067 sptr[0] = ctx->r; // Function 1st then Arguments
3068 if (lbm_is_cons(rest)) {
3069 lbm_cons_t *cell = lbm_ref_cell(rest);
3070 sptr[1] = env;
3071 sptr[2] = cell->cdr;
3072 lbm_value *rptr = stack_reserve(ctx,2);
3073 rptr[0] = count + (1 << LBM_VAL_SHIFT4);
3074 rptr[1] = APPLICATION_ARGS(((5) << 2) | 0xF8000001u);
3075 ctx->curr_exp = cell->car;
3076 } else {
3077 // No more arguments
3078 lbm_stack_drop(&ctx->K, 2);
3079 lbm_uint nargs = lbm_dec_u(count);
3080 lbm_value *args = get_stack_ptr(ctx, (uint32_t)(nargs + 1));
3081 application(ctx,args, nargs);
3082 }
3083}
3084
3085static void cont_and(eval_context_t *ctx) {
3086 lbm_value env;
3087 lbm_value rest;
3088 lbm_value arg = ctx->r;
3089 lbm_pop_2(&ctx->K, &rest, &env);
3090 if (lbm_is_symbol_nil(arg)) {
3091 ctx->app_cont = true1;
3092 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3093 } else if (lbm_is_symbol_nil(rest)) {
3094 ctx->app_cont = true1;
3095 } else {
3096 lbm_value *sptr = stack_reserve(ctx, 3);
3097 sptr[0] = env;
3098 sptr[1] = get_cdr(rest);
3099 sptr[2] = AND(((6) << 2) | 0xF8000001u);
3100 ctx->curr_env = env;
3101 ctx->curr_exp = get_car(rest);
3102 }
3103}
3104
3105static void cont_or(eval_context_t *ctx) {
3106 lbm_value env;
3107 lbm_value rest;
3108 lbm_value arg = ctx->r;
3109 lbm_pop_2(&ctx->K, &rest, &env);
3110 if (!lbm_is_symbol_nil(arg)) {
3111 ctx->app_cont = true1;
3112 } else if (lbm_is_symbol_nil(rest)) {
3113 ctx->app_cont = true1;
3114 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3115 } else {
3116 lbm_value *sptr = stack_reserve(ctx, 3);
3117 sptr[0] = env;
3118 sptr[1] = get_cdr(rest);
3119 sptr[2] = OR(((7) << 2) | 0xF8000001u);
3120 ctx->curr_exp = get_car(rest);
3121 ctx->curr_env = env;
3122 }
3123}
3124
3125static int fill_binding_location(lbm_value key, lbm_value value, lbm_value env) {
3126 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) {
3127 if (key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return FB_OK0;
3128 lbm_env_modify_binding(env,key,value);
3129 return FB_OK0;
3130 } else if (lbm_is_cons(key) &&
3131 lbm_is_cons(value)) {
3132 int r = fill_binding_location(get_car(key), get_car(value), env);
3133 if (r == FB_OK0) {
3134 r = fill_binding_location(get_cdr(key), get_cdr(value), env);
3135 }
3136 return r;
3137 }
3138 return FB_TYPE_ERROR-1;
3139}
3140
3141static void cont_bind_to_key_rest(eval_context_t *ctx) {
3142
3143 lbm_value *sptr = get_stack_ptr(ctx, 4);
3144
3145 lbm_value rest = sptr[1];
3146 lbm_value env = sptr[2];
3147 lbm_value key = sptr[3];
3148
3149 if (fill_binding_location(key, ctx->r, env) < 0) {
3150 lbm_set_error_reason("Incorrect type of name/key in let-binding");
3151 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
3152 }
3153
3154 if (lbm_is_cons(rest)) {
3155 lbm_value car_rest = get_car(rest);
3156 lbm_value key_val[2];
3157 extract_n(car_rest, key_val, 2);
3158
3159 sptr[1] = get_cdr(rest);
3160 sptr[3] = key_val[0];
3161 stack_reserve(ctx,1)[0] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
3162 ctx->curr_exp = key_val[1];
3163 ctx->curr_env = env;
3164 } else {
3165 // Otherwise evaluate the expression in the populated env
3166 ctx->curr_exp = sptr[0];
3167 ctx->curr_env = env;
3168 lbm_stack_drop(&ctx->K, 4);
3169 }
3170}
3171
3172static void cont_if(eval_context_t *ctx) {
3173
3174 lbm_value arg = ctx->r;
3175
3176 lbm_value *sptr = pop_stack_ptr(ctx, 2);
3177
3178 ctx->curr_env = sptr[1];
3179 if (lbm_is_symbol_nil(arg)) {
3180 ctx->curr_exp = get_cadr(sptr[0]); // else branch
3181 } else {
3182 ctx->curr_exp = get_car(sptr[0]); // then branch
3183 }
3184}
3185
3186static void cont_match(eval_context_t *ctx) {
3187 lbm_value e = ctx->r;
3188 bool_Bool do_gc = false0;
3189
3190 lbm_uint *sptr = get_stack_ptr(ctx, 2);
3191 lbm_value patterns = (lbm_value)sptr[0];
3192 lbm_value orig_env = (lbm_value)sptr[1]; // restore enclosing environment.
3193 lbm_value new_env = orig_env;
3194
3195 if (lbm_is_symbol_nil(patterns)) {
3196 // no more patterns
3197 lbm_stack_drop(&ctx->K, 2);
3198 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
3199 ctx->app_cont = true1;
3200 } else if (lbm_is_cons(patterns)) {
3201 lbm_value match_case = get_car(patterns);
3202 lbm_value pattern = get_car(match_case);
3203 lbm_value n1 = get_cadr(match_case);
3204 lbm_value n2 = get_cadr(get_cdr(match_case));
3205 lbm_value body;
3206 bool_Bool check_guard = false0;
3207 if (lbm_is_symbol_nil(n2)) { // TODO: Not a very robust check.
3208 body = n1;
3209 } else {
3210 body = n2;
3211 check_guard = true1;
3212 }
3213
3214 bool_Bool is_match = match(pattern, e, &new_env, &do_gc);
3215 if (do_gc) {
3216 gc();
3217 do_gc = false0;
3218 new_env = orig_env;
3219 is_match = match(pattern, e, &new_env, &do_gc);
3220 if (do_gc) {
3221 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3222 }
3223 }
3224 if (is_match) {
3225 if (check_guard) {
3226 lbm_value *rptr = stack_reserve(ctx,5);
3227 sptr[0] = get_cdr(patterns);
3228 sptr[1] = ctx->curr_env;
3229 rptr[0] = MATCH(((9) << 2) | 0xF8000001u);
3230 rptr[1] = new_env;
3231 rptr[2] = body;
3232 rptr[3] = e;
3233 rptr[4] = MATCH_GUARD(((27) << 2) | 0xF8000001u);
3234 ctx->curr_env = new_env;
3235 ctx->curr_exp = n1; // The guard
3236 } else {
3237 lbm_stack_drop(&ctx->K, 2);
3238 ctx->curr_env = new_env;
3239 ctx->curr_exp = body;
3240 }
3241 } else {
3242 // set up for checking of next pattern
3243 sptr[0] = get_cdr(patterns);
3244 sptr[1] = orig_env;
3245 stack_reserve(ctx,1)[0] = MATCH(((9) << 2) | 0xF8000001u);
3246 // leave r unaltered
3247 ctx->app_cont = true1;
3248 }
3249 } else {
3250 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MATCH(((0x108) << 4) | 0x00000000u));
3251 }
3252}
3253
3254static void cont_exit_atomic(eval_context_t *ctx) {
3255 is_atomic --;
3256 ctx->app_cont = true1;
3257}
3258
3259static void cont_map(eval_context_t *ctx) {
3260 lbm_value *sptr = get_stack_ptr(ctx, 6);
3261
3262 lbm_value ls = sptr[0];
3263 lbm_value env = sptr[1];
3264 lbm_value t = sptr[3];
3265 lbm_set_car(t, ctx->r); // update car field tailmost position.
3266 if (lbm_is_cons(ls)) {
3267 lbm_value next, rest;
3268 get_car_and_cdr(ls, &next, &rest);
3269 sptr[0] = rest;
3270 stack_reserve(ctx,1)[0] = MAP(((26) << 2) | 0xF8000001u);
3271 lbm_set_car(sptr[5], next); // new arguments
3272
3273 lbm_value elt = cons_with_gc(ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3274 lbm_set_cdr(t, elt);
3275 sptr[3] = elt; // (r1 ... rN . (nil . nil))
3276 ctx->curr_exp = sptr[4];
3277 ctx->curr_env = env;
3278 } else {
3279 ctx->r = sptr[2]; //head of result list
3280 ctx->curr_env = env;
3281 lbm_stack_drop(&ctx->K, 6);
3282 ctx->app_cont = true1;
3283 }
3284}
3285
3286static void cont_match_guard(eval_context_t *ctx) {
3287 if (lbm_is_symbol_nil(ctx->r)) {
3288 lbm_value e;
3289 lbm_pop(&ctx->K, &e);
3290 lbm_stack_drop(&ctx->K, 2);
3291 ctx->r = e;
3292 ctx->app_cont = true1;
3293 } else {
3294 lbm_value body;
3295 lbm_value env;
3296 lbm_stack_drop(&ctx->K, 1);
3297 lbm_pop_2(&ctx->K, &body, &env);
3298 lbm_stack_drop(&ctx->K, 3);
3299 ctx->curr_env = env;
3300 ctx->curr_exp = body;
3301 }
3302}
3303
3304static void cont_terminate(eval_context_t *ctx) {
3305 error_ctx(ctx->r);
3306}
3307
3308static void cont_loop(eval_context_t *ctx) {
3309 lbm_value *sptr = get_stack_ptr(ctx, 2);
3310 stack_reserve(ctx,1)[0] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
3311 ctx->curr_exp = sptr[1];
3312}
3313
3314static void cont_loop_condition(eval_context_t *ctx) {
3315 if (lbm_is_symbol_nil(ctx->r)) {
3316 lbm_stack_drop(&ctx->K, 2);
3317 ctx->app_cont = true1; // A loop returns nil? Makes sense to me... but in general?
3318 return;
3319 }
3320 lbm_value *sptr = get_stack_ptr(ctx, 2);
3321 stack_reserve(ctx,1)[0] = LOOP(((41) << 2) | 0xF8000001u);
3322 ctx->curr_exp = sptr[0];
3323}
3324
3325static void cont_merge_rest(eval_context_t *ctx) {
3326 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3327
3328 // If comparator returns true (result is in ctx->r):
3329 // "a" should be moved to the last element position in merged list.
3330 // A new element from "a_rest" should be moved into comparator argument 1 pos.
3331 // else
3332 // "b" should be moved to last element position in merged list.
3333 // A new element from "b_rest" should be moved into comparator argument 2 pos.
3334 //
3335 // If a_rest or b_rest is NIL:
3336 // we are done, the remaining elements of
3337 // non_nil list should be appended to merged list.
3338 // else
3339 // Set up for a new comparator evaluation and recurse.
3340 lbm_value a = sptr[2];
3341 lbm_value b = lbm_cdr(a);
3342 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate 1 element list
3343
3344 if (ctx->r == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) { // Comparison false
3345
3346 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3347 sptr[0] = b;
3348 sptr[1] = b;
3349 } else {
3350 lbm_set_cdr(sptr[1], b);
3351 sptr[1] = b;
3352 }
3353 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3354 lbm_set_cdr(a, sptr[3]);
3355 lbm_set_cdr(sptr[1], a);
3356 ctx->r = sptr[0];
3357 lbm_stack_drop(&ctx->K, 9);
3358 ctx->app_cont = true1;
3359 return;
3360 } else {
3361 b = sptr[4];
3362 sptr[4] = lbm_cdr(sptr[4]);
3363 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3364 }
3365 } else {
3366 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3367 sptr[0] = a;
3368 sptr[1] = a;
3369 } else {
3370 lbm_set_cdr(sptr[1], a);
3371 sptr[1] = a;
3372 }
3373
3374 if (sptr[3] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3375 lbm_set_cdr(b, sptr[4]);
3376 lbm_set_cdr(sptr[1], b);
3377 ctx->r = sptr[0];
3378 lbm_stack_drop(&ctx->K, 9);
3379 ctx->app_cont = true1;
3380 return;
3381 } else {
3382 a = sptr[3];
3383 sptr[3] = lbm_cdr(sptr[3]);
3384 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3385 }
3386 }
3387 lbm_set_cdr(a, b);
3388 sptr[2] = a;
3389
3390 lbm_value par1 = sptr[7];
3391 lbm_value par2 = sptr[8];
3392 lbm_value cmp_body = sptr[5];
3393 lbm_value cmp_env = sptr[6];
3394 // Environment should be preallocated already at this point
3395 // and the operations below should never need GC.
3396 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3397 lbm_value new_env = lbm_env_set(new_env0, par2, lbm_car(b));
3398 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3399 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3400 }
3401 cmp_env = new_env;
3402
3403 stack_reserve(ctx,1)[0] = MERGE_REST(((43) << 2) | 0xF8000001u);
3404 ctx->curr_exp = cmp_body;
3405 ctx->curr_env = cmp_env;
3406}
3407
3408// merge_layer stack contents
3409// s[sp-9] = cmp
3410// s[sp-8] = cmp_env
3411// s[sp-7] = par1
3412// s[sp-6] = par2
3413// s[sp-5] = acc - first cell
3414// s[sp-4] = acc - last cell
3415// s[sp-3] = rest;
3416// s[sp-2] = layer
3417// s[sp-1] = length or original list
3418//
3419// ctx->r merged sublist
3420static void cont_merge_layer(eval_context_t *ctx) {
3421 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3422 lbm_int layer = lbm_dec_i(sptr[7]);
3423 lbm_int len = lbm_dec_i(sptr[8]);
3424
3425 lbm_value r_curr = ctx->r;
3426 while (lbm_is_cons(r_curr)) {
3427 lbm_value next = lbm_cdr(r_curr);
3428 if (next == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3429 break;
3430 }
3431 r_curr = next;
3432 }
3433
3434 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3435 sptr[4] = ctx->r;
3436 sptr[5] = r_curr;
3437 } else {
3438 lbm_set_cdr(sptr[5], ctx->r); // accumulate merged sublists.
3439 sptr[5] = r_curr;
3440 }
3441
3442 lbm_value layer_rest = sptr[6];
3443 // switch layer or done ?
3444 if (layer_rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3445 if (layer * 2 >= len) {
3446 ctx->r = sptr[4];
3447 ctx->app_cont = true1;
3448 lbm_stack_drop(&ctx->K, 9);
3449 return;
3450 } else {
3451 // Setup for merges of the next layer
3452 layer = layer * 2;
3453 sptr[7] = lbm_enc_i(layer);
3454 layer_rest = sptr[4]; // continue on the accumulation of all sublists.
3455 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3456 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3457 }
3458 }
3459 // merge another sublist based on current layer.
3460 lbm_value a_list = layer_rest;
3461 // build sublist a
3462 lbm_value curr = layer_rest;
3463 for (int i = 0; i < layer-1; i ++) {
3464 if (lbm_is_cons(curr)) {
3465 curr = lbm_cdr(curr);
3466 } else {
3467 break;
3468 }
3469 }
3470 layer_rest = lbm_cdr(curr);
3471 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3472
3473 lbm_value b_list = layer_rest;
3474 // build sublist b
3475 curr = layer_rest;
3476 for (int i = 0; i < layer-1; i ++) {
3477 if (lbm_is_cons(curr)) {
3478 curr = lbm_cdr(curr);
3479 } else {
3480 break;
3481 }
3482 }
3483 layer_rest = lbm_cdr(curr);
3484 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3485
3486 sptr[6] = layer_rest;
3487
3488 if (b_list == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3489 stack_reserve(ctx,1)[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3490 ctx->r = a_list;
3491 ctx->app_cont = true1;
3492 return;
3493 }
3494 // Set up for a merge of sublists.
3495
3496 lbm_value a_rest = lbm_cdr(a_list);
3497 lbm_value b_rest = lbm_cdr(b_list);
3498 lbm_value a = a_list;
3499 lbm_value b = b_list;
3500 lbm_set_cdr(a, b);
3501 // Terminating the b list would be incorrect here
3502 // if there was any chance that the environment update below
3503 // performs GC.
3504 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3505
3506 lbm_value cmp_body = sptr[0];
3507 lbm_value cmp_env = sptr[1];
3508 lbm_value par1 = sptr[2];
3509 lbm_value par2 = sptr[3];
3510 // Environment should be preallocated already at this point
3511 // and the operations below should never need GC.
3512 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3513 lbm_value new_env = lbm_env_set(cmp_env, par2, lbm_car(b));
3514 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3515 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3516 }
3517 cmp_env = new_env;
3518
3519 lbm_uint *merge_cont = stack_reserve(ctx, 11);
3520 merge_cont[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3521 merge_cont[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3522 merge_cont[2] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3523 merge_cont[3] = a;
3524 merge_cont[4] = a_rest;
3525 merge_cont[5] = b_rest;
3526 merge_cont[6] = cmp_body;
3527 merge_cont[7] = cmp_env;
3528 merge_cont[8] = par1;
3529 merge_cont[9] = par2;
3530 merge_cont[10] = MERGE_REST(((43) << 2) | 0xF8000001u);
3531 ctx->curr_exp = cmp_body;
3532 ctx->curr_env = cmp_env;
3533 return;
3534}
3535
3536/****************************************************/
3537/* READER */
3538
3539static void read_finish(lbm_char_channel_t *str, eval_context_t *ctx) {
3540
3541 /* Tokenizer reached "end of file"
3542 The parser could be in a state where it needs
3543 more tokens to correctly finish an expression.
3544
3545 Three cases
3546 1. The program / expression is malformed and the context should die.
3547 2. We are finished reading a program and should close off the
3548 internal representation with a closing parenthesis. Then
3549 apply continuation.
3550 3. We are finished reading an expression and should
3551 apply the continuation.
3552
3553 In case 3, we should find the READ_DONE at sp - 1.
3554 In case 2, we should find the READ_DONE at sp - 5.
3555
3556 */
3557
3558 if (lbm_is_symbol(ctx->r)) {
3559 lbm_uint sym_val = lbm_dec_sym(ctx->r);
3560 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
3561 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
3562 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3563 }
3564 }
3565
3566 if (ctx->K.data[ctx->K.sp-1] == READ_DONE(((20) << 2) | 0xF8000001u) &&
3567 lbm_dec_u(ctx->K.data[ctx->K.sp-3]) == 0) {
3568 /* successfully finished reading an expression (CASE 3) */
3569 ctx->app_cont = true1;
3570 } else if (ctx->K.sp > 4 && ctx->K.data[ctx->K.sp - 4] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3571 lbm_value env;
3572 lbm_value s;
3573 lbm_value sym;
3574 lbm_pop_3(&ctx->K, &sym, &env, &s);
3575 ctx->curr_env = env;
3576 ctx->app_cont = true1; // Program evaluated and result is in ctx->r.
3577 } else if (ctx->K.sp > 5 && ctx->K.data[ctx->K.sp - 5] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3578 /* successfully finished reading a program (CASE 2) */
3579 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3580 ctx->app_cont = true1;
3581 } else {
3582 /* Parsing failed */
3583 if (lbm_channel_row(str) == 1 &&
3584 lbm_channel_column(str) == 1 ){
3585 // eof at empty stream.
3586 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3587 ctx->app_cont = true1;
3588 } else {
3589 lbm_set_error_reason((char*)lbm_error_str_parse_eof);
3590 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3591 }
3592 lbm_channel_reader_close(str);
3593 }
3594}
3595
3596/* cont_read_next_token
3597 sp-2 : Stream
3598 sp-1 : Grab row
3599*/
3600static void cont_read_next_token(eval_context_t *ctx) {
3601 lbm_value *sptr = get_stack_ptr(ctx, 2);
3602 lbm_value stream = sptr[0];
3603 lbm_value grab_row0 = sptr[1];
3604
3605 lbm_char_channel_t *chan = lbm_dec_channel(stream);
3606 if (chan == NULL((void*)0) || chan->state == NULL((void*)0)) {
3607 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3608 }
3609
3610 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3611 lbm_stack_drop(&ctx->K, 2);
3612 read_finish(chan, ctx);
3613 return;
3614 }
3615 /* Eat whitespace and comments */
3616 if (!tok_clean_whitespace(chan)) {
3617 sptr[0] = stream;
3618 sptr[1] = lbm_enc_u(0);
3619 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3620 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3621 return;
3622 }
3623 /* After eating whitespace we may be at end of file/stream */
3624 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3625 lbm_stack_drop(&ctx->K, 2);
3626 read_finish(chan, ctx);
3627 return;
3628 }
3629
3630 if (lbm_dec_u(grab_row0)) {
3631 ctx->row0 = (int32_t)lbm_channel_row(chan);
3632 }
3633
3634 /* Attempt to extract tokens from the character stream */
3635 int n = 0;
3636 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3637 unsigned int string_len = 0;
3638
3639 /*
3640 * SYNTAX
3641 */
3642 uint32_t match;
3643 n = tok_syntax(chan, &match);
3644 if (n > 0) {
3645 if (!lbm_channel_drop(chan, (unsigned int)n)) {
3646 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3647 }
3648 ctx->app_cont = true1;
3649 lbm_uint do_next = 0;
3650 switch(match) {
3651 case TOKOPENPAR1u: {
3652 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3653 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3654 lbm_value *rptr = stack_reserve(ctx,5);
3655 rptr[0] = stream;
3656 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3657 rptr[2] = stream;
3658 rptr[3] = lbm_enc_u(0);
3659 rptr[4] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3660 ctx->r = ENC_SYM_OPENPAR(((0x70) << 4) | 0x00000000u);
3661 } return;
3662 case TOKCLOSEPAR2u: {
3663 lbm_stack_drop(&ctx->K, 2);
3664 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3665 } return;
3666 case TOKOPENBRACK3u: {
3667 sptr[0] = stream;
3668 sptr[1] = READ_START_ARRAY(((24) << 2) | 0xF8000001u);
3669 lbm_value *rptr = stack_reserve(ctx, 3);
3670 rptr[0] = stream;
3671 rptr[1] = lbm_enc_u(0);
3672 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3673 ctx->r = ENC_SYM_OPENBRACK(((0x80) << 4) | 0x00000000u);
3674 } return;
3675 case TOKCLOSEBRACK4u:
3676 lbm_stack_drop(&ctx->K, 2);
3677 ctx->r = ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u);
3678 return;
3679 case TOKDOT5u:
3680 lbm_stack_drop(&ctx->K, 2);
3681 ctx->r = ENC_SYM_DOT(((0x76) << 4) | 0x00000000u);
3682 return;
3683 case TOKDONTCARE6u:
3684 lbm_stack_drop(&ctx->K, 2);
3685 ctx->r = ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u);
3686 return;
3687 case TOKQUOTE7u:
3688 do_next = READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u);
3689 break;
3690 case TOKBACKQUOTE8u: {
3691 sptr[0] = QQ_EXPAND_START(((35) << 2) | 0xF8000001u);
3692 sptr[1] = stream;
3693 lbm_value *rptr = stack_reserve(ctx, 2);
3694 rptr[0] = lbm_enc_u(0);
3695 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3696 ctx->app_cont = true1;
3697 } return;
3698 case TOKCOMMAAT9u:
3699 do_next = READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u);
3700 break;
3701 case TOKCOMMA10u:
3702 do_next = READ_COMMA_RESULT(((23) << 2) | 0xF8000001u);
3703 break;
3704 case TOKMATCHANY11u:
3705 lbm_stack_drop(&ctx->K, 2);
3706 ctx->r = ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u);
3707 return;
3708 case TOKOPENCURL12u: {
3709 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3710 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3711 lbm_value *rptr = stack_reserve(ctx,2);
3712 rptr[0] = stream;
3713 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3714 ctx->r = ENC_SYM_PROGN(((0x102) << 4) | 0x00000000u);
3715 } return;
3716 case TOKCLOSECURL13u:
3717 lbm_stack_drop(&ctx->K, 2);
3718 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3719 return;
3720 case TOKCONSTSTART14u: /* fall through */
3721 case TOKCONSTEND15u:
3722 case TOKCONSTSYMSTR16u: {
3723 if (match == TOKCONSTSTART14u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3724 if (match == TOKCONSTEND15u) ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3725 if (match == TOKCONSTSYMSTR16u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04;
3726 sptr[0] = stream;
3727 sptr[1] = lbm_enc_u(0);
3728 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3729 ctx->app_cont = true1;
3730 } return;
3731 default:
3732 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3733 }
3734 sptr[0] = do_next;
3735 sptr[1] = stream;
3736 lbm_value *rptr = stack_reserve(ctx, 2);
3737 rptr[0] = lbm_enc_u(0);
3738 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3739 ctx->app_cont = true1;
3740 return;
3741 } else if (n < 0) goto retry_token;
3742
3743 /*
3744 * STRING
3745 */
3746 n = tok_string(chan, &string_len);
3747 if (n >= 2) {
3748 lbm_channel_drop(chan, (unsigned int)n);
3749 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3750 gc();
3751 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3752 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3753 return; // dead return but static analysis does not know that.
3754 }
3755 }
3756 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(res);
3757 char *data = (char*)arr->data;
3758 memset(data,0, string_len + 1);
3759 memcpy(data, tokpar_sym_str, string_len);
3760 lbm_stack_drop(&ctx->K, 2);
3761 ctx->r = res;
3762 ctx->app_cont = true1;
3763 return;
3764 } else if (n < 0) goto retry_token;
3765
3766 /*
3767 * FLOAT
3768 */
3769 token_float f_val;
3770 n = tok_double(chan, &f_val);
3771 if (n > 0) {
3772 lbm_channel_drop(chan, (unsigned int) n);
3773 switch(f_val.type) {
3774 case TOKTYPEF32107u:
3775 WITH_GC(res, lbm_enc_float((float)f_val.value))(res) = (lbm_enc_float((float)f_val.value)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (lbm_enc_float((float)f_val.value));
if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
3776 break;
3777 case TOKTYPEF64108u:
3778 res = lbm_enc_double(f_val.value);
3779 break;
3780 default:
3781 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3782 }
3783 lbm_stack_drop(&ctx->K, 2);
3784 ctx->r = res;
3785 ctx->app_cont = true1;
3786 return;
3787 } else if (n < 0) goto retry_token;
3788
3789 /*
3790 * INTEGER
3791 */
3792 token_int int_result;
3793 n = tok_integer(chan, &int_result);
3794 if (n > 0) {
3795 lbm_channel_drop(chan, (unsigned int)n);
3796 switch(int_result.type) {
3797 case TOKTYPEBYTE100u:
3798 res = lbm_enc_char((uint8_t)(int_result.negative ? -int_result.value : int_result.value));
3799 break;
3800 case TOKTYPEI101u:
3801 res = lbm_enc_i((lbm_int)(int_result.negative ? -int_result.value : int_result.value));
3802 break;
3803 case TOKTYPEU102u:
3804 res = lbm_enc_u((lbm_uint)(int_result.negative ? -int_result.value : int_result.value));
3805 break;
3806 case TOKTYPEI32103u:
3807 WITH_GC(res, lbm_enc_i32((int32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i32((int32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i32((int32_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3808 break;
3809 case TOKTYPEU32104u:
3810 WITH_GC(res,lbm_enc_u32((uint32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u32((uint32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u32((uint32_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3811 break;
3812 case TOKTYPEI64105u:
3813 WITH_GC(res,lbm_enc_i64((int64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i64((int64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i64((int64_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3814 break;
3815 case TOKTYPEU64106u:
3816 WITH_GC(res,lbm_enc_u64((uint64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u64((uint64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u64((uint64_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3817 break;
3818 default:
3819 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3820 }
3821 lbm_stack_drop(&ctx->K, 2);
3822 ctx->r = res;
3823 ctx->app_cont = true1;
3824 return;
3825 } else if (n < 0) goto retry_token;
3826
3827 /*
3828 * SYMBOL
3829 */
3830 n = tok_symbol(chan);
3831 if (n > 0) {
3832 lbm_channel_drop(chan, (unsigned int) n);
3833 lbm_uint symbol_id;
3834 if (lbm_get_symbol_by_name(tokpar_sym_str, &symbol_id)) {
3835 res = lbm_enc_sym(symbol_id);
3836 } else {
3837 int r = 0;
3838 if (n > 4 &&
3839 tokpar_sym_str[0] == 'e' &&
3840 tokpar_sym_str[1] == 'x' &&
3841 tokpar_sym_str[2] == 't' &&
3842 tokpar_sym_str[3] == '-') {
3843 lbm_uint ext_id;
3844 lbm_uint ext_name_len = (lbm_uint)n + 1;
3845 char *ext_name = lbm_malloc(ext_name_len);
3846 if (!ext_name) {
3847 gc();
3848 ext_name = lbm_malloc(ext_name_len);
3849 }
3850 if (ext_name) {
3851 memcpy(ext_name, tokpar_sym_str, ext_name_len);
3852 r = lbm_add_extension(ext_name, lbm_extensions_default);
3853 if (!lbm_lookup_extension_id(ext_name, &ext_id)) {
3854 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3855 }
3856 symbol_id = ext_id;
3857 } else {
3858 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3859 }
3860 } else {
3861 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04 &&
3862 ctx->flags & EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08) {
3863 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id, true1); //flash
3864 if (!r) {
3865 lbm_set_error_reason((char*)lbm_error_str_flash_error);
3866 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3867 }
3868 } else {
3869 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3870 if (!r) {
3871 gc();
3872 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3873 }
3874 }
3875 }
3876 if (r) {
3877 res = lbm_enc_sym(symbol_id);
3878 } else {
3879 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3880 }
3881 }
3882 lbm_stack_drop(&ctx->K, 2);
3883 ctx->r = res;
3884 ctx->app_cont = true1;
3885 return;
3886 } else if (n == TOKENIZER_NEED_MORE-1) {
3887 goto retry_token;
3888 } else if (n <= TOKENIZER_STRING_ERROR-2) {
3889 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3890 }
3891
3892 /*
3893 * CHAR
3894 */
3895 char c_val;
3896 n = tok_char(chan, &c_val);
3897 if(n > 0) {
3898 lbm_channel_drop(chan,(unsigned int) n);
3899 lbm_stack_drop(&ctx->K, 2);
3900 ctx->r = lbm_enc_char((uint8_t)c_val);
3901 ctx->app_cont = true1;
3902 return;
3903 }else if (n < 0) goto retry_token;
3904
3905 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3906
3907 retry_token:
3908 if (n == TOKENIZER_NEED_MORE-1) {
3909 sptr[0] = stream;
3910 sptr[1] = lbm_enc_u(0);
3911 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3912 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3913 return;
3914 }
3915 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3916}
3917
3918static void cont_read_start_array(eval_context_t *ctx) {
3919 lbm_value *sptr = get_stack_ptr(ctx, 1);
3920 lbm_value stream = sptr[0];
3921
3922 lbm_char_channel_t *str = lbm_dec_channel(stream);
3923 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
3924 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3925 }
3926
3927 lbm_uint num_free = lbm_memory_longest_free();
3928 lbm_uint initial_size = (lbm_uint)((float)num_free * 0.9);
3929 if (initial_size == 0) {
3930 gc();
3931 num_free = lbm_memory_longest_free();
3932 initial_size = (lbm_uint)((float)num_free * 0.9);
3933 if (initial_size == 0) {
3934 lbm_channel_reader_close(str);
3935 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3936 }
3937 }
3938
3939 if (lbm_is_number(ctx->r)) {
3940 lbm_value array;
3941 initial_size = sizeof(lbm_uint) * initial_size;
3942
3943 if (!lbm_heap_allocate_array(&array, initial_size)) {
3944 lbm_set_error_reason("Out of memory while reading.");
3945 lbm_channel_reader_close(str);
3946 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3947 // NOTE: If array is not created evaluation ends here.
3948 // Static analysis seems unaware.
3949 }
3950
3951 sptr[0] = array;
3952 lbm_value *rptr = stack_reserve(ctx, 4);
3953 rptr[0] = lbm_enc_u(initial_size);
3954 rptr[1] = lbm_enc_u(0);
3955 rptr[2] = stream;
3956 rptr[3] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3957 ctx->app_cont = true1;
3958 } else {
3959 lbm_channel_reader_close(str);
3960 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3961 }
3962}
3963
3964static void cont_read_append_array(eval_context_t *ctx) {
3965 lbm_uint *sptr = get_stack_ptr(ctx, 4);
3966
3967 lbm_value array = sptr[0];
3968 lbm_value size = lbm_dec_as_u32(sptr[1]);
3969 lbm_value ix = lbm_dec_as_u32(sptr[2]);
3970 lbm_value stream = sptr[3];
3971
3972 if (ix >= (size - 1)) {
3973 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3974 }
3975
3976 // get_car can return nil. Whose value is 0!
3977 // So static Analysis is right about this being a potential NULL pointer.
3978 // However, if the array was created correcly to begin with, it should be fine.
3979 lbm_value arr_car = get_car(array);
3980 lbm_array_header_t *arr = (lbm_array_header_t*)arr_car;
3981
3982 if (lbm_is_number(ctx->r)) {
3983 ((uint8_t*)arr->data)[ix] = (uint8_t)lbm_dec_as_u32(ctx->r);
3984
3985 sptr[2] = lbm_enc_u(ix + 1);
3986 lbm_value *rptr = stack_reserve(ctx, 4);
3987 rptr[0] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3988 rptr[1] = stream;
3989 rptr[2] = lbm_enc_u(0);
3990 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3991 ctx->app_cont = true1;
3992 } else if (lbm_is_symbol(ctx->r) && ctx->r == ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u)) {
3993 lbm_uint array_size = ix / sizeof(lbm_uint);
3994
3995 if (ix % sizeof(lbm_uint) != 0) {
3996 array_size = array_size + 1;
3997 }
3998 lbm_memory_shrink((lbm_uint*)arr->data, array_size);
3999 arr->size = ix;
4000 lbm_stack_drop(&ctx->K, 4);
4001 ctx->r = array;
4002 ctx->app_cont = true1;
4003 } else {
4004 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
4005 }
4006}
4007
4008static void cont_read_append_continue(eval_context_t *ctx) {
4009 lbm_value *sptr = get_stack_ptr(ctx, 3);
4010
4011 lbm_value first_cell = sptr[0];
4012 lbm_value last_cell = sptr[1];
4013 lbm_value stream = sptr[2];
4014
4015 lbm_char_channel_t *str = lbm_dec_channel(stream);
4016 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4017 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4018 }
4019
4020 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4021
4022 switch(ctx->r) {
4023 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4024 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4025 lbm_set_cdr(last_cell, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate the list
4026 ctx->r = first_cell;
4027 } else {
4028 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4029 }
4030 lbm_stack_drop(&ctx->K, 3);
4031 /* Skip reading another token and apply the continuation */
4032 ctx->app_cont = true1;
4033 return;
4034 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4035 lbm_value *rptr = stack_reserve(ctx, 4);
4036 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4037 rptr[1] = stream;
4038 rptr[2] = lbm_enc_u(0);
4039 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4040 ctx->app_cont = true1;
4041 } return;
4042 }
4043 }
4044 lbm_value new_cell = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4045 if (lbm_is_symbol_merror(new_cell)) {
4046 lbm_channel_reader_close(str);
4047 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4048 return;
4049 }
4050 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4051 lbm_set_cdr(last_cell, new_cell);
4052 last_cell = new_cell;
4053 } else {
4054 first_cell = last_cell = new_cell;
4055 }
4056 sptr[0] = first_cell;
4057 sptr[1] = last_cell;
4058 sptr[2] = stream; // unchanged.
4059 lbm_value *rptr = stack_reserve(ctx, 4);
4060 rptr[0] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
4061 rptr[1] = stream;
4062 rptr[2] = lbm_enc_u(0);
4063 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4064 ctx->app_cont = true1;
4065}
4066
4067static void cont_read_eval_continue(eval_context_t *ctx) {
4068 lbm_value env;
4069 lbm_value stream;
4070 lbm_pop_2(&ctx->K, &env, &stream);
4071
4072 lbm_char_channel_t *str = lbm_dec_channel(stream);
4073 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4074 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4075 }
4076
4077 ctx->row1 = (lbm_int)str->row(str);
4078
4079 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4080
4081 switch(ctx->r) {
4082 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4083 ctx->app_cont = true1;
4084 return;
4085 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4086 // This case is a bit mysterious.
4087 // A dot, may in reality be an error in this location.
4088 lbm_value *rptr = stack_reserve(ctx, 4);
4089 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4090 rptr[1] = stream;
4091 rptr[2] = lbm_enc_u(0);
4092 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4093 ctx->app_cont = true1;
4094 } return;
4095 }
4096 }
4097
4098 lbm_value *rptr = stack_reserve(ctx, 6);
4099 rptr[0] = stream;
4100 rptr[1] = env;
4101 rptr[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
4102 rptr[3] = stream;
4103 rptr[4] = lbm_enc_u(1);
4104 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4105 rptr[6] = lbm_enc_u(ctx->flags);
4106 rptr[7] = POP_READER_FLAGS(((47) << 2) | 0xF8000001u);
4107 ctx->curr_env = env;
4108 ctx->curr_exp = ctx->r;
4109}
4110
4111static void cont_read_expect_closepar(eval_context_t *ctx) {
4112 lbm_value res;
4113 lbm_value stream;
4114
4115 lbm_pop_2(&ctx->K, &res, &stream);
4116
4117 lbm_char_channel_t *str = lbm_dec_channel(stream);
4118 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4119 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4120 }
4121
4122 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4123 ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u)) {
4124 ctx->r = res;
4125 ctx->app_cont = true1;
4126 } else {
4127 lbm_channel_reader_close(str);
4128 lbm_set_error_reason((char*)lbm_error_str_parse_close);
4129 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4130 }
4131}
4132
4133static void cont_read_dot_terminate(eval_context_t *ctx) {
4134 lbm_value *sptr = get_stack_ptr(ctx, 3);
4135
4136 lbm_value first_cell = sptr[0];
4137 lbm_value last_cell = sptr[1];
4138 lbm_value stream = sptr[2];
4139
4140 lbm_char_channel_t *str = lbm_dec_channel(stream);
4141 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4142 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4143 }
4144
4145 lbm_stack_drop(&ctx->K ,3);
4146
4147 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4148 (ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u) ||
4149 ctx->r == ENC_SYM_DOT(((0x76) << 4) | 0x00000000u))) {
4150 lbm_channel_reader_close(str);
4151 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4152 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4153 } else {
4154 if (lbm_is_cons(last_cell)) {
4155 lbm_set_cdr(last_cell, ctx->r);
4156 ctx->r = first_cell;
4157 lbm_value *rptr = stack_reserve(ctx, 6);
4158 rptr[0] = stream;
4159 rptr[1] = ctx->r;
4160 rptr[2] = READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u);
4161 rptr[3] = stream;
4162 rptr[4] = lbm_enc_u(0);
4163 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4164 ctx->app_cont = true1;
4165 } else {
4166 lbm_channel_reader_close(str);
4167 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4168 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4169 }
4170 }
4171}
4172
4173static void cont_read_done(eval_context_t *ctx) {
4174 lbm_value stream;
4175 lbm_value f_val;
4176 lbm_pop_2(&ctx->K, &stream ,&f_val);
4177
4178 uint32_t flags = lbm_dec_as_u32(f_val);
4179 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4180 ctx->flags |= (flags & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4181
4182 lbm_char_channel_t *str = lbm_dec_channel(stream);
4183 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4184 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4185 }
4186
4187 lbm_channel_reader_close(str);
4188 if (lbm_is_symbol(ctx->r)) {
4189 lbm_uint sym_val = lbm_dec_sym(ctx->r);
4190 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
4191 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
4192 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4193 }
4194 }
4195
4196 ctx->row0 = -1;
4197 ctx->row1 = -1;
4198 ctx->app_cont = true1;
4199}
4200
4201static void cont_read_quote_result(eval_context_t *ctx) {
4202 lbm_value cell;
4203 WITH_GC(cell, lbm_heap_allocate_list_init(2,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4204 ENC_SYM_QUOTE,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4205 ctx->r))(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
};
4206 ctx->r = cell;
4207 ctx->app_cont = true1;
4208}
4209
4210static void cont_read_commaat_result(eval_context_t *ctx) {
4211 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4212 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4213 ctx->r = cell1;
4214 ctx->app_cont = true1;
4215}
4216
4217static void cont_read_comma_result(eval_context_t *ctx) {
4218 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u),ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4219 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4220 ctx->r = cell1;
4221 ctx->app_cont = true1;
4222}
4223
4224static void cont_application_start(eval_context_t *ctx) {
4225
4226 /* sptr[0] = env
4227 * sptr[1] = args
4228 * ctx->r = function
4229 */
4230
4231 if (lbm_is_symbol(ctx->r)) {
4232 stack_reserve(ctx,1)[0] = lbm_enc_u(0);
4233 cont_application_args(ctx);
4234 } else if (lbm_is_cons(ctx->r)) {
4235 lbm_uint *sptr = get_stack_ptr(ctx, 2);
4236 lbm_value args = (lbm_value)sptr[1];
4237 switch (get_car(ctx->r)) {
4238 case ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u): {
4239 lbm_value cl[3];
4240 extract_n(get_cdr(ctx->r), cl, 3);
4241 lbm_value arg_env = (lbm_value)sptr[0];
4242 lbm_value arg0, arg_rest;
4243 get_car_and_cdr(args, &arg0, &arg_rest);
4244 sptr[1] = cl[CLO_BODY1];
4245 bool_Bool a_nil = lbm_is_symbol_nil(args);
4246 bool_Bool p_nil = lbm_is_symbol_nil(cl[CLO_PARAMS0]);
4247 lbm_value *reserved = stack_reserve(ctx, 4);
4248
4249 if (!a_nil && !p_nil) {
4250 reserved[0] = cl[CLO_ENV2];
4251 reserved[1] = cl[CLO_PARAMS0];
4252 reserved[2] = arg_rest;
4253 reserved[3] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
4254 ctx->curr_exp = arg0;
4255 ctx->curr_env = arg_env;
4256 } else if (a_nil && p_nil) {
4257 // No params, No args
4258 lbm_stack_drop(&ctx->K, 6);
4259 ctx->curr_exp = cl[CLO_BODY1];
4260 ctx->curr_env = cl[CLO_ENV2];
4261 } else if (p_nil) {
4262 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), cl[CLO_ENV2]);
4263 reserved[0] = rest_binder;
4264 reserved[1] = get_cdr(args);
4265 reserved[2] = get_car(rest_binder);
4266 reserved[3] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
4267 ctx->curr_exp = get_car(args);
4268 ctx->curr_env = arg_env;
4269 } else {
4270 lbm_set_error_reason((char*)lbm_error_str_num_args);
4271 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->r);
4272 }
4273 } break;
4274 case ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u):{
4275 /* Continuation created using call-cc.
4276 * ((SYM_CONT . cont-array) arg0 )
4277 */
4278 lbm_value c = get_cdr(ctx->r); /* should be the continuation array*/
4279
4280 if (!lbm_is_lisp_array_r(c)) {
4281 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4282 }
4283
4284 lbm_uint arg_count = lbm_list_length(args);
4285 lbm_value arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4286 switch (arg_count) {
4287 case 0:
4288 arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4289 break;
4290 case 1:
4291 arg = get_car(args);
4292 break;
4293 default:
4294 lbm_set_error_reason((char*)lbm_error_str_num_args);
4295 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4296 }
4297 lbm_stack_clear(&ctx->K);
4298
4299 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(c);
4300
4301 ctx->K.sp = arr->size / sizeof(lbm_uint);
4302 memcpy(ctx->K.data, arr->data, arr->size);
4303
4304 ctx->curr_exp = arg;
4305 break;
4306 }
4307 case ENC_SYM_MACRO(((0x10D) << 4) | 0x00000000u):{
4308 /*
4309 * Perform macro expansion.
4310 * Macro expansion is really just evaluation in an
4311 * environment augmented with the unevaluated expressions passed
4312 * as arguments.
4313 */
4314 lbm_value env = (lbm_value)sptr[0];
4315
4316 lbm_value curr_param = get_cadr(ctx->r);
4317 lbm_value curr_arg = args;
4318 lbm_value expand_env = env;
4319 while (lbm_is_cons(curr_param) &&
4320 lbm_is_cons(curr_arg)) {
4321 lbm_value car_curr_param, cdr_curr_param;
4322 lbm_value car_curr_arg, cdr_curr_arg;
4323 get_car_and_cdr(curr_param, &car_curr_param, &cdr_curr_param);
4324 get_car_and_cdr(curr_arg, &car_curr_arg, &cdr_curr_arg);
4325
4326 lbm_value entry = cons_with_gc(car_curr_param, car_curr_arg, expand_env);
4327 lbm_value aug_env = cons_with_gc(entry, expand_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4328 expand_env = aug_env;
4329
4330 curr_param = cdr_curr_param;
4331 curr_arg = cdr_curr_arg;
4332 }
4333 /* Two rounds of evaluation is performed.
4334 * First to instantiate the arguments into the macro body.
4335 * Second to evaluate the resulting program.
4336 */
4337 sptr[1] = EVAL_R(((11) << 2) | 0xF8000001u);
4338 lbm_value exp = get_cadr(get_cdr(ctx->r));
4339 ctx->curr_exp = exp;
4340 ctx->curr_env = expand_env;
4341 } break;
4342 default:
4343 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4344 }
4345 } else {
4346 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4347 }
4348}
4349
4350static void cont_eval_r(eval_context_t* ctx) {
4351 lbm_value env;
4352 lbm_pop(&ctx->K, &env);
4353 ctx->curr_exp = ctx->r;
4354 ctx->curr_env = env;
4355}
4356
4357static void cont_progn_var(eval_context_t* ctx) {
4358
4359 lbm_value key;
4360 lbm_value env;
4361
4362 lbm_pop_2(&ctx->K, &key, &env);
4363
4364 if (fill_binding_location(key, ctx->r, env) < 0) {
4365 lbm_set_error_reason("Incorrect type of name/key in let-binding");
4366 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
4367 }
4368
4369 ctx->app_cont = true1;
4370}
4371
4372static void cont_setq(eval_context_t *ctx) {
4373 lbm_value sym;
4374 lbm_value env;
4375 lbm_pop_2(&ctx->K, &sym, &env);
4376 lbm_value res;
4377 WITH_GC(res, perform_setvar(sym, ctx->r, env))(res) = (perform_setvar(sym, ctx->r, env)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (perform_setvar(sym, ctx->r, env)
); if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
4378 ctx->r = res;
4379 ctx->app_cont = true1;
4380}
4381
4382lbm_flash_status request_flash_storage_cell(lbm_value val, lbm_value *res) {
4383
4384 lbm_value flash_cell;
4385 lbm_flash_status s = lbm_allocate_const_cell(&flash_cell);
4386 if (s != LBM_FLASH_WRITE_OK)
4387 return s;
4388 lbm_value new_val = val;
4389 new_val &= ~LBM_PTR_VAL_MASK0x03FFFFFCu; // clear the value part of the ptr
4390 new_val |= (flash_cell & LBM_PTR_VAL_MASK0x03FFFFFCu);
4391 new_val |= LBM_PTR_TO_CONSTANT_BIT0x04000000u;
4392 *res = new_val;
4393 return s;
4394}
4395
4396static void cont_move_to_flash(eval_context_t *ctx) {
4397
4398 lbm_value args;
4399 lbm_pop(&ctx->K, &args);
4400
4401 if (lbm_is_symbol_nil(args)) {
4402 // Done looping over arguments. return true.
4403 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
4404 ctx->app_cont = true1;
4405 return;
4406 }
4407
4408 lbm_value first_arg, rest;
4409 get_car_and_cdr(args, &first_arg, &rest);
4410
4411 lbm_value val;
4412 if (lbm_is_symbol(first_arg) && lbm_global_env_lookup(&val, first_arg)) {
4413 // Prepare to copy the rest of the arguments when done with first.
4414 lbm_value *rptr = stack_reserve(ctx, 2);
4415 rptr[0] = rest;
4416 rptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
4417 if (lbm_is_ptr(val) &&
4418 (!(val & LBM_PTR_TO_CONSTANT_BIT0x04000000u))) {
4419 lbm_value * rptr1 = stack_reserve(ctx, 3);
4420 rptr1[0] = first_arg;
4421 rptr1[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
4422 rptr1[2] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4423 ctx->r = val;
4424 }
4425 ctx->app_cont = true1;
4426 return;
4427 }
4428 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4429}
4430
4431static void cont_move_val_to_flash_dispatch(eval_context_t *ctx) {
4432
4433 lbm_value val = ctx->r;
4434
4435 if (lbm_is_cons(val)) {
4436 lbm_value *rptr = stack_reserve(ctx, 5);
4437 rptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // fst cell of list
4438 rptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last cell of list
4439 rptr[2] = get_cdr(val);
4440 rptr[3] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4441 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4442 ctx->r = get_car(val);
4443 ctx->app_cont = true1;
4444 return;
4445 }
4446
4447 if (lbm_is_ptr(val) && (val & LBM_PTR_TO_CONSTANT_BIT0x04000000u)) {
4448 ctx->r = val;
4449 ctx->app_cont = true1;
4450 return;
4451 }
4452
4453 if (lbm_is_ptr(val)) {
4454 lbm_cons_t *ref = lbm_ref_cell(val);
4455 if (lbm_type_of(ref->cdr) == LBM_TYPE_SYMBOL0x00000000u) {
4456 switch (ref->cdr) {
4457 case ENC_SYM_RAW_I_TYPE(((0x31) << 4) | 0x00000000u): /* fall through */
4458 case ENC_SYM_RAW_U_TYPE(((0x32) << 4) | 0x00000000u):
4459 case ENC_SYM_RAW_F_TYPE(((0x33) << 4) | 0x00000000u): {
4460 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4461 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4462 handle_flash_status(write_const_car(flash_cell, ref->car));
4463 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4464 ctx->r = flash_cell;
4465 } break;
4466 case ENC_SYM_IND_I_TYPE(((0x34) << 4) | 0x00000000u): /* fall through */
4467 case ENC_SYM_IND_U_TYPE(((0x35) << 4) | 0x00000000u):
4468 case ENC_SYM_IND_F_TYPE(((0x36) << 4) | 0x00000000u): {
4469#ifndef LBM64
4470 /* 64 bit values are in lbm mem on 32bit platforms. */
4471 lbm_uint *lbm_mem_ptr = (lbm_uint*)ref->car;
4472 lbm_uint flash_ptr;
4473
4474 handle_flash_status(lbm_write_const_raw(lbm_mem_ptr, 2, &flash_ptr));
4475 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4476 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4477 handle_flash_status(write_const_car(flash_cell, flash_ptr));
4478 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4479 ctx->r = flash_cell;
4480#else
4481 // There are no indirect types in LBM64
4482 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4483#endif
4484 } break;
4485 case ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u): {
4486 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4487 lbm_uint size = arr->size / sizeof(lbm_uint);
4488 lbm_uint flash_addr;
4489 lbm_value *arrdata = (lbm_value *)arr->data;
4490 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4491 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4492 handle_flash_status(lbm_allocate_const_raw(size, &flash_addr));
4493 lift_array_flash(flash_cell,
4494 false0,
4495 (char *)flash_addr,
4496 arr->size);
4497 // Move array contents to flash recursively
4498 lbm_value *rptr = stack_reserve(ctx, 5);
4499 rptr[0] = flash_cell;
4500 rptr[1] = lbm_enc_u(0);
4501 rptr[2] = val;
4502 rptr[3] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4503 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4504 ctx->r = arrdata[0];
4505 ctx->app_cont = true1;
4506 return;
4507 }
4508 case ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u): {
4509 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4510 // arbitrary address: flash_arr.
4511 lbm_uint flash_arr;
4512 handle_flash_status(lbm_write_const_array_padded((uint8_t*)arr->data, arr->size, &flash_arr));
4513 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4514 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4515 lift_array_flash(flash_cell,
4516 true1,
4517 (char *)flash_arr,
4518 arr->size);
4519 ctx->r = flash_cell;
4520 } break;
4521 case ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u): /* fall through */
4522 case ENC_SYM_CUSTOM_TYPE(((0x38) << 4) | 0x00000000u):
4523 lbm_set_error_reason((char *)lbm_error_str_flash_not_possible);
4524 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4525 }
4526 } else {
4527 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4528 }
4529 ctx->app_cont = true1;
4530 return;
4531 }
4532 ctx->r = val;
4533 ctx->app_cont = true1;
4534}
4535
4536static void cont_move_list_to_flash(eval_context_t *ctx) {
4537
4538 // ctx->r holds the value that should go in car
4539
4540 lbm_value *sptr = get_stack_ptr(ctx, 3);
4541
4542 lbm_value fst = sptr[0];
4543 lbm_value lst = sptr[1];
4544 lbm_value val = sptr[2];
4545
4546
4547 lbm_value new_lst = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4548 // Allocate element ptr storage after storing the element to flash.
4549 handle_flash_status(request_flash_storage_cell(lbm_enc_cons_ptr(LBM_PTR_NULL(0x03FFFFFCu >> 2)), &new_lst));
4550
4551 if (lbm_is_symbol_nil(fst)) {
4552 lst = new_lst;
4553 fst = new_lst;
4554 handle_flash_status(write_const_car(lst, ctx->r));
4555 } else {
4556 handle_flash_status(write_const_cdr(lst, new_lst)); // low before high
4557 handle_flash_status(write_const_car(new_lst, ctx->r));
4558 lst = new_lst;
4559 }
4560
4561 if (lbm_is_cons(val)) {
4562 sptr[0] = fst;
4563 sptr[1] = lst;//rest_cell;
4564 sptr[2] = get_cdr(val);
4565 lbm_value *rptr = stack_reserve(ctx, 2);
4566 rptr[0] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4567 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4568 ctx->r = get_car(val);
4569 } else {
4570 sptr[0] = fst;
4571 sptr[1] = lst;
4572 sptr[2] = CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u);
4573 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4574 ctx->r = val;
4575 }
4576 ctx->app_cont = true1;
4577}
4578
4579static void cont_close_list_in_flash(eval_context_t *ctx) {
4580 lbm_value fst;
4581 lbm_value lst;
4582 lbm_pop_2(&ctx->K, &lst, &fst);
4583 lbm_value val = ctx->r;
4584 handle_flash_status(write_const_cdr(lst, val));
4585 ctx->r = fst;
4586 ctx->app_cont = true1;
4587}
4588
4589static void cont_move_array_elts_to_flash(eval_context_t *ctx) {
4590 lbm_value *sptr = get_stack_ptr(ctx, 3);
4591 // sptr[2] = source array in RAM
4592 // sptr[1] = current index
4593 // sptr[0] = target array in flash
4594 lbm_array_header_t *src_arr = (lbm_array_header_t*)get_car(sptr[2]);
4595 lbm_uint size = src_arr->size / sizeof(lbm_uint);
4596 lbm_value *srcdata = (lbm_value *)src_arr->data;
4597
4598 lbm_array_header_t *tgt_arr = (lbm_array_header_t*)get_car(sptr[0]);
4599 lbm_uint *tgtdata = (lbm_value *)tgt_arr->data;
4600 lbm_uint ix = lbm_dec_as_u32(sptr[1]);
4601 handle_flash_status(lbm_const_write(&tgtdata[ix], ctx->r));
4602 if (ix >= size-1) {
4603 ctx->r = sptr[0];
4604 lbm_stack_drop(&ctx->K, 3);
4605 ctx->app_cont = true1;
4606 return;
4607 }
4608 sptr[1] = lbm_enc_u(ix + 1);
4609 lbm_value *rptr = stack_reserve(ctx, 2);
4610 rptr[0] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4611 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4612 ctx->r = srcdata[ix+1];
4613 ctx->app_cont = true1;
4614 return;
4615}
4616
4617static void cont_qq_expand_start(eval_context_t *ctx) {
4618 lbm_value *rptr = stack_reserve(ctx, 2);
4619 rptr[0] = ctx->r;
4620 rptr[1] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4621 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4622 ctx->app_cont = true1;
4623}
4624
4625lbm_value quote_it(lbm_value qquoted) {
4626 if (lbm_is_symbol(qquoted) &&
4627 lbm_is_special(qquoted)) return qquoted;
4628
4629 lbm_value val = cons_with_gc(qquoted, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4630 return cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4631}
4632
4633bool_Bool is_append(lbm_value a) {
4634 return (lbm_is_cons(a) &&
4635 lbm_is_symbol(get_car(a)) &&
4636 (get_car(a) == ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u)));
4637}
4638
4639lbm_value append(lbm_value front, lbm_value back) {
4640 if (lbm_is_symbol_nil(front)) return back;
4641 if (lbm_is_symbol_nil(back)) return front;
4642
4643 if (lbm_is_quoted_list(front) &&
4644 lbm_is_quoted_list(back)) {
4645 lbm_value f = get_cadr(front);
4646 lbm_value b = get_cadr(back);
4647 return quote_it(lbm_list_append(f, b));
4648 }
4649
4650 if (is_append(back) &&
4651 lbm_is_quoted_list(get_cadr(back)) &&
4652 lbm_is_quoted_list(front)) {
4653 lbm_value ql = get_cadr(back);
4654 lbm_value f = get_cadr(front);
4655 lbm_value b = get_cadr(ql);
4656
4657 lbm_value v = lbm_list_append(f, b);
4658 lbm_set_car(get_cdr(ql), v);
4659 return back;
4660 }
4661
4662 if (is_append(back)) {
4663 back = get_cdr(back);
4664 lbm_value new = cons_with_gc(front, back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4665 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), new, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4666 }
4667
4668 lbm_value t0, t1;
4669
4670 t0 = cons_with_gc(back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), front);
4671 t1 = cons_with_gc(front, t0, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4672 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), t1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4673}
4674
4675/* Bawden's qq-expand implementation
4676(define (qq-expand x)
4677 (cond ((tag-comma? x)
4678 (tag-data x))
4679 ((tag-comma-atsign? x)
4680 (error "Illegal"))
4681 ((tag-backquote? x)
4682 (qq-expand
4683 (qq-expand (tag-data x))))
4684 ((pair? x)
4685 `(append
4686 ,(qq-expand-list (car x))
4687 ,(qq-expand (cdr x))))
4688 (else `',x)))
4689 */
4690static void cont_qq_expand(eval_context_t *ctx) {
4691 lbm_value qquoted;
4692 lbm_pop(&ctx->K, &qquoted);
4693
4694 switch(lbm_type_of(qquoted)) {
4695 case LBM_TYPE_CONS0x10000000u: {
4696 lbm_value car_val = get_car(qquoted);
4697 lbm_value cdr_val = get_cdr(qquoted);
4698 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4699 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4700 ctx->r = append(ctx->r, get_car(cdr_val));
4701 ctx->app_cont = true1;
4702 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4703 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4704 error_ctx(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u));
4705 } else {
4706 lbm_value *rptr = stack_reserve(ctx, 6);
4707 rptr[0] = ctx->r;
4708 rptr[1] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4709 rptr[2] = cdr_val;
4710 rptr[3] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4711 rptr[4] = car_val;
4712 rptr[5] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4713 ctx->app_cont = true1;
4714 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4715 }
4716
4717 } break;
4718 default: {
4719 lbm_value res = quote_it(qquoted);
4720 ctx->r = append(ctx->r, res);
4721 ctx->app_cont = true1;
4722 }
4723 }
4724}
4725
4726static void cont_qq_append(eval_context_t *ctx) {
4727 lbm_value head;
4728 lbm_pop(&ctx->K, &head);
4729 ctx->r = append(head, ctx->r);
4730 ctx->app_cont = true1;
4731}
4732
4733/* Bawden's qq-expand-list implementation
4734(define (qq-expand-list x)
4735 (cond ((tag-comma? x)
4736 `(list ,(tag-data x)))
4737 ((tag-comma-atsign? x)
4738 (tag-data x))
4739 ((tag-backquote? x)
4740 (qq-expand-list
4741 (qq-expand (tag-data x))))
4742 ((pair? x)
4743 `(list
4744 (append
4745 ,(qq-expand-list (car x))
4746 ,(qq-expand (cdr x)))))
4747 (else `'(,x))))
4748*/
4749
4750static void cont_qq_expand_list(eval_context_t* ctx) {
4751 lbm_value l;
4752 lbm_pop(&ctx->K, &l);
4753
4754 ctx->app_cont = true1;
4755 switch(lbm_type_of(l)) {
4756 case LBM_TYPE_CONS0x10000000u: {
4757 lbm_value car_val = get_car(l);
4758 lbm_value cdr_val = get_cdr(l);
4759 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4760 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4761 lbm_value tl = cons_with_gc(get_car(cdr_val), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4762 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4763 ctx->r = append(ctx->r, tmp);
4764 return;
4765 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4766 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4767 ctx->r = get_car(cdr_val);
4768 return;
4769 } else {
4770 lbm_value *rptr = stack_reserve(ctx, 7);
4771 rptr[0] = QQ_LIST(((39) << 2) | 0xF8000001u);
4772 rptr[1] = ctx->r;
4773 rptr[2] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4774 rptr[3] = cdr_val;
4775 rptr[4] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4776 rptr[5] = car_val;
4777 rptr[6] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4778 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4779 }
4780
4781 } break;
4782 default: {
4783 lbm_value a_list = cons_with_gc(l, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4784 lbm_value tl = cons_with_gc(a_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4785 lbm_value tmp = cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4786 ctx->r = append(ctx->r, tmp);
4787 }
4788 }
4789}
4790
4791static void cont_qq_list(eval_context_t *ctx) {
4792 lbm_value val = ctx->r;
4793 lbm_value apnd_app = cons_with_gc(val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4794 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), apnd_app, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4795 ctx->r = tmp;
4796 ctx->app_cont = true1;
4797}
4798
4799static void cont_kill(eval_context_t *ctx) {
4800 (void) ctx;
4801 finish_ctx();
4802}
4803
4804static void cont_pop_reader_flags(eval_context_t *ctx) {
4805 lbm_value flags;
4806 lbm_pop(&ctx->K, &flags);
4807 ctx->flags = ctx->flags & ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4808 ctx->flags |= (lbm_dec_as_u32(flags) & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4809 // r is unchanged.
4810 ctx->app_cont = true1;
4811}
4812
4813static void cont_exception_handler(eval_context_t *ctx) {
4814 lbm_value *sptr = pop_stack_ptr(ctx, 2);
4815 lbm_value retval = sptr[0];
4816 lbm_value flags = sptr[1];
4817 lbm_set_car(get_cdr(retval), ctx->r);
4818 ctx->flags = flags;
4819 ctx->r = retval;
4820 ctx->app_cont = true1;
4821}
4822
4823/*********************************************************/
4824/* Continuations table */
4825typedef void (*cont_fun)(eval_context_t *);
4826
4827static const cont_fun continuations[NUM_CONTINUATIONS49] =
4828 { advance_ctx, // CONT_DONE
4829 cont_set_global_env,
4830 cont_bind_to_key_rest,
4831 cont_if,
4832 cont_progn_rest,
4833 cont_application_args,
4834 cont_and,
4835 cont_or,
4836 cont_wait,
4837 cont_match,
4838 cont_application_start,
4839 cont_eval_r,
4840 cont_resume,
4841 cont_closure_application_args,
4842 cont_exit_atomic,
4843 cont_read_next_token,
4844 cont_read_append_continue,
4845 cont_read_eval_continue,
4846 cont_read_expect_closepar,
4847 cont_read_dot_terminate,
4848 cont_read_done,
4849 cont_read_quote_result,
4850 cont_read_commaat_result,
4851 cont_read_comma_result,
4852 cont_read_start_array,
4853 cont_read_append_array,
4854 cont_map,
4855 cont_match_guard,
4856 cont_terminate,
4857 cont_progn_var,
4858 cont_setq,
4859 cont_move_to_flash,
4860 cont_move_val_to_flash_dispatch,
4861 cont_move_list_to_flash,
4862 cont_close_list_in_flash,
4863 cont_qq_expand_start,
4864 cont_qq_expand,
4865 cont_qq_append,
4866 cont_qq_expand_list,
4867 cont_qq_list,
4868 cont_kill,
4869 cont_loop,
4870 cont_loop_condition,
4871 cont_merge_rest,
4872 cont_merge_layer,
4873 cont_closure_args_rest,
4874 cont_move_array_elts_to_flash,
4875 cont_pop_reader_flags,
4876 cont_exception_handler
4877 };
4878
4879/*********************************************************/
4880/* Evaluators lookup table (special forms) */
4881typedef void (*evaluator_fun)(eval_context_t *);
4882
4883static const evaluator_fun evaluators[] =
4884 {
4885 eval_quote,
4886 eval_define,
4887 eval_progn,
4888 eval_lambda,
4889 eval_if,
4890 eval_let,
4891 eval_and,
4892 eval_or,
4893 eval_match,
4894 eval_receive,
4895 eval_receive_timeout,
4896 eval_callcc,
4897 eval_atomic,
4898 eval_selfevaluating, // macro
4899 eval_selfevaluating, // cont
4900 eval_selfevaluating, // closure
4901 eval_cond,
4902 eval_app_cont,
4903 eval_var,
4904 eval_setq,
4905 eval_move_to_flash,
4906 eval_loop,
4907 eval_trap
4908 };
4909
4910
4911/*********************************************************/
4912/* Evaluator step function */
4913
4914static void evaluation_step(void){
4915 eval_context_t *ctx = ctx_running;
4916#ifdef VISUALIZE_HEAP
4917 heap_vis_gen_image();
4918#endif
4919
4920 if (ctx->app_cont) {
4921 lbm_value k;
4922 lbm_pop(&ctx->K, &k);
4923 ctx->app_cont = false0;
4924
4925 lbm_uint decoded_k = DEC_CONTINUATION(k)(((k) & ~0xF8000001u) >> 2);
4926
4927 if (decoded_k < NUM_CONTINUATIONS49) {
4928 continuations[decoded_k](ctx);
4929 } else {
4930 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4931 }
4932 return;
4933 }
4934
4935 if (lbm_is_symbol(ctx->curr_exp)) {
4936 eval_symbol(ctx);
4937 return;
4938 }
4939 if (lbm_is_cons(ctx->curr_exp)) {
4940 lbm_cons_t *cell = lbm_ref_cell(ctx->curr_exp);
4941 lbm_value h = cell->car;
4942 if (lbm_is_symbol(h) && ((h & ENC_SPECIAL_FORMS_MASK0xFFFFF000) == ENC_SPECIAL_FORMS_BIT0x00001000)) {
4943 lbm_uint eval_index = lbm_dec_sym(h) & SPECIAL_FORMS_INDEX_MASK0x000000FF;
4944 evaluators[eval_index](ctx);
4945 return;
4946 }
4947 /*
4948 * At this point head can be anything. It should evaluate
4949 * into a form that can be applied (closure, symbol, ...) though.
4950 */
4951 lbm_value *reserved = stack_reserve(ctx, 3);
4952 reserved[0] = ctx->curr_env;
4953 reserved[1] = cell->cdr;
4954 reserved[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
4955 ctx->curr_exp = h; // evaluate the function
4956 return;
4957 }
4958
4959 eval_selfevaluating(ctx);
4960 return;
4961}
4962
4963void lbm_pause_eval(void ) {
4964 eval_cps_next_state_arg = 0;
4965 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4966 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4967}
4968
4969void lbm_pause_eval_with_gc(uint32_t num_free) {
4970 eval_cps_next_state_arg = num_free;
4971 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4972 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4973}
4974
4975void lbm_continue_eval(void) {
4976 eval_cps_next_state = EVAL_CPS_STATE_RUNNING2;
4977 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4978}
4979
4980void lbm_kill_eval(void) {
4981 eval_cps_next_state = EVAL_CPS_STATE_KILL4;
4982 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4983}
4984
4985uint32_t lbm_get_eval_state(void) {
4986 return eval_cps_run_state;
4987}
4988
4989// Will wake up thread that is sleeping as well.
4990// Not sure this is good behavior.
4991static void handle_event_unblock_ctx(lbm_cid cid, lbm_value v) {
4992 eval_context_t *found = NULL((void*)0);
4993 mutex_lock(&qmutex);
4994
4995 found = lookup_ctx_nm(&blocked, cid);
4996 if (found) {
4997 drop_ctx_nm(&blocked,found);
4998 if (lbm_is_error(v)) {
4999 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
5000 found->app_cont = true1;
5001 }
5002 found->r = v;
5003 enqueue_ctx_nm(&queue,found);
5004 }
5005 mutex_unlock(&qmutex);
5006}
5007
5008static void handle_event_define(lbm_value key, lbm_value val) {
5009 lbm_uint dec_key = lbm_dec_sym(key);
5010 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
5011 lbm_value *global_env = lbm_get_global_env();
5012 lbm_uint orig_env = global_env[ix_key];
5013 lbm_value new_env;
5014 // A key is a symbol and should not need to be remembered.
5015 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
5016
5017 global_env[ix_key] = new_env;
5018}
5019
5020static lbm_value get_event_value(lbm_event_t *e) {
5021 lbm_value v;
5022 if (e->buf_len > 0) {
5023 lbm_flat_value_t fv;
5024 fv.buf = (uint8_t*)e->buf_ptr;
5025 fv.buf_size = e->buf_len;
5026 fv.buf_pos = 0;
5027 if (!lbm_unflatten_value(&fv, &v)) {
5028 lbm_set_flags(LBM_FLAG_HANDLER_EVENT_DELIVERY_FAILED(1 << 1));
5029 v = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
5030 }
5031 // Free the flat value buffer. GC is unaware of its existence.
5032 lbm_free(fv.buf);
5033 } else {
5034 v = (lbm_value)e->buf_ptr;
5035 }
5036 return v;
5037}
5038
5039static void process_events(void) {
5040
5041 if (!lbm_events) return;
5042 lbm_event_t e;
5043
5044 while (lbm_event_pop(&e)) {
5045
5046 lbm_value event_val = get_event_value(&e);
5047 switch(e.type) {
5048 case LBM_EVENT_UNBLOCK_CTX:
5049 handle_event_unblock_ctx((lbm_cid)e.parameter, event_val);
5050 break;
5051 case LBM_EVENT_DEFINE:
5052 handle_event_define((lbm_value)e.parameter, event_val);
5053 break;
5054 case LBM_EVENT_FOR_HANDLER:
5055 if (lbm_event_handler_pid >= 0) {
5056 lbm_find_receiver_and_send(lbm_event_handler_pid, event_val);
5057 }
5058 break;
5059 }
5060 }
5061}
5062
5063/* eval_cps_run can be paused
5064 I think it would be better use a mailbox for
5065 communication between other threads and the run_eval
5066 but for now a set of variables will be used. */
5067void lbm_run_eval(void){
5068
5069 if (setjmp(critical_error_jmp_buf)_setjmp (critical_error_jmp_buf) > 0) {
5070 printf_callback("GC stack overflow!\n");
5071 critical_error_callback();
5072 // terminate evaluation thread.
5073 return;
5074 }
5075
5076 setjmp(error_jmp_buf)_setjmp (error_jmp_buf);
5077
5078 while (eval_running) {
5079 if (eval_cps_state_changed || eval_cps_run_state == EVAL_CPS_STATE_PAUSED1) {
5080 eval_cps_state_changed = false0;
5081 switch (eval_cps_next_state) {
5082 case EVAL_CPS_STATE_PAUSED1:
5083 if (eval_cps_run_state != EVAL_CPS_STATE_PAUSED1) {
5084 if (lbm_heap_num_free() < eval_cps_next_state_arg) {
5085 gc();
5086 }
5087 eval_cps_next_state_arg = 0;
5088 }
5089 eval_cps_run_state = EVAL_CPS_STATE_PAUSED1;
5090 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5091 continue; /* jump back to start of eval_running loop */
5092 case EVAL_CPS_STATE_KILL4:
5093 eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
5094 eval_running = false0;
5095 continue;
5096 default: // running state
5097 eval_cps_run_state = eval_cps_next_state;
5098 break;
5099 }
5100 }
5101 while (true1) {
5102 if (eval_steps_quota && ctx_running) {
5103 eval_steps_quota--;
5104 evaluation_step();
5105 } else {
5106 if (eval_cps_state_changed) break;
5107 eval_steps_quota = eval_steps_refill;
5108 if (is_atomic) {
5109 if (!ctx_running) {
5110 lbm_set_flags(LBM_FLAG_ATOMIC_MALFUNCTION(1 << 0));
5111 is_atomic = 0;
5112 }
5113 } else {
5114 if (gc_requested) {
5115 gc();
5116 }
5117 process_events();
5118 mutex_lock(&qmutex);
5119 if (ctx_running) {
5120 enqueue_ctx_nm(&queue, ctx_running);
5121 ctx_running = NULL((void*)0);
5122 }
5123 wake_up_ctxs_nm();
5124 ctx_running = dequeue_ctx_nm(&queue);
5125 mutex_unlock(&qmutex);
5126 if (!ctx_running) {
5127 lbm_system_sleeping = true1;
5128 //Fixed sleep interval to poll events regularly.
5129 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5130 lbm_system_sleeping = false0;
5131 }
5132 }
5133 }
5134 }
5135 }
5136}
5137
5138lbm_cid lbm_eval_program(lbm_value lisp) {
5139 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), 256, NULL((void*)0));
5140}
5141
5142lbm_cid lbm_eval_program_ext(lbm_value lisp, unsigned int stack_size) {
5143 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), stack_size, NULL((void*)0));
5144}
5145
5146int lbm_eval_init() {
5147 if (!qmutex_initialized) {
5148 mutex_init(&qmutex);
5149 qmutex_initialized = true1;
5150 }
5151 if (!lbm_events_mutex_initialized) {
5152 mutex_init(&lbm_events_mutex);
5153 lbm_events_mutex_initialized = true1;
5154 }
5155 if (!blocking_extension_mutex_initialized) {
5156 mutex_init(&blocking_extension_mutex);
5157 blocking_extension_mutex_initialized = true1;
5158 }
5159
5160 mutex_lock(&qmutex);
5161 mutex_lock(&lbm_events_mutex);
5162
5163 blocked.first = NULL((void*)0);
5164 blocked.last = NULL((void*)0);
5165 queue.first = NULL((void*)0);
5166 queue.last = NULL((void*)0);
5167 ctx_running = NULL((void*)0);
5168
5169 eval_cps_run_state = EVAL_CPS_STATE_RUNNING2;
5170
5171 mutex_unlock(&lbm_events_mutex);
5172 mutex_unlock(&qmutex);
5173
5174 if (!lbm_init_env()) return 0;
5175 eval_running = true1;
5176 return 1;
5177}
5178
5179bool_Bool lbm_eval_init_events(unsigned int num_events) {
5180
5181 mutex_lock(&lbm_events_mutex);
5182 lbm_events = (lbm_event_t*)lbm_malloc(num_events * sizeof(lbm_event_t));
5183 bool_Bool r = false0;
5184 if (lbm_events) {
5185 lbm_events_max = num_events;
5186 lbm_events_head = 0;
5187 lbm_events_tail = 0;
5188 lbm_events_full = false0;
5189 lbm_event_handler_pid = -1;
5190 r = true1;
5191 }
5192 mutex_unlock(&lbm_events_mutex);
5193 return r;
5194}
diff --git a/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-52eee6.html b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-52eee6.html new file mode 100644 index 00000000..d79c649d --- /dev/null +++ b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-52eee6.html @@ -0,0 +1,6543 @@ + + + +src/eval_cps.c + + + + + + + + + + + + + + + + + + + + + + + + + + +

Bug Summary

+ + + + +
File:eval_cps.c
Warning:line 2998, column 13
Assigned value is garbage or undefined
+ +

Annotated Source Code

+

Press '?' + to see keyboard shortcuts

+ + +
clang -cc1 -triple i386-pc-linux-gnu -analyze -disable-free -disable-llvm-verifier -discard-value-names -main-file-name eval_cps.c -analyzer-store=region -analyzer-opt-analyze-nested-blocks -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -mrelocation-model static -mthread-model posix -mframe-pointer=none -fmath-errno -fno-rounding-math -masm-verbose -mconstructor-aliases -target-cpu i686 -dwarf-column-info -fno-split-dwarf-inlining -debugger-tuning=gdb -resource-dir /usr/lib/llvm-10/lib/clang/10.0.0 -I ./include -I ./include/extensions -I platform/linux/include -D _PRELUDE -internal-isystem /usr/local/include -internal-isystem /usr/lib/llvm-10/lib/clang/10.0.0/include -internal-externc-isystem /usr/include/i386-linux-gnu -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -std=c99 -fdebug-compilation-dir /home/joels/Current/lispbm -ferror-limit 19 -fmessage-length 0 -fgnuc-version=4.2.1 -fobjc-runtime=gcc -fdiagnostics-show-option -vectorize-loops -vectorize-slp -analyzer-output=html -faddrsig -o /home/joels/Current/lispbm/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1 -x c src/eval_cps.c +
+ + + +
+ + +
+ + + + +
+

src/eval_cps.c

+
→
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1/*
2 Copyright 2018, 2020 - 2024 Joel Svensson svenssonjoel@yahoo.se
3
4 This program is free software: you can redistribute it and/or modify
5 it under the terms of the GNU General Public License as published by
6 the Free Software Foundation, either version 3 of the License, or
7 (at your option) any later version.
8
9 This program is distributed in the hope that it will be useful,
10 but WITHOUT ANY WARRANTY; without even the implied warranty of
11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 GNU General Public License for more details.
13
14 You should have received a copy of the GNU General Public License
15 along with this program. If not, see <http://www.gnu.org/licenses/>.
16*/
17
18#include <lbm_memory.h>
19#include <lbm_types.h>
20#include "symrepr.h"
21#include "heap.h"
22#include "env.h"
23#include "eval_cps.h"
24#include "stack.h"
25#include "fundamental.h"
26#include "extensions.h"
27#include "tokpar.h"
28#include "lbm_channel.h"
29#include "print.h"
30#include "platform_mutex.h"
31#include "lbm_flat_value.h"
32#include "lbm_flags.h"
33
34#ifdef VISUALIZE_HEAP
35#include "heap_vis.h"
36#endif
37
38#include <setjmp.h>
39#include <stdarg.h>
40
41static jmp_buf error_jmp_buf;
42static jmp_buf critical_error_jmp_buf;
43
44#define S_TO_US(X)(lbm_uint)((X) * 1000000) (lbm_uint)((X) * 1000000)
45
46#define DEC_CONTINUATION(x)(((x) & ~0xF8000001u) >> 2) (((x) & ~LBM_CONTINUATION_INTERNAL0xF8000001u) >> LBM_ADDRESS_SHIFT2)
47#define IS_CONTINUATION(x)(((x) & 0xF8000001u) == 0xF8000001u) (((x) & LBM_CONTINUATION_INTERNAL0xF8000001u) == LBM_CONTINUATION_INTERNAL0xF8000001u)
48#define CONTINUATION(x)(((x) << 2) | 0xF8000001u) (((x) << LBM_ADDRESS_SHIFT2) | LBM_CONTINUATION_INTERNAL0xF8000001u)
49
50#define DONE(((0) << 2) | 0xF8000001u) CONTINUATION(0)(((0) << 2) | 0xF8000001u)
51#define SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u) CONTINUATION(1)(((1) << 2) | 0xF8000001u)
52#define BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u) CONTINUATION(2)(((2) << 2) | 0xF8000001u)
53#define IF(((3) << 2) | 0xF8000001u) CONTINUATION(3)(((3) << 2) | 0xF8000001u)
54#define PROGN_REST(((4) << 2) | 0xF8000001u) CONTINUATION(4)(((4) << 2) | 0xF8000001u)
55#define APPLICATION_ARGS(((5) << 2) | 0xF8000001u) CONTINUATION(5)(((5) << 2) | 0xF8000001u)
56#define AND(((6) << 2) | 0xF8000001u) CONTINUATION(6)(((6) << 2) | 0xF8000001u)
57#define OR(((7) << 2) | 0xF8000001u) CONTINUATION(7)(((7) << 2) | 0xF8000001u)
58#define WAIT(((8) << 2) | 0xF8000001u) CONTINUATION(8)(((8) << 2) | 0xF8000001u)
59#define MATCH(((9) << 2) | 0xF8000001u) CONTINUATION(9)(((9) << 2) | 0xF8000001u)
60#define APPLICATION_START(((10) << 2) | 0xF8000001u) CONTINUATION(10)(((10) << 2) | 0xF8000001u)
61#define EVAL_R(((11) << 2) | 0xF8000001u) CONTINUATION(11)(((11) << 2) | 0xF8000001u)
62#define RESUME(((12) << 2) | 0xF8000001u) CONTINUATION(12)(((12) << 2) | 0xF8000001u)
63#define CLOSURE_ARGS(((13) << 2) | 0xF8000001u) CONTINUATION(13)(((13) << 2) | 0xF8000001u)
64#define EXIT_ATOMIC(((14) << 2) | 0xF8000001u) CONTINUATION(14)(((14) << 2) | 0xF8000001u)
65#define READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u) CONTINUATION(15)(((15) << 2) | 0xF8000001u)
66#define READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u) CONTINUATION(16)(((16) << 2) | 0xF8000001u)
67#define READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u) CONTINUATION(17)(((17) << 2) | 0xF8000001u)
68#define READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u) CONTINUATION(18)(((18) << 2) | 0xF8000001u)
69#define READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u) CONTINUATION(19)(((19) << 2) | 0xF8000001u)
70#define READ_DONE(((20) << 2) | 0xF8000001u) CONTINUATION(20)(((20) << 2) | 0xF8000001u)
71#define READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u) CONTINUATION(21)(((21) << 2) | 0xF8000001u)
72#define READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u) CONTINUATION(22)(((22) << 2) | 0xF8000001u)
73#define READ_COMMA_RESULT(((23) << 2) | 0xF8000001u) CONTINUATION(23)(((23) << 2) | 0xF8000001u)
74#define READ_START_ARRAY(((24) << 2) | 0xF8000001u) CONTINUATION(24)(((24) << 2) | 0xF8000001u)
75#define READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u) CONTINUATION(25)(((25) << 2) | 0xF8000001u)
76#define MAP(((26) << 2) | 0xF8000001u) CONTINUATION(26)(((26) << 2) | 0xF8000001u)
77#define MATCH_GUARD(((27) << 2) | 0xF8000001u) CONTINUATION(27)(((27) << 2) | 0xF8000001u)
78#define TERMINATE(((28) << 2) | 0xF8000001u) CONTINUATION(28)(((28) << 2) | 0xF8000001u)
79#define PROGN_VAR(((29) << 2) | 0xF8000001u) CONTINUATION(29)(((29) << 2) | 0xF8000001u)
80#define SETQ(((30) << 2) | 0xF8000001u) CONTINUATION(30)(((30) << 2) | 0xF8000001u)
81#define MOVE_TO_FLASH(((31) << 2) | 0xF8000001u) CONTINUATION(31)(((31) << 2) | 0xF8000001u)
82#define MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u) CONTINUATION(32)(((32) << 2) | 0xF8000001u)
83#define MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u) CONTINUATION(33)(((33) << 2) | 0xF8000001u)
84#define CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u) CONTINUATION(34)(((34) << 2) | 0xF8000001u)
85#define QQ_EXPAND_START(((35) << 2) | 0xF8000001u) CONTINUATION(35)(((35) << 2) | 0xF8000001u)
86#define QQ_EXPAND(((36) << 2) | 0xF8000001u) CONTINUATION(36)(((36) << 2) | 0xF8000001u)
87#define QQ_APPEND(((37) << 2) | 0xF8000001u) CONTINUATION(37)(((37) << 2) | 0xF8000001u)
88#define QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u) CONTINUATION(38)(((38) << 2) | 0xF8000001u)
89#define QQ_LIST(((39) << 2) | 0xF8000001u) CONTINUATION(39)(((39) << 2) | 0xF8000001u)
90#define KILL(((40) << 2) | 0xF8000001u) CONTINUATION(40)(((40) << 2) | 0xF8000001u)
91#define LOOP(((41) << 2) | 0xF8000001u) CONTINUATION(41)(((41) << 2) | 0xF8000001u)
92#define LOOP_CONDITION(((42) << 2) | 0xF8000001u) CONTINUATION(42)(((42) << 2) | 0xF8000001u)
93#define MERGE_REST(((43) << 2) | 0xF8000001u) CONTINUATION(43)(((43) << 2) | 0xF8000001u)
94#define MERGE_LAYER(((44) << 2) | 0xF8000001u) CONTINUATION(44)(((44) << 2) | 0xF8000001u)
95#define CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u) CONTINUATION(45)(((45) << 2) | 0xF8000001u)
96#define MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u) CONTINUATION(46)(((46) << 2) | 0xF8000001u)
97#define POP_READER_FLAGS(((47) << 2) | 0xF8000001u) CONTINUATION(47)(((47) << 2) | 0xF8000001u)
98#define EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u) CONTINUATION(48)(((48) << 2) | 0xF8000001u)
99#define NUM_CONTINUATIONS49 49
100
101#define FM_NEED_GC-1 -1
102#define FM_NO_MATCH-2 -2
103#define FM_PATTERN_ERROR-3 -3
104
105typedef enum {
106 BL_OK = 0,
107 BL_NO_MEMORY,
108 BL_INCORRECT_KEY
109} binding_location_status;
110
111#define FB_OK0 0
112#define FB_TYPE_ERROR-1 -1
113
114const char* lbm_error_str_parse_eof = "End of parse stream.";
115const char* lbm_error_str_parse_dot = "Incorrect usage of '.'.";
116const char* lbm_error_str_parse_close = "Expected closing parenthesis.";
117const char* lbm_error_str_num_args = "Incorrect number of arguments.";
118const char* lbm_error_str_forbidden_in_atomic = "Operation is forbidden in an atomic block.";
119const char* lbm_error_str_no_number = "Argument(s) must be a number.";
120const char* lbm_error_str_not_a_boolean = "Argument must be t or nil (true or false).";
121const char* lbm_error_str_incorrect_arg = "Incorrect argument.";
122const char* lbm_error_str_var_outside_progn = "Usage of var outside of progn.";
123const char* lbm_error_str_flash_not_possible = "Value cannot be written to flash.";
124const char* lbm_error_str_flash_error = "Error writing to flash.";
125const char* lbm_error_str_flash_full = "Flash memory is full.";
126const char* lbm_error_str_variable_not_bound = "Variable not bound.";
127
128static lbm_value lbm_error_suspect;
129static bool_Bool lbm_error_has_suspect = false0;
130#ifdef LBM_ALWAYS_GC
131
132#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
133 gc(); \
134 (y) = (x); \
135 if (lbm_is_symbol_merror((y))) { \
136 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
137 }
138
139#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
140 lbm_gc_mark_phase(r); \
141 gc(); \
142 (y) = (x); \
143 if (lbm_is_symbol_merror((y))) { \
144 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
145 }
146
147#else
148
149#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
150 (y) = (x); \
151 if (lbm_is_symbol_merror((y))) { \
152 gc(); \
153 (y) = (x); \
154 if (lbm_is_symbol_merror((y))) { \
155 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
156 } \
157 /* continue executing statements below */ \
158 }
159#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
160 (y) = (x); \
161 if (lbm_is_symbol_merror((y))) { \
162 lbm_gc_mark_phase(r); \
163 gc(); \
164 (y) = (x); \
165 if (lbm_is_symbol_merror((y))) { \
166 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
167 } \
168 /* continue executing statements below */ \
169 }
170
171#endif
172
173typedef struct {
174 eval_context_t *first;
175 eval_context_t *last;
176} eval_context_queue_t;
177
178#ifdef CLEAN_UP_CLOSURES
179static lbm_value clean_cl_env_symbol = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
180#endif
181
182static int gc(void);
183static void error_ctx(lbm_value);
184static void error_at_ctx(lbm_value err_val, lbm_value at);
185static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx);
186static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail);
187
188// The currently executing context.
189eval_context_t *ctx_running = NULL((void*)0);
190volatile bool_Bool lbm_system_sleeping = false0;
191
192static volatile bool_Bool gc_requested = false0;
193void lbm_request_gc(void) {
194 gc_requested = true1;
195}
196
197/*
198 On ChibiOs the CH_CFG_ST_FREQUENCY setting in chconf.h sets the
199 resolution of the timer used for sleep operations. If this is set
200 to 10KHz the resolution is 100us.
201
202 The CH_CFG_ST_TIMEDELTA specifies the minimum number of ticks that
203 can be safely specified in a timeout directive (wonder if that
204 means sleep-period). The timedelta is set to 2.
205
206 If I have understood these correctly it means that the minimum
207 sleep duration possible is 2 * 100us = 200us.
208*/
209
210#define EVAL_CPS_DEFAULT_STACK_SIZE256 256
211#define EVAL_CPS_MIN_SLEEP200 200
212#define EVAL_STEPS_QUOTA10 10
213
214static volatile uint32_t eval_steps_refill = EVAL_STEPS_QUOTA10;
215static uint32_t eval_steps_quota = EVAL_STEPS_QUOTA10;
216
217void lbm_set_eval_step_quota(uint32_t quota) {
218 eval_steps_refill = quota;
219}
220
221static uint32_t eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
222static volatile uint32_t eval_cps_next_state = EVAL_CPS_STATE_NONE0;
223static volatile uint32_t eval_cps_next_state_arg = 0;
224static volatile bool_Bool eval_cps_state_changed = false0;
225
226static void usleep_nonsense(uint32_t us) {
227 (void) us;
228}
229
230static bool_Bool dynamic_load_nonsense(const char *sym, const char **code) {
231 (void) sym;
232 (void) code;
233 return false0;
234}
235
236static uint32_t timestamp_nonsense(void) {
237 return 0;
238}
239
240static int printf_nonsense(const char *fmt, ...) {
241 (void) fmt;
242 return 0;
243}
244
245static void ctx_done_nonsense(eval_context_t *ctx) {
246 (void) ctx;
247}
248
249static void critical_nonsense(void) {
250 return;
251}
252
253static void (*critical_error_callback)(void) = critical_nonsense;
254static void (*usleep_callback)(uint32_t) = usleep_nonsense;
255static uint32_t (*timestamp_us_callback)(void) = timestamp_nonsense;
256static void (*ctx_done_callback)(eval_context_t *) = ctx_done_nonsense;
257static int (*printf_callback)(const char *, ...) = printf_nonsense;
258static bool_Bool (*dynamic_load_callback)(const char *, const char **) = dynamic_load_nonsense;
259
260void lbm_set_critical_error_callback(void (*fptr)(void)) {
261 if (fptr == NULL((void*)0)) critical_error_callback = critical_nonsense;
262 else critical_error_callback = fptr;
263}
264
265void lbm_set_usleep_callback(void (*fptr)(uint32_t)) {
266 if (fptr == NULL((void*)0)) usleep_callback = usleep_nonsense;
267 else usleep_callback = fptr;
268}
269
270void lbm_set_timestamp_us_callback(uint32_t (*fptr)(void)) {
271 if (fptr == NULL((void*)0)) timestamp_us_callback = timestamp_nonsense;
272 else timestamp_us_callback = fptr;
273}
274
275void lbm_set_ctx_done_callback(void (*fptr)(eval_context_t *)) {
276 if (fptr == NULL((void*)0)) ctx_done_callback = ctx_done_nonsense;
277 else ctx_done_callback = fptr;
278}
279
280void lbm_set_printf_callback(int (*fptr)(const char*, ...)){
281 if (fptr == NULL((void*)0)) printf_callback = printf_nonsense;
282 else printf_callback = fptr;
283}
284
285void lbm_set_dynamic_load_callback(bool_Bool (*fptr)(const char *, const char **)) {
286 if (fptr == NULL((void*)0)) dynamic_load_callback = dynamic_load_nonsense;
287 else dynamic_load_callback = fptr;
288}
289
290static volatile lbm_event_t *lbm_events = NULL((void*)0);
291static unsigned int lbm_events_head = 0;
292static unsigned int lbm_events_tail = 0;
293static unsigned int lbm_events_max = 0;
294static bool_Bool lbm_events_full = false0;
295static mutex_t lbm_events_mutex;
296static bool_Bool lbm_events_mutex_initialized = false0;
297static volatile lbm_cid lbm_event_handler_pid = -1;
298
299lbm_cid lbm_get_event_handler_pid(void) {
300 return lbm_event_handler_pid;
301}
302
303void lbm_set_event_handler_pid(lbm_cid pid) {
304 lbm_event_handler_pid = pid;
305}
306
307bool_Bool lbm_event_handler_exists(void) {
308 return(lbm_event_handler_pid > 0);
309}
310
311
312static bool_Bool event_internal(lbm_event_type_t event_type, lbm_uint parameter, lbm_uint buf_ptr, lbm_uint buf_len) {
313 bool_Bool r = false0;
314 if (lbm_events) {
315 mutex_lock(&lbm_events_mutex);
316 if (!lbm_events_full) {
317 lbm_event_t event;
318 event.type = event_type;
319 event.parameter = parameter;
320 event.buf_ptr = buf_ptr;
321 event.buf_len = buf_len;
322 lbm_events[lbm_events_head] = event;
323 lbm_events_head = (lbm_events_head + 1) % lbm_events_max;
324 lbm_events_full = lbm_events_head == lbm_events_tail;
325 r = true1;
326 }
327 mutex_unlock(&lbm_events_mutex);
328 }
329 return r;
330}
331
332bool_Bool lbm_event_define(lbm_value key, lbm_flat_value_t *fv) {
333 return event_internal(LBM_EVENT_DEFINE, key, (lbm_uint)fv->buf, fv->buf_size);
334}
335
336bool_Bool lbm_event_unboxed(lbm_value unboxed) {
337 lbm_uint t = lbm_type_of(unboxed);
338 if (t == LBM_TYPE_SYMBOL0x00000000u ||
339 t == LBM_TYPE_I0x00000008u ||
340 t == LBM_TYPE_U0x0000000Cu ||
341 t == LBM_TYPE_CHAR0x00000004u) {
342 if (lbm_event_handler_pid > 0) {
343 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)unboxed, 0);
344 }
345 }
346 return false0;
347}
348
349bool_Bool lbm_event(lbm_flat_value_t *fv) {
350 if (lbm_event_handler_pid > 0) {
351 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)fv->buf, fv->buf_size);
352 }
353 return false0;
354}
355
356static bool_Bool lbm_event_pop(lbm_event_t *event) {
357 mutex_lock(&lbm_events_mutex);
358 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
359 mutex_unlock(&lbm_events_mutex);
360 return false0;
361 }
362 *event = lbm_events[lbm_events_tail];
363 lbm_events_tail = (lbm_events_tail + 1) % lbm_events_max;
364 lbm_events_full = false0;
365 mutex_unlock(&lbm_events_mutex);
366 return true1;
367}
368
369bool_Bool lbm_event_queue_is_empty(void) {
370 mutex_lock(&lbm_events_mutex);
371 bool_Bool empty = false0;
372 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
373 empty = true1;
374 }
375 mutex_unlock(&lbm_events_mutex);
376 return empty;
377}
378
379static bool_Bool eval_running = false0;
380static volatile bool_Bool blocking_extension = false0;
381static mutex_t blocking_extension_mutex;
382static bool_Bool blocking_extension_mutex_initialized = false0;
383static lbm_uint blocking_extension_timeout_us = 0;
384static bool_Bool blocking_extension_timeout = false0;
385
386static uint32_t is_atomic = 0;
387
388/* Process queues */
389static eval_context_queue_t blocked = {NULL((void*)0), NULL((void*)0)};
390static eval_context_queue_t queue = {NULL((void*)0), NULL((void*)0)};
391
392/* one mutex for all queue operations */
393mutex_t qmutex;
394bool_Bool qmutex_initialized = false0;
395
396
397// MODES
398static volatile bool_Bool lbm_verbose = false0;
399
400void lbm_toggle_verbose(void) {
401 lbm_verbose = !lbm_verbose;
402}
403
404void lbm_set_verbose(bool_Bool verbose) {
405 lbm_verbose = verbose;
406}
407
408lbm_cid lbm_get_current_cid(void) {
409 if (ctx_running)
410 return ctx_running->id;
411 else
412 return -1;
413}
414
415eval_context_t *lbm_get_current_context(void) {
416 return ctx_running;
417}
418
419/****************************************************/
420/* Utilities used locally in this file */
421
422static lbm_value cons_with_gc(lbm_value head, lbm_value tail, lbm_value remember) {
423#ifdef LBM_ALWAYS_GC
424 lbm_value roots[3] = {head, tail, remember};
425 lbm_gc_mark_roots(roots, 3);
426 gc();
427 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
428 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
429 if (lbm_is_symbol_merror(res)) {
430 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
431 }
432 return res;
433#else
434 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
435 if (lbm_is_symbol_merror(res)) {
436 lbm_value roots[3] = {head, tail, remember};
437 lbm_gc_mark_roots(roots,3);
438 gc();
439 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
440 if (lbm_is_symbol_merror(res)) {
441 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
442 }
443 }
444 return res;
445#endif
446}
447
448static lbm_uint *get_stack_ptr(eval_context_t *ctx, unsigned int n) {
449 if (n <= ctx->K.sp) {
450 lbm_uint index = ctx->K.sp - n;
451 return &ctx->K.data[index];
452 }
453 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
454 return 0; // dead code cannot be reached, but C compiler doesn't realise.
455}
456
457// pop_stack_ptr is safe when no GC is performed and
458// the values of the stack will be dropped.
459static lbm_uint *pop_stack_ptr(eval_context_t *ctx, unsigned int n) {
460 if (n <= ctx->K.sp) {
461 ctx->K.sp -= n;
462 return &ctx->K.data[ctx->K.sp];
463 }
464 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
465 return 0; // dead code cannot be reached, but C compiler doesn't realise.
466}
467
468static inline lbm_uint *stack_reserve(eval_context_t *ctx, unsigned int n) {
469 if (ctx->K.sp + n < ctx->K.size) {
470 lbm_uint *ptr = &ctx->K.data[ctx->K.sp];
471 ctx->K.sp += n;
472 return ptr;
473 }
474 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
475 return 0; // dead code cannot be reached, but C compiler doesn't realise.
476}
477
478static void handle_flash_status(lbm_flash_status s) {
479 if ( s == LBM_FLASH_FULL) {
480 lbm_set_error_reason((char*)lbm_error_str_flash_full);
481 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
482 }
483 if (s == LBM_FLASH_WRITE_ERROR) {
484 lbm_set_error_reason((char*)lbm_error_str_flash_error);
485 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
486 }
487}
488
489static void lift_array_flash(lbm_value flash_cell, bool_Bool bytearray, char *data, lbm_uint num_elt) {
490
491 lbm_array_header_t flash_array_header;
492 flash_array_header.size = num_elt;
493 flash_array_header.data = (lbm_uint*)data;
494 lbm_uint flash_array_header_ptr;
495 handle_flash_status(lbm_write_const_raw((lbm_uint*)&flash_array_header,
496 sizeof(lbm_array_header_t) / sizeof(lbm_uint),
497 &flash_array_header_ptr));
498 handle_flash_status(write_const_car(flash_cell, flash_array_header_ptr));
499 lbm_uint t = bytearray ? ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u) : ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u);
500 handle_flash_status(write_const_cdr(flash_cell, t));
501}
502
503static void get_car_and_cdr(lbm_value a, lbm_value *a_car, lbm_value *a_cdr) {
504 if (lbm_is_ptr(a)) {
2
←
Assuming the condition is true
→
3
←
Taking true branch
→
17
←
Assuming the condition is false
→
18
←
Taking false branch
→
505 lbm_cons_t *cell = lbm_ref_cell(a);
506 *a_car = cell->car;
507 *a_cdr = cell->cdr;
4
←
Value assigned to 'cdr_params', which participates in a condition later
→
508 } else if (lbm_is_symbol_nil(a)) {
19
←
Taking false branch
→
509 *a_car = *a_cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
510 } else {
511 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
512 }
513}
20
←
Returning without writing to '*a_cdr'
→
514
515/* car cdr caar cadr replacements that are evaluator safe. */
516static lbm_value get_car(lbm_value a) {
517 if (lbm_is_ptr(a)) {
518 lbm_cons_t *cell = lbm_ref_cell(a);
519 return cell->car;
520 } else if (lbm_is_symbol_nil(a)) {
521 return a;
522 }
523 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
524 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
525}
526
527static lbm_value get_cdr(lbm_value a) {
528 if (lbm_is_ptr(a)) {
529 lbm_cons_t *cell = lbm_ref_cell(a);
530 return cell->cdr;
531 } else if (lbm_is_symbol_nil(a)) {
532 return a;
533 }
534 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
535 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
536}
537
538static lbm_value get_cadr(lbm_value a) {
539 if (lbm_is_ptr(a)) {
540 lbm_cons_t *cell = lbm_ref_cell(a);
541 lbm_value tmp = cell->cdr;
542 if (lbm_is_ptr(tmp)) {
543 return lbm_ref_cell(tmp)->car;
544 } else if (lbm_is_symbol_nil(tmp)) {
545 return tmp;
546 }
547 } else if (lbm_is_symbol_nil(a)) {
548 return a;
549 }
550 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
551 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
552}
553
554static lbm_value allocate_closure(lbm_value params, lbm_value body, lbm_value env) {
555
556#ifdef LBM_ALWAYS_GC
557 gc();
558 if (lbm_heap_num_free() < 4) {
559 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
560 }
561#else
562 if (lbm_heap_num_free() < 4) {
563 gc();
564 if (lbm_heap_num_free() < 4) {
565 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
566 }
567 }
568#endif
569 // The freelist will always contain just plain heap-cells.
570 // So dec_ptr is sufficient.
571 lbm_value res = lbm_heap_state.freelist;
572 if (lbm_type_of(res) == LBM_TYPE_CONS0x10000000u) {
573 lbm_cons_t *heap = lbm_heap_state.heap;
574 lbm_uint ix = lbm_dec_ptr(res);
575 heap[ix].car = ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u);
576 ix = lbm_dec_ptr(heap[ix].cdr);
577 heap[ix].car = params;
578 ix = lbm_dec_ptr(heap[ix].cdr);
579 heap[ix].car = body;
580 ix = lbm_dec_ptr(heap[ix].cdr);
581 heap[ix].car = env;
582 lbm_heap_state.freelist = heap[ix].cdr;
583 heap[ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
584 lbm_heap_state.num_alloc+=4;
585 } else {
586 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
587 }
588 return res;
589}
590
591// Allocate a binding and attach it to a list (if so desired)
592static lbm_value allocate_binding(lbm_value key, lbm_value val, lbm_value the_cdr) {
593 if (lbm_heap_num_free() < 2) {
594 gc();
595 if (lbm_heap_num_free() < 2) {
596 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
597 }
598 }
599 lbm_cons_t* heap = lbm_heap_state.heap;
600 lbm_value binding_cell = lbm_heap_state.freelist;
601 lbm_uint binding_cell_ix = lbm_dec_ptr(binding_cell);
602 lbm_value list_cell = heap[binding_cell_ix].cdr;
603 lbm_uint list_cell_ix = lbm_dec_ptr(list_cell);
604 lbm_heap_state.freelist = heap[list_cell_ix].cdr;
605 lbm_heap_state.num_alloc += 2;
606 heap[binding_cell_ix].car = key;
607 heap[binding_cell_ix].cdr = val;
608 heap[list_cell_ix].car = binding_cell;
609 heap[list_cell_ix].cdr = the_cdr;
610 return list_cell;
611}
612
613#define CLO_PARAMS0 0
614#define CLO_BODY1 1
615#define CLO_ENV2 2
616#define LOOP_BINDS0 0
617#define LOOP_COND1 1
618#define LOOP_BODY2 2
619
620// (a b c) -> [a b c]
621static lbm_value extract_n(lbm_value curr, lbm_value *res, unsigned int n) {
622 for (unsigned int i = 0; i < n; i ++) {
623 if (lbm_is_ptr(curr)) {
624 lbm_cons_t *cell = lbm_ref_cell(curr);
625 res[i] = cell->car;
626 curr = cell->cdr;
627 } else {
628 res[i] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
629 }
630 }
631 return curr; // Rest of list is returned here.
632}
633
634static void call_fundamental(lbm_uint fundamental, lbm_value *args, lbm_uint arg_count, eval_context_t *ctx) {
635 lbm_value res;
636 res = fundamental_table[fundamental](args, arg_count, ctx);
637 if (lbm_is_error(res)) {
638 if (lbm_is_symbol_merror(res)) {
639 gc();
640 res = fundamental_table[fundamental](args, arg_count, ctx);
641 }
642 if (lbm_is_error(res)) {
643 error_at_ctx(res, lbm_enc_sym(FUNDAMENTAL_SYMBOLS_START0x20000 | fundamental));
644 }
645 }
646 lbm_stack_drop(&ctx->K, arg_count+1);
647 ctx->app_cont = true1;
648 ctx->r = res;
649}
650
651// block_current_ctx blocks a context until it is
652// woken up externally or a timeout period of time passes.
653static void block_current_ctx(uint32_t state, lbm_uint sleep_us, bool_Bool do_cont) {
654 ctx_running->timestamp = timestamp_us_callback();
655 ctx_running->sleep_us = sleep_us;
656 ctx_running->state = state;
657 ctx_running->app_cont = do_cont;
658 enqueue_ctx(&blocked, ctx_running);
659 ctx_running = NULL((void*)0);
660}
661
662lbm_flash_status lbm_write_const_array_padded(uint8_t *data, lbm_uint n, lbm_uint *res) {
663 lbm_uint full_words = n / sizeof(lbm_uint);
664 lbm_uint n_mod = n % sizeof(lbm_uint);
665
666 if (n_mod == 0) { // perfect fit.
667 return lbm_write_const_raw((lbm_uint*)data, full_words, res);
668 } else {
669 lbm_uint last_word = 0;
670 memcpy(&last_word, &data[full_words * sizeof(lbm_uint)], n_mod);
671 if (full_words >= 1) {
672 lbm_flash_status s = lbm_write_const_raw((lbm_uint*)data, full_words, res);
673 if ( s == LBM_FLASH_WRITE_OK) {
674 lbm_uint dummy;
675 s = lbm_write_const_raw(&last_word, 1, &dummy);
676 }
677 return s;
678 } else {
679 return lbm_write_const_raw(&last_word, 1, res);
680 }
681 }
682}
683
684/****************************************************/
685/* Error message creation */
686
687#define ERROR_MESSAGE_BUFFER_SIZE_BYTES256 256
688
689void print_environments(char *buf, unsigned int size) {
690
691 lbm_value curr_l = ctx_running->curr_env;
692 printf_callback("\tCurrent local environment:\n");
693 while (lbm_type_of(curr_l) == LBM_TYPE_CONS0x10000000u) {
694 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_l));
695 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_l)));
696 printf_callback("\t%s = %s\n", buf, buf+(size/2));
697 curr_l = lbm_cdr(curr_l);
698 }
699 printf_callback("\n\n");
700 printf_callback("\tCurrent global environment:\n");
701 lbm_value *glob_env = lbm_get_global_env();
702
703 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
704 lbm_value curr_g = glob_env[i];;
705 while (lbm_type_of(curr_g) == LBM_TYPE_CONS0x10000000u) {
706
707 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_g));
708 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_g)));
709 printf_callback("\t%s = %s\n", buf, buf+(size/2));
710 curr_g = lbm_cdr(curr_g);
711 }
712 }
713}
714
715void print_error_message(lbm_value error, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int col, lbm_int row0, lbm_int row1) {
716 if (!printf_callback) return;
717
718 /* try to allocate a lbm_print_value buffer on the lbm_memory */
719 char *buf = lbm_malloc_reserve(ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
720 if (!buf) {
721 printf_callback("Error: Not enough free memory to create a human readable error message\n");
722 return;
723 }
724
725 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, error);
726 printf_callback( "*** Error: %s\n", buf);
727 if (has_at) {
728 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, at);
729 printf_callback("*** In: %s\n",buf);
730 if (lbm_error_has_suspect) {
731 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, lbm_error_suspect);
732 lbm_error_has_suspect = false0;
733 printf_callback("*** At: %s\n", buf);
734 } else {
735 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
736 printf_callback("*** After: %s\n",buf);
737 }
738 } else {
739 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
740 printf_callback("*** Near: %s\n",buf);
741 }
742
743 printf_callback("\n");
744
745 if (lbm_is_symbol(error) &&
746 error == ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u)) {
747 printf_callback("*** Line: %u\n", row);
748 printf_callback("*** Column: %u\n", col);
749 } else if (row0 != -1 || row1 != -1 ) {
750 printf_callback("*** Between rows: (-1 unknown) \n");
751 printf_callback("*** Start: %d\n", (int32_t)row0);
752 printf_callback("*** End: %d\n", (int32_t)row1);
753 }
754
755 printf_callback("\n");
756
757 if (ctx_running->error_reason) {
758 printf_callback("Reason:\n %s\n\n", ctx_running->error_reason);
759 }
760 if (lbm_verbose) {
761 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
762 printf_callback(" In context: %d\n", ctx_running->id);
763 printf_callback(" Current intermediate result: %s\n\n", buf);
764
765 print_environments(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
766 printf_callback("\n\n");
767
768 printf_callback(" Stack:\n");
769 for (unsigned int i = 0; i < ctx_running->K.sp; i ++) {
770 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->K.data[i]);
771 printf_callback(" %s\n", buf);
772 }
773 }
774 lbm_free(buf);
775}
776
777/****************************************************/
778/* Tokenizing and parsing */
779
780bool_Bool create_string_channel(char *str, lbm_value *res) {
781
782 lbm_char_channel_t *chan = NULL((void*)0);
783 lbm_string_channel_state_t *st = NULL((void*)0);
784
785 st = (lbm_string_channel_state_t*)lbm_memory_allocate(sizeof(lbm_string_channel_state_t) / sizeof(lbm_uint) +1);
786 if (st == NULL((void*)0)) {
787 return false0;
788 }
789 chan = (lbm_char_channel_t*)lbm_memory_allocate(sizeof(lbm_char_channel_t) / sizeof(lbm_uint) + 1);
790 if (chan == NULL((void*)0)) {
791 lbm_memory_free((lbm_uint*)st);
792 return false0;
793 }
794
795 lbm_create_string_char_channel(st, chan, str);
796 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
797 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
798 lbm_memory_free((lbm_uint*)st);
799 lbm_memory_free((lbm_uint*)chan);
800 return false0;
801 }
802
803 *res = cell;
804 return true1;
805}
806
807bool_Bool lift_char_channel(lbm_char_channel_t *chan , lbm_value *res) {
808 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
809 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
810 return false0;
811 }
812 *res = cell;
813 return true1;
814}
815
816
817/****************************************************/
818/* Queue functions */
819
820static void queue_iterator_nm(eval_context_queue_t *q, ctx_fun f, void *arg1, void *arg2) {
821 eval_context_t *curr;
822 curr = q->first;
823
824 while (curr != NULL((void*)0)) {
825 f(curr, arg1, arg2);
826 curr = curr->next;
827 }
828}
829
830void lbm_running_iterator(ctx_fun f, void *arg1, void *arg2){
831 mutex_lock(&qmutex);
832 queue_iterator_nm(&queue, f, arg1, arg2);
833 mutex_unlock(&qmutex);
834}
835
836void lbm_blocked_iterator(ctx_fun f, void *arg1, void *arg2){
837 mutex_lock(&qmutex);
838 queue_iterator_nm(&blocked, f, arg1, arg2);
839 mutex_unlock(&qmutex);
840}
841
842static void enqueue_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
843 if (q->last == NULL((void*)0)) {
844 ctx->prev = NULL((void*)0);
845 ctx->next = NULL((void*)0);
846 q->first = ctx;
847 q->last = ctx;
848 } else {
849 ctx->prev = q->last;
850 ctx->next = NULL((void*)0);
851 q->last->next = ctx;
852 q->last = ctx;
853 }
854}
855
856static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx) {
857 mutex_lock(&qmutex);
858 enqueue_ctx_nm(q,ctx);
859 mutex_unlock(&qmutex);
860}
861
862static eval_context_t *lookup_ctx_nm(eval_context_queue_t *q, lbm_cid cid) {
863 eval_context_t *curr;
864 curr = q->first;
865 while (curr != NULL((void*)0)) {
866 if (curr->id == cid) {
867 return curr;
868 }
869 curr = curr->next;
870 }
871 return NULL((void*)0);
872}
873
874static bool_Bool drop_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
875
876 bool_Bool res = false0;
877 if (q->first == NULL((void*)0) || q->last == NULL((void*)0)) {
878 if (!(q->last == NULL((void*)0) && q->first == NULL((void*)0))) {
879 /* error state that should not happen */
880 return res;
881 }
882 /* Queue is empty */
883 return res;
884 }
885
886 eval_context_t *curr = q->first;
887 while (curr) {
888 if (curr->id == ctx->id) {
889 res = true1;
890 eval_context_t *tmp = curr->next;
891 if (curr->prev == NULL((void*)0)) {
892 if (curr->next == NULL((void*)0)) {
893 q->last = NULL((void*)0);
894 q->first = NULL((void*)0);
895 } else {
896 q->first = tmp;
897 tmp->prev = NULL((void*)0);
898 }
899 } else { /* curr->prev != NULL */
900 if (curr->next == NULL((void*)0)) {
901 q->last = curr->prev;
902 q->last->next = NULL((void*)0);
903 } else {
904 curr->prev->next = tmp;
905 tmp->prev = curr->prev;
906 }
907 }
908 break;
909 }
910 curr = curr->next;
911 }
912 return res;
913}
914
915/* End execution of the running context. */
916static void finish_ctx(void) {
917
918 if (!ctx_running) {
919 return;
920 }
921 /* Drop the continuation stack immediately to free up lbm_memory */
922 lbm_stack_free(&ctx_running->K);
923 ctx_done_callback(ctx_running);
924 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->name)) {
925 lbm_free(ctx_running->name);
926 }
927 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->error_reason)) {
928 lbm_memory_free((lbm_uint*)ctx_running->error_reason);
929 }
930 lbm_memory_free((lbm_uint*)ctx_running->mailbox);
931 lbm_memory_free((lbm_uint*)ctx_running);
932 ctx_running = NULL((void*)0);
933}
934
935static void context_exists(eval_context_t *ctx, void *cid, void *b) {
936 if (ctx->id == *(lbm_cid*)cid) {
937 *(bool_Bool*)b = true1;
938 }
939}
940
941bool_Bool lbm_wait_ctx(lbm_cid cid, lbm_uint timeout_ms) {
942
943 bool_Bool exists;
944 uint32_t i = 0;
945
946 do {
947 exists = false0;
948 lbm_blocked_iterator(context_exists, &cid, &exists);
949 lbm_running_iterator(context_exists, &cid, &exists);
950
951 if (ctx_running &&
952 ctx_running->id == cid) {
953 exists = true1;
954 }
955
956 if (exists) {
957 if (usleep_callback) {
958 usleep_callback(1000);
959 }
960 if (timeout_ms > 0) i ++;
961 }
962 } while (exists && i < timeout_ms);
963
964 if (exists) return false0;
965 return true1;
966}
967
968void lbm_set_error_suspect(lbm_value suspect) {
969 lbm_error_suspect = suspect;
970 lbm_error_has_suspect = true1;
971}
972
973void lbm_set_error_reason(char *error_str) {
974 if (ctx_running != NULL((void*)0)) {
975 ctx_running->error_reason = error_str;
976 }
977}
978
979// Not possible to CONS_WITH_GC in error_ctx_base (potential loop)
980static void error_ctx_base(lbm_value err_val, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int column) {
981
982 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
983 if (lbm_heap_num_free() < 3) {
984 gc();
985 }
986
987 if (lbm_heap_num_free() >= 3) {
988 lbm_value msg = lbm_cons(err_val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
989 msg = lbm_cons(lbm_enc_i(ctx_running->id), msg);
990 msg = lbm_cons(ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u), msg);
991 if (!lbm_is_symbol_merror(msg)) {
992 lbm_find_receiver_and_send(ctx_running->parent, msg);
993 goto error_ctx_base_done;
994 }
995 }
996 }
997 if ((ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10) &&
998 (err_val != ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u))) {
999 lbm_uint v;
1000 while (ctx_running->K.sp > 0) {
1001 lbm_pop(&ctx_running->K, &v);
1002 if (v == EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u)) {
1003 lbm_value *sptr = get_stack_ptr(ctx_running, 2);
1004 lbm_set_car(sptr[0], ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
1005 stack_reserve(ctx_running, 1)[0] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1006 ctx_running->app_cont = true1;
1007 ctx_running->r = err_val;
1008 longjmp(error_jmp_buf, 1);
1009 }
1010 }
1011 err_val = ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u);
1012 }
1013 print_error_message(err_val,
1014 has_at,
1015 at,
1016 row,
1017 column,
1018 ctx_running->row0,
1019 ctx_running->row1);
1020 error_ctx_base_done:
1021 ctx_running->r = err_val;
1022 finish_ctx();
1023 longjmp(error_jmp_buf, 1);
1024}
1025
1026static void error_at_ctx(lbm_value err_val, lbm_value at) {
1027 error_ctx_base(err_val, true1, at, 0, 0);
1028}
1029
1030static void error_ctx(lbm_value err_val) {
1031 error_ctx_base(err_val, false0, 0, 0, 0);
1032}
1033
1034static void read_error_ctx(unsigned int row, unsigned int column) {
1035 error_ctx_base(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u), false0, 0, row, column);
1036}
1037
1038void lbm_critical_error(void) {
1039 longjmp(critical_error_jmp_buf, 1);
1040}
1041
1042// successfully finish a context
1043static void ok_ctx(void) {
1044 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
1045 lbm_value msg;
1046 WITH_GC(msg, lbm_heap_allocate_list_init(3,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1047 ENC_SYM_EXIT_OK,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1048 lbm_enc_i(ctx_running->id),(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1049 ctx_running->r))(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
1050 lbm_find_receiver_and_send(ctx_running->parent, msg);
1051 }
1052 finish_ctx();
1053}
1054
1055static eval_context_t *dequeue_ctx_nm(eval_context_queue_t *q) {
1056 if (q->last == NULL((void*)0)) {
1057 return NULL((void*)0);
1058 }
1059 // q->first should only be NULL if q->last is.
1060 eval_context_t *res = q->first;
1061
1062 if (q->first == q->last) { // One thing in queue
1063 q->first = NULL((void*)0);
1064 q->last = NULL((void*)0);
1065 } else {
1066 q->first = q->first->next;
1067 q->first->prev = NULL((void*)0);
1068 }
1069 res->prev = NULL((void*)0);
1070 res->next = NULL((void*)0);
1071 return res;
1072}
1073
1074static void wake_up_ctxs_nm(void) {
1075 lbm_uint t_now;
1076
1077 if (timestamp_us_callback) {
1078 t_now = timestamp_us_callback();
1079 } else {
1080 t_now = 0;
1081 }
1082
1083 eval_context_queue_t *q = &blocked;
1084 eval_context_t *curr = q->first;
1085
1086 while (curr != NULL((void*)0)) {
1087 lbm_uint t_diff;
1088 eval_context_t *next = curr->next;
1089 if (curr->state != LBM_THREAD_STATE_BLOCKED(uint32_t)1) {
1090 if ( curr->timestamp > t_now) {
1091 /* There was an overflow on the counter */
1092#ifndef LBM64
1093 t_diff = (0xFFFFFFFF - curr->timestamp) + t_now;
1094#else
1095 t_diff = (0xFFFFFFFFFFFFFFFF - curr->timestamp) + t_now;
1096#endif
1097 } else {
1098 t_diff = t_now - curr->timestamp;
1099 }
1100
1101 if (t_diff >= curr->sleep_us) {
1102 eval_context_t *wake_ctx = curr;
1103 if (curr == q->last) {
1104 if (curr->prev) {
1105 q->last = curr->prev;
1106 q->last->next = NULL((void*)0);
1107 } else {
1108 q->first = NULL((void*)0);
1109 q->last = NULL((void*)0);
1110 }
1111 } else if (curr->prev == NULL((void*)0)) {
1112 q->first = curr->next;
1113 q->first->prev = NULL((void*)0);
1114 } else {
1115 curr->prev->next = curr->next;
1116 if (curr->next) {
1117 curr->next->prev = curr->prev;
1118 }
1119 }
1120 wake_ctx->next = NULL((void*)0);
1121 wake_ctx->prev = NULL((void*)0);
1122 if (curr->state == LBM_THREAD_STATE_TIMEOUT(uint32_t)2) {
1123 mailbox_add_mail(wake_ctx, ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u));
1124 wake_ctx->r = ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u);
1125 }
1126 wake_ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1127 enqueue_ctx_nm(&queue, wake_ctx);
1128 }
1129 }
1130 curr = next;
1131 }
1132}
1133
1134static void yield_ctx(lbm_uint sleep_us) {
1135 if (timestamp_us_callback) {
1136 ctx_running->timestamp = timestamp_us_callback();
1137 ctx_running->sleep_us = sleep_us;
1138 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1139 } else {
1140 ctx_running->timestamp = 0;
1141 ctx_running->sleep_us = 0;
1142 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1143 }
1144 ctx_running->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1145 ctx_running->app_cont = true1;
1146 enqueue_ctx(&blocked,ctx_running);
1147 ctx_running = NULL((void*)0);
1148}
1149
1150static lbm_cid lbm_create_ctx_parent(lbm_value program, lbm_value env, lbm_uint stack_size, lbm_cid parent, uint32_t context_flags, char *name) {
1151
1152 if (!lbm_is_cons(program)) return -1;
1153
1154 eval_context_t *ctx = NULL((void*)0);
1155
1156 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1157 if (ctx == NULL((void*)0)) {
1158 lbm_uint roots[2] = {program, env};
1159 lbm_gc_mark_roots(roots, 2);
1160 gc();
1161 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1162 }
1163 if (ctx == NULL((void*)0)) return -1;
1164
1165 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1166 lbm_uint roots[2] = {program, env};
1167 lbm_gc_mark_roots(roots, 2);
1168 gc();
1169 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1170 lbm_memory_free((lbm_uint*)ctx);
1171 return -1;
1172 }
1173 }
1174
1175 lbm_value *mailbox = NULL((void*)0);
1176 mailbox = (lbm_value*)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1177 if (mailbox == NULL((void*)0)) {
1178 lbm_value roots[2] = {program, env};
1179 lbm_gc_mark_roots(roots,2);
1180 gc();
1181 mailbox = (lbm_value *)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1182 }
1183 if (mailbox == NULL((void*)0)) {
1184 lbm_stack_free(&ctx->K);
1185 lbm_memory_free((lbm_uint*)ctx);
1186 return -1;
1187 }
1188
1189 // TODO: Limit names to 19 chars + 1 char for 0? (or something similar).
1190 if (name) {
1191 lbm_uint name_len = strlen(name) + 1;
1192 ctx->name = lbm_malloc(strlen(name) + 1);
1193 if (ctx->name == NULL((void*)0)) {
1194 lbm_value roots[2] = {program, env};
1195 lbm_gc_mark_roots(roots, 2);
1196 gc();
1197 ctx->name = lbm_malloc(strlen(name) + 1);
1198 }
1199 if (ctx->name == NULL((void*)0)) {
1200 lbm_stack_free(&ctx->K);
1201 lbm_memory_free((lbm_uint*)mailbox);
1202 lbm_memory_free((lbm_uint*)ctx);
1203 return -1;
1204 }
1205 memcpy(ctx->name, name, name_len+1);
1206 } else {
1207 ctx->name = NULL((void*)0);
1208 }
1209
1210 lbm_int cid = lbm_memory_address_to_ix((lbm_uint*)ctx);
1211
1212 ctx->program = lbm_cdr(program);
1213 ctx->curr_exp = lbm_car(program);
1214 ctx->curr_env = env;
1215 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1216 ctx->error_reason = NULL((void*)0);
1217 ctx->mailbox = mailbox;
1218 ctx->mailbox_size = EVAL_CPS_DEFAULT_MAILBOX_SIZE10;
1219 ctx->flags = context_flags;
1220 ctx->num_mail = 0;
1221 ctx->app_cont = false0;
1222 ctx->timestamp = 0;
1223 ctx->sleep_us = 0;
1224 ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1225 ctx->prev = NULL((void*)0);
1226 ctx->next = NULL((void*)0);
1227
1228 ctx->row0 = -1;
1229 ctx->row1 = -1;
1230
1231 ctx->id = cid;
1232 ctx->parent = parent;
1233
1234 if (!lbm_push(&ctx->K, DONE(((0) << 2) | 0xF8000001u))) {
1235 lbm_memory_free((lbm_uint*)ctx->mailbox);
1236 lbm_stack_free(&ctx->K);
1237 lbm_memory_free((lbm_uint*)ctx);
1238 return -1;
1239 }
1240
1241 enqueue_ctx(&queue,ctx);
1242
1243 return ctx->id;
1244}
1245
1246lbm_cid lbm_create_ctx(lbm_value program, lbm_value env, lbm_uint stack_size, char *name) {
1247 // Creates a parentless context.
1248 return lbm_create_ctx_parent(program,
1249 env,
1250 stack_size,
1251 -1,
1252 EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00,
1253 name);
1254}
1255
1256bool_Bool lbm_mailbox_change_size(eval_context_t *ctx, lbm_uint new_size) {
1257
1258 lbm_value *mailbox = NULL((void*)0);
1259 mailbox = (lbm_value*)lbm_memory_allocate(new_size);
1260 if (mailbox == NULL((void*)0)) {
1261 gc();
1262 mailbox = (lbm_value *)lbm_memory_allocate(new_size);
1263 }
1264 if (mailbox == NULL((void*)0)) {
1265 return false0;
1266 }
1267
1268 for (lbm_uint i = 0; i < ctx->num_mail; i ++ ) {
1269 mailbox[i] = ctx->mailbox[i];
1270 }
1271 lbm_memory_free(ctx->mailbox);
1272 ctx->mailbox = mailbox;
1273 ctx->mailbox_size = (uint32_t)new_size;
1274 return true1;
1275}
1276
1277static void mailbox_remove_mail(eval_context_t *ctx, lbm_uint ix) {
1278
1279 for (lbm_uint i = ix; i < ctx->num_mail-1; i ++) {
1280 ctx->mailbox[i] = ctx->mailbox[i+1];
1281 }
1282 ctx->num_mail --;
1283}
1284
1285static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail) {
1286
1287 if (ctx->num_mail >= ctx->mailbox_size) {
1288 mailbox_remove_mail(ctx, 0);
1289 }
1290
1291 ctx->mailbox[ctx->num_mail] = mail;
1292 ctx->num_mail ++;
1293 return true1;
1294}
1295
1296/* Advance execution to the next expression in the program */
1297static void advance_ctx(eval_context_t *ctx) {
1298 if (lbm_is_cons(ctx->program)) {
1299 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);;
1300 get_car_and_cdr(ctx->program, &ctx->curr_exp, &ctx->program);
1301 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1302 } else {
1303 if (ctx_running == ctx) { // This should always be the case because of odd historical reasons.
1304 ok_ctx();
1305 }
1306 }
1307}
1308
1309bool_Bool lbm_unblock_ctx(lbm_cid cid, lbm_flat_value_t *fv) {
1310 return event_internal(LBM_EVENT_UNBLOCK_CTX, (lbm_uint)cid, (lbm_uint)fv->buf, fv->buf_size);
1311}
1312
1313bool_Bool lbm_unblock_ctx_r(lbm_cid cid) {
1314 mutex_lock(&blocking_extension_mutex);
1315 bool_Bool r = false0;
1316 eval_context_t *found = NULL((void*)0);
1317 mutex_lock(&qmutex);
1318 found = lookup_ctx_nm(&blocked, cid);
1319 if (found) {
1320 drop_ctx_nm(&blocked,found);
1321 enqueue_ctx_nm(&queue,found);
1322 r = true1;
1323 }
1324 mutex_unlock(&qmutex);
1325 mutex_unlock(&blocking_extension_mutex);
1326 return r;
1327}
1328
1329// unblock unboxed is also safe for rmbr:ed things.
1330bool_Bool lbm_unblock_ctx_unboxed(lbm_cid cid, lbm_value unboxed) {
1331 mutex_lock(&blocking_extension_mutex);
1332 bool_Bool r = false0;
1333 eval_context_t *found = NULL((void*)0);
1334 mutex_lock(&qmutex);
1335 found = lookup_ctx_nm(&blocked, cid);
1336 if (found) {
1337 drop_ctx_nm(&blocked,found);
1338 found->r = unboxed;
1339 if (lbm_is_error(unboxed)) {
1340 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
1341 found->app_cont = true1;
1342 }
1343 enqueue_ctx_nm(&queue,found);
1344 r = true1;
1345 }
1346 mutex_unlock(&qmutex);
1347 mutex_unlock(&blocking_extension_mutex);
1348 return r;
1349}
1350
1351static bool_Bool lbm_block_ctx_base(bool_Bool timeout, float t_s) {
1352 mutex_lock(&blocking_extension_mutex);
1353 blocking_extension = true1;
1354 if (timeout) {
1355 blocking_extension_timeout_us = S_TO_US(t_s)(lbm_uint)((t_s) * 1000000);
1356 blocking_extension_timeout = true1;
1357 } else {
1358 blocking_extension_timeout = false0;
1359 }
1360 return true1;
1361}
1362
1363void lbm_block_ctx_from_extension_timeout(float s) {
1364 lbm_block_ctx_base(true1, s);
1365}
1366
1367void lbm_block_ctx_from_extension(void) {
1368 lbm_block_ctx_base(false0, 0);
1369}
1370
1371// todo: May need to pop rmbrs from stack, if present.
1372// Suspect that the letting the discard cont run is really not a problem.
1373// Either way will be quite confusing what happens to allocated things when undoing block.
1374void lbm_undo_block_ctx_from_extension(void) {
1375 blocking_extension = false0;
1376 blocking_extension_timeout_us = 0;
1377 blocking_extension_timeout = false0;
1378 mutex_unlock(&blocking_extension_mutex);
1379}
1380
1381lbm_value lbm_find_receiver_and_send(lbm_cid cid, lbm_value msg) {
1382 mutex_lock(&qmutex);
1383 eval_context_t *found = NULL((void*)0);
1384 bool_Bool found_blocked = false0;
1385
1386 found = lookup_ctx_nm(&blocked, cid);
1387 if (found) found_blocked = true1;
1388
1389 if (found == NULL((void*)0)) {
1390 found = lookup_ctx_nm(&queue, cid);
1391 }
1392
1393 if (found) {
1394 if (!mailbox_add_mail(found, msg)) {
1395 mutex_unlock(&qmutex);
1396 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1397 }
1398
1399 if (found_blocked){
1400 drop_ctx_nm(&blocked,found);
1401 enqueue_ctx_nm(&queue,found);
1402 }
1403 mutex_unlock(&qmutex);
1404 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1405 }
1406
1407 /* check the current context */
1408 if (ctx_running && ctx_running->id == cid) {
1409 if (!mailbox_add_mail(ctx_running, msg)) {
1410 mutex_unlock(&qmutex);
1411 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1412 }
1413 mutex_unlock(&qmutex);
1414 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1415 }
1416 mutex_unlock(&qmutex);
1417 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1418}
1419
1420/* Pattern matching is currently implemented as a recursive
1421 function and make use of stack relative to the size of
1422 expressions that are being matched. */
1423static bool_Bool match(lbm_value p, lbm_value e, lbm_value *env, bool_Bool *gc) {
1424
1425 lbm_value binding;
1426
1427 if (lbm_is_match_binder(p)) {
1428 lbm_value var = get_cadr(p);
1429 lbm_value bindertype = get_car(p);
1430
1431 if (!lbm_is_symbol(var)) return false0;
1432
1433 switch (bindertype) {
1434 case ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u):
1435 if ( var == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) {
1436 return true1;
1437 }
1438 break;
1439 default: /* this should be an error case */
1440 return false0;
1441 }
1442 binding = lbm_cons(var, e);
1443 if ( lbm_type_of(binding) == LBM_TYPE_SYMBOL0x00000000u ) {
1444 *gc = true1;
1445 return false0;
1446 }
1447 *env = lbm_cons(binding, *env);
1448 if ( lbm_type_of(*env) == LBM_TYPE_SYMBOL0x00000000u ) {
1449 *gc = true1;
1450 return false0;
1451 }
1452 return true1;
1453 }
1454
1455 if (lbm_is_symbol(p)) {
1456 if (p == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return true1;
1457 return (p == e);
1458 }
1459 if (lbm_is_cons(p) &&
1460 lbm_is_cons(e) ) {
1461
1462 lbm_value headp, tailp;
1463 lbm_value heade, taile;
1464 get_car_and_cdr(p, &headp, &tailp);
1465 get_car_and_cdr(e, &heade, &taile); // Static analysis warns, but execution does not
1466 // past this point unless head and tail get initialized.
1467 if (!match(headp, heade, env, gc)) {
1468 return false0;
1469 }
1470 return match (tailp, taile, env, gc);
1471 }
1472 return struct_eq(p, e);
1473}
1474
1475// Find match is not very picky about syntax.
1476// A completely malformed recv form is most likely to
1477// just return no_match.
1478static int find_match(lbm_value plist, lbm_value *earr, lbm_uint num, lbm_value *e, lbm_value *env) {
1479
1480 // A pattern list is a list of pattern, expression lists.
1481 // ( (p1 e1) (p2 e2) ... (pn en))
1482 lbm_value curr_p = plist;
1483 int n = 0;
1484 bool_Bool gc = false0;
1485 for (int i = 0; i < (int)num; i ++ ) {
1486 lbm_value curr_e = earr[i];
1487 while (!lbm_is_symbol_nil(curr_p)) {
1488 lbm_value me = get_car(curr_p);
1489 if (match(get_car(me), curr_e, env, &gc)) {
1490 if (gc) return FM_NEED_GC-1;
1491 *e = get_cadr(me);
1492
1493 if (!lbm_is_symbol_nil(get_cadr(get_cdr(me)))) {
1494 return FM_PATTERN_ERROR-3;
1495 }
1496 return n;
1497 }
1498 curr_p = get_cdr(curr_p);
1499 }
1500 curr_p = plist; /* search all patterns against next exp */
1501 n ++;
1502 }
1503
1504 return FM_NO_MATCH-2;
1505}
1506
1507/****************************************************/
1508/* Garbage collection */
1509
1510static void mark_context(eval_context_t *ctx, void *arg1, void *arg2) {
1511 (void) arg1;
1512 (void) arg2;
1513 lbm_value roots[3] = {ctx->curr_exp, ctx->program, ctx->r };
1514 lbm_gc_mark_env(ctx->curr_env);
1515 lbm_gc_mark_roots(roots, 3);
1516 lbm_gc_mark_roots(ctx->mailbox, ctx->num_mail);
1517 lbm_gc_mark_aux(ctx->K.data, ctx->K.sp);
1518}
1519
1520static int gc(void) {
1521 if (ctx_running) {
1522 ctx_running->state = ctx_running->state | LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1523 }
1524
1525 gc_requested = false0;
1526 lbm_gc_state_inc();
1527
1528 // The freelist should generally be NIL when GC runs.
1529 lbm_nil_freelist();
1530 lbm_value *env = lbm_get_global_env();
1531 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
1532 lbm_gc_mark_env(env[i]);
1533 }
1534
1535 mutex_lock(&qmutex); // Lock the queues.
1536 // Any concurrent messing with the queues
1537 // while doing GC cannot possibly be good.
1538 queue_iterator_nm(&queue, mark_context, NULL((void*)0), NULL((void*)0));
1539 queue_iterator_nm(&blocked, mark_context, NULL((void*)0), NULL((void*)0));
1540
1541 if (ctx_running) {
1542 mark_context(ctx_running, NULL((void*)0), NULL((void*)0));
1543 }
1544 mutex_unlock(&qmutex);
1545
1546#ifdef VISUALIZE_HEAP
1547 heap_vis_gen_image();
1548#endif
1549
1550 int r = lbm_gc_sweep_phase();
1551 lbm_heap_new_freelist_length();
1552
1553 if (ctx_running) {
1554 ctx_running->state = ctx_running->state & ~LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1555 }
1556 return r;
1557}
1558
1559int lbm_perform_gc(void) {
1560 return gc();
1561}
1562
1563/****************************************************/
1564/* Evaluation functions */
1565
1566
1567static void eval_symbol(eval_context_t *ctx) {
1568 lbm_uint s = lbm_dec_sym(ctx->curr_exp);
1569 if (s >= RUNTIME_SYMBOLS_START0x40000) {
1570 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1571 if (lbm_env_lookup_b(&res, ctx->curr_exp, ctx->curr_env) ||
1572 lbm_global_env_lookup(&res, ctx->curr_exp)) {
1573 ctx->r = res;
1574 ctx->app_cont = true1;
1575 return;
1576 }
1577 // Dynamic load attempt
1578 // Only symbols of kind RUNTIME can be dynamically loaded.
1579 const char *sym_str = lbm_get_name_by_symbol(s);
1580 const char *code_str = NULL((void*)0);
1581 if (!dynamic_load_callback(sym_str, &code_str)) {
1582 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), ctx->curr_exp);
1583 }
1584 lbm_value *sptr = stack_reserve(ctx, 3);
1585 sptr[0] = ctx->curr_exp;
1586 sptr[1] = ctx->curr_env;
1587 sptr[2] = RESUME(((12) << 2) | 0xF8000001u);
1588
1589 lbm_value chan;
1590 if (!create_string_channel((char *)code_str, &chan)) {
1591 gc();
1592 if (!create_string_channel((char *)code_str, &chan)) {
1593 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1594 }
1595 }
1596
1597 lbm_value loader;
1598 WITH_GC_RMBR_1(loader, lbm_heap_allocate_list_init(2,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1599 ENC_SYM_READ,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1600 chan), chan)(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} };
1601 lbm_value evaluator;
1602 WITH_GC_RMBR_1(evaluator, lbm_heap_allocate_list_init(2,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1603 ENC_SYM_EVAL,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1604 loader), loader)(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } };
1605 ctx->curr_exp = evaluator;
1606 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // dynamics should be evaluable in empty local env
1607 } else {
1608 //special symbols and extensions can be handled the same way.
1609 ctx->r = ctx->curr_exp;
1610 ctx->app_cont = true1;
1611 }
1612}
1613
1614static void eval_quote(eval_context_t *ctx) {
1615 ctx->r = get_cadr(ctx->curr_exp);
1616 ctx->app_cont = true1;
1617}
1618
1619static void eval_selfevaluating(eval_context_t *ctx) {
1620 ctx->r = ctx->curr_exp;
1621 ctx->app_cont = true1;
1622}
1623
1624static void eval_progn(eval_context_t *ctx) {
1625 lbm_value exps = get_cdr(ctx->curr_exp);
1626
1627 if (lbm_is_cons(exps)) {
1628 lbm_uint *sptr = stack_reserve(ctx, 4);
1629 sptr[0] = ctx->curr_env; // env to restore between expressions in progn
1630 sptr[1] = lbm_enc_u(0); // Has env been copied (needed for progn local bindings)
1631 sptr[3] = PROGN_REST(((4) << 2) | 0xF8000001u);
1632 get_car_and_cdr(exps, &ctx->curr_exp, &sptr[2]);
1633 if (lbm_is_symbol(sptr[2])) /* The only symbol it can be is nil */
1634 lbm_stack_drop(&ctx->K, 4);
1635 } else if (lbm_is_symbol_nil(exps)) {
1636 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1637 ctx->app_cont = true1;
1638 } else {
1639 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1640 }
1641}
1642
1643static void eval_atomic(eval_context_t *ctx) {
1644 if (is_atomic) {
1645 lbm_set_error_reason("Atomic blocks cannot be nested!");
1646 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1647 }
1648 stack_reserve(ctx, 1)[0] = EXIT_ATOMIC(((14) << 2) | 0xF8000001u);
1649 is_atomic ++;
1650 eval_progn(ctx);
1651}
1652
1653/* (call-cc (lambda (k) .... )) */
1654static void eval_callcc(eval_context_t *ctx) {
1655 lbm_value cont_array;
1656 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1657 gc();
1658 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1659 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1660 return; // dead return but static analysis doesn't know :)
1661 }
1662 }
1663 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(cont_array);
1664 memcpy(arr->data, ctx->K.data, ctx->K.sp * sizeof(lbm_uint));
1665
1666 lbm_value acont = cons_with_gc(ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u), cont_array, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1667 lbm_value arg_list = cons_with_gc(acont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1668 // Go directly into application evaluation without passing go
1669 lbm_uint *sptr = stack_reserve(ctx, 3);
1670 sptr[0] = ctx->curr_env;
1671 sptr[1] = arg_list;
1672 sptr[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
1673 ctx->curr_exp = get_cadr(ctx->curr_exp);
1674}
1675
1676// (define sym exp)
1677#define KEY1 1
1678#define VAL2 2
1679static void eval_define(eval_context_t *ctx) {
1680 lbm_value parts[3];
1681 lbm_value rest = extract_n(ctx->curr_exp, parts, 3);
1682 lbm_uint *sptr = stack_reserve(ctx, 2);
1683 if (lbm_is_symbol(parts[KEY1]) && lbm_is_symbol_nil(rest)) {
1684 lbm_uint sym_val = lbm_dec_sym(parts[KEY1]);
1685 sptr[0] = parts[KEY1];
1686 if (sym_val >= RUNTIME_SYMBOLS_START0x40000) {
1687 sptr[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
1688 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02) {
1689 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
1690 }
1691 ctx->curr_exp = parts[VAL2];
1692 return;
1693 }
1694 }
1695 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
1696}
1697
1698
1699/* Eval lambda is cheating, a lot! It does this
1700 for performance reasons. The cheats are that
1701 1. When closure is created, a reference to the local env
1702 in which the lambda was evaluated is added to the closure.
1703 Ideally it should have created a list of free variables in the function
1704 and then looked up the values of these creating a new environment.
1705 2. The global env is considered global constant. As there is no copying
1706 of environment bindings into the closure, undefine may break closures.
1707
1708 Correct closure creation is a lot more expensive than what happens here.
1709 However, one can try to write programs in such a way that closures are created
1710 seldomly. If one does that the space-usage benefits of "correct" closures
1711 may outweigh the performance gain of "incorrect" ones.
1712
1713 some obscure programs such as test_setq_local_closure.lisp does not
1714 work properly due to this cheating.
1715 */
1716// (lambda param-list body-exp) -> (closure param-list body-exp env)
1717static void eval_lambda(eval_context_t *ctx) {
1718 lbm_value vals[3];
1719 extract_n(ctx->curr_exp, vals, 3);
1720 ctx->r = allocate_closure(vals[1],vals[2], ctx->curr_env);
1721#ifdef CLEAN_UP_CLOSURES
1722 lbm_uint sym_id = 0;
1723 if (clean_cl_env_symbol) {
1724 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1725 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1726 ctx->curr_exp = app;
1727 } else if (lbm_get_symbol_by_name("clean-cl-env", &sym_id)) {
1728 clean_cl_env_symbol = lbm_enc_sym(sym_id);
1729 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1730 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1731 ctx->curr_exp = app;
1732 } else {
1733 ctx->app_cont = true1;
1734 }
1735#else
1736 ctx->app_cont = true1;
1737#endif
1738}
1739
1740// (if cond-expr then-expr else-expr)
1741static void eval_if(eval_context_t *ctx) {
1742 lbm_value cdr = get_cdr(ctx->curr_exp);
1743 lbm_value *sptr = stack_reserve(ctx, 3);
1744 sptr[0] = get_cdr(cdr);
1745 sptr[1] = ctx->curr_env;
1746 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1747 ctx->curr_exp = get_car(cdr);
1748}
1749
1750// (cond (cond-expr-1 expr-1)
1751// ...
1752// (cond-expr-N expr-N))
1753static void eval_cond(eval_context_t *ctx) {
1754 lbm_value cond1[2];
1755 lbm_value rest_conds = extract_n(ctx->curr_exp, cond1, 2);
1756
1757 // end recursion at (cond )
1758 if (lbm_is_symbol_nil(cond1[1])) {
1759 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1760 ctx->app_cont = true1;
1761 } else {
1762 // Cond is one of the few places where a bit of syntax checking takes place at runtime..
1763 // Maybe dont bother?
1764 lbm_uint len = lbm_list_length(cond1[1]);
1765 if (len != 2) {
1766 lbm_set_error_reason("Incorrect syntax in cond");
1767 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1768 }
1769 lbm_value cond_expr[2];
1770 extract_n(cond1[1], cond_expr, 2);
1771 lbm_value rest;
1772 WITH_GC(rest, lbm_heap_allocate_list_init(2,(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1773 cond_expr[1], // Then branch(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1774 cons_with_gc(ENC_SYM_COND, rest_conds , ENC_SYM_NIL)))(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
1775 lbm_value *sptr = stack_reserve(ctx, 3);
1776 sptr[0] = rest;
1777 sptr[1] = ctx->curr_env;
1778 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1779 ctx->curr_exp = cond_expr[0]; //condition;
1780 }
1781}
1782
1783static void eval_app_cont(eval_context_t *ctx) {
1784 lbm_stack_drop(&ctx->K, 1);
1785 ctx->app_cont = true1;
1786}
1787
1788// Create a named location in an environment to later receive a value.
1789static binding_location_status create_binding_location_internal(lbm_value key, lbm_value *env) {
1790
1791 if (lbm_is_symbol(key) &&
1792 (key == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u) ||
1793 key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)))
1794 return BL_OK;
1795
1796 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) { // default case
1797 lbm_value binding;
1798 lbm_value new_env_tmp;
1799 binding = lbm_cons(key, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1800 new_env_tmp = lbm_cons(binding, *env);
1801 if (lbm_is_symbol(binding) || lbm_is_symbol(new_env_tmp)) {
1802 return BL_NO_MEMORY;
1803 }
1804 *env = new_env_tmp;
1805 } else if (lbm_is_cons(key)) { // deconstruct case
1806 int r = create_binding_location_internal(get_car(key), env);
1807 if (r == BL_OK) {
1808 r = create_binding_location_internal(get_cdr(key), env);
1809 }
1810 return r;
1811 }
1812 return BL_OK;
1813}
1814
1815static void create_binding_location(lbm_value key, lbm_value *env) {
1816
1817 lbm_value env_tmp = *env;
1818 binding_location_status r = create_binding_location_internal(key, &env_tmp);
1819 if (r != BL_OK) {
1820 if (r == BL_NO_MEMORY) {
1821 env_tmp = *env;
1822 lbm_gc_mark_phase(env_tmp);
1823 gc();
1824 r = create_binding_location_internal(key, &env_tmp);
1825 }
1826 switch(r) {
1827 case BL_OK:
1828 break;
1829 case BL_NO_MEMORY:
1830 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1831 break;
1832 case BL_INCORRECT_KEY:
1833 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
1834 break;
1835 }
1836 }
1837 *env = env_tmp;
1838}
1839
1840static void let_bind_values_eval(lbm_value binds, lbm_value exp, lbm_value env, eval_context_t *ctx) {
1841
1842 if (!lbm_is_cons(binds)) {
1843 // binds better be nil or there is a programmer error.
1844 ctx->curr_exp = exp;
1845 return;
1846 }
1847
1848 // Preallocate binding locations.
1849 lbm_value curr = binds;
1850 while (lbm_is_cons(curr)) {
1851 lbm_value new_env_tmp = env;
1852 lbm_value car_curr, cdr_curr;
1853 get_car_and_cdr(curr, &car_curr, &cdr_curr);
1854 lbm_value key = get_car(car_curr);
1855 create_binding_location(key, &new_env_tmp);
1856 env = new_env_tmp;
1857 curr = cdr_curr;
1858 }
1859
1860 lbm_value car_binds;
1861 lbm_value cdr_binds;
1862 get_car_and_cdr(binds, &car_binds, &cdr_binds);
1863 lbm_value key_val[2];
1864 extract_n(car_binds, key_val, 2);
1865
1866 lbm_uint *sptr = stack_reserve(ctx, 5);
1867 sptr[0] = exp;
1868 sptr[1] = cdr_binds;
1869 sptr[2] = env;
1870 sptr[3] = key_val[0];
1871 sptr[4] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
1872 ctx->curr_exp = key_val[1];
1873 ctx->curr_env = env;
1874}
1875
1876// (var x (...)) - local binding inside of an progn
1877// var has to take, place root-level nesting within progn.
1878// (progn ... (var a 10) ...) OK!
1879// (progn ... (something (var a 10)) ... ) NOT OK!
1880/* progn stack
1881 sp-4 : env
1882 sp-3 : 0
1883 sp-2 : rest
1884 sp-1 : PROGN_REST
1885*/
1886static void eval_var(eval_context_t *ctx) {
1887
1888 if (ctx->K.sp >= 4) { // Possibly in progn
1889 lbm_value sv = ctx->K.data[ctx->K.sp - 1];
1890 if (IS_CONTINUATION(sv)(((sv) & 0xF8000001u) == 0xF8000001u) && (sv == PROGN_REST(((4) << 2) | 0xF8000001u))) {
1891 lbm_uint sp = ctx->K.sp;
1892 uint32_t is_copied = lbm_dec_as_u32(ctx->K.data[sp-3]);
1893 if (is_copied == 0) {
1894 lbm_value env;
1895 WITH_GC(env, lbm_env_copy_spine(ctx->K.data[sp-4]))(env) = (lbm_env_copy_spine(ctx->K.data[sp-4])); if (lbm_is_symbol_merror
((env))) { gc(); (env) = (lbm_env_copy_spine(ctx->K.data[sp
-4])); if (lbm_is_symbol_merror((env))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1896 ctx->K.data[sp-3] = lbm_enc_u(1);
1897 ctx->K.data[sp-4] = env;
1898 }
1899 lbm_value new_env = ctx->K.data[sp-4];
1900 lbm_value args = get_cdr(ctx->curr_exp);
1901 lbm_value key = get_car(args);
1902 create_binding_location(key, &new_env);
1903 ctx->K.data[sp-4] = new_env;
1904
1905 lbm_value v_exp = get_cadr(args);
1906 lbm_value *sptr = stack_reserve(ctx, 3);
1907 sptr[0] = new_env;
1908 sptr[1] = key;
1909 sptr[2] = PROGN_VAR(((29) << 2) | 0xF8000001u);
1910 // Activating the new environment before the evaluation of the value to be bound,
1911 // means that other variables with same name will be shadowed already in the value
1912 // body.
1913 // The way closures work, the var-variable needs to be in scope during val evaluation
1914 // for a recursive closure to be possible.
1915 ctx->curr_env = new_env;
1916 ctx->curr_exp = v_exp;
1917 return;
1918 }
1919 }
1920 lbm_set_error_reason((char*)lbm_error_str_var_outside_progn);
1921 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1922}
1923
1924// (setq x (...)) - same as (set 'x (...)) or (setvar 'x (...))
1925static void eval_setq(eval_context_t *ctx) {
1926 lbm_value parts[3];
1927 extract_n(ctx->curr_exp, parts, 3);
1928 lbm_value *sptr = stack_reserve(ctx, 3);
1929 sptr[0] = ctx->curr_env;
1930 sptr[1] = parts[1];
1931 sptr[2] = SETQ(((30) << 2) | 0xF8000001u);
1932 ctx->curr_exp = parts[2];
1933}
1934
1935static void eval_move_to_flash(eval_context_t *ctx) {
1936 lbm_value args = get_cdr(ctx->curr_exp);
1937 lbm_value *sptr = stack_reserve(ctx,2);
1938 sptr[0] = args;
1939 sptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
1940 ctx->app_cont = true1;
1941}
1942
1943// (loop list-of-local-bindings
1944// condition-exp
1945// body-exp)
1946static void eval_loop(eval_context_t *ctx) {
1947 lbm_value env = ctx->curr_env;
1948 lbm_value parts[3];
1949 extract_n(get_cdr(ctx->curr_exp), parts, 3);
1950 lbm_value *sptr = stack_reserve(ctx, 3);
1951 sptr[0] = parts[LOOP_BODY2];
1952 sptr[1] = parts[LOOP_COND1];
1953 sptr[2] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
1954 let_bind_values_eval(parts[LOOP_BINDS0], parts[LOOP_COND1], env, ctx);
1955}
1956
1957/* (trap expression)
1958 *
1959 * suggested use:
1960 * (match (trap expression)
1961 * ((exit-error (? err)) (error-handler err))
1962 * ((exit-ok (? v)) (value-handler v)))
1963 */
1964static void eval_trap(eval_context_t *ctx) {
1965
1966 lbm_value expr = get_cadr(ctx->curr_exp);
1967 lbm_value retval;
1968 WITH_GC(retval, lbm_heap_allocate_list(2))(retval) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((retval))) { gc(); (retval) = (lbm_heap_allocate_list(2)); if
(lbm_is_symbol_merror((retval))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1969 lbm_set_car(retval, ENC_SYM_EXIT_OK(((0x3000B) << 4) | 0x00000000u)); // Assume things will go well.
1970 lbm_uint *sptr = stack_reserve(ctx,3);
1971 sptr[0] = retval;
1972 sptr[1] = ctx->flags;
1973 sptr[2] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1974 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10;
1975 ctx->curr_exp = expr;
1976}
1977
1978// (let list-of-binding s
1979// body-exp)
1980static void eval_let(eval_context_t *ctx) {
1981 lbm_value env = ctx->curr_env;
1982 lbm_value parts[3];
1983 extract_n(ctx->curr_exp, parts, 3);
1984 let_bind_values_eval(parts[1], parts[2], env, ctx);
1985}
1986
1987// (and exp0 ... expN)
1988static void eval_and(eval_context_t *ctx) {
1989 lbm_value rest = get_cdr(ctx->curr_exp);
1990 if (lbm_is_symbol_nil(rest)) {
1991 ctx->app_cont = true1;
1992 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1993 } else {
1994 lbm_value *sptr = stack_reserve(ctx, 3);
1995 sptr[0] = ctx->curr_env;
1996 sptr[1] = get_cdr(rest);
1997 sptr[2] = AND(((6) << 2) | 0xF8000001u);
1998 ctx->curr_exp = get_car(rest);
1999 }
2000}
2001
2002// (or exp0 ... expN)
2003static void eval_or(eval_context_t *ctx) {
2004 lbm_value rest = get_cdr(ctx->curr_exp);
2005 if (lbm_is_symbol_nil(rest)) {
2006 ctx->app_cont = true1;
2007 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2008 } else {
2009 lbm_value *sptr = stack_reserve(ctx, 3);
2010 sptr[0] = ctx->curr_env;
2011 sptr[1] = get_cdr(rest);
2012 sptr[2] = OR(((7) << 2) | 0xF8000001u);
2013 ctx->curr_exp = get_car(rest);
2014 }
2015}
2016
2017// Pattern matching
2018// format:
2019// (match e (pattern body)
2020// (pattern body)
2021// ... )
2022//
2023// There can be an optional pattern guard:
2024// (match e (pattern guard body)
2025// ... )
2026// a guard is a boolean expression.
2027// Guards make match, pattern matching more complicated
2028// than the recv pattern matching and requires staged execution
2029// via the continuation system rather than a while loop over a list.
2030static void eval_match(eval_context_t *ctx) {
2031
2032 lbm_value rest = get_cdr(ctx->curr_exp);
2033 if (lbm_type_of(rest) == LBM_TYPE_SYMBOL0x00000000u &&
2034 rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
2035 // Someone wrote the program (match)
2036 ctx->app_cont = true1;
2037 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2038 } else {
2039 lbm_value cdr_rest;
2040 get_car_and_cdr(rest, &ctx->curr_exp, &cdr_rest);
2041 lbm_value *sptr = stack_reserve(ctx, 3);
2042 sptr[0] = cdr_rest;
2043 sptr[1] = ctx->curr_env;
2044 sptr[2] = MATCH(((9) << 2) | 0xF8000001u);
2045 }
2046}
2047
2048static void receive_base(eval_context_t *ctx, lbm_value pats, float timeout_time, bool_Bool timeout) {
2049 if (ctx->num_mail == 0) {
2050 if (timeout) {
2051 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000), false0);
2052 } else {
2053 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1,0,false0);
2054 }
2055 } else {
2056 lbm_value *msgs = ctx->mailbox;
2057 lbm_uint num = ctx->num_mail;
2058
2059 if (lbm_is_symbol_nil(pats)) {
2060 /* A receive statement without any patterns */
2061 ctx->app_cont = true1;
2062 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2063 } else {
2064 /* The common case */
2065 lbm_value e;
2066 lbm_value new_env = ctx->curr_env;
2067 int n = find_match(pats, msgs, num, &e, &new_env);
2068 if (n == FM_NEED_GC-1) {
2069 gc();
2070 new_env = ctx->curr_env;
2071 n = find_match(pats, msgs, num, &e, &new_env);
2072 if (n == FM_NEED_GC-1) {
2073 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2074 }
2075 }
2076 if (n == FM_PATTERN_ERROR-3) {
2077 lbm_set_error_reason("Incorrect pattern format for recv");
2078 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),pats);
2079 } else if (n >= 0 ) { /* Match */
2080 mailbox_remove_mail(ctx, (lbm_uint)n);
2081 ctx->curr_env = new_env;
2082 ctx->curr_exp = e;
2083 } else { /* No match go back to sleep */
2084 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
2085 if (timeout) {
2086 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2,S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000),false0);
2087 } else {
2088 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,false0);
2089 }
2090 }
2091 }
2092 }
2093 return;
2094}
2095
2096static void eval_receive_timeout(eval_context_t *ctx) {
2097 if (is_atomic) {
2098 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2099 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2100 }
2101 lbm_value timeout_val = get_cadr(ctx->curr_exp);
2102 if (!lbm_is_number(timeout_val)) {
2103 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2104 }
2105 float timeout_time = lbm_dec_as_float(timeout_val);
2106 lbm_value pats = get_cdr(get_cdr(ctx->curr_exp));
2107 receive_base(ctx, pats, timeout_time, true1);
2108}
2109
2110// Receive
2111// (recv (pattern expr)
2112// (pattern expr))
2113static void eval_receive(eval_context_t *ctx) {
2114
2115 if (is_atomic) {
2116 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2117 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
2118 }
2119 lbm_value pats = get_cdr(ctx->curr_exp);
2120 receive_base(ctx, pats, 0, false0);
2121}
2122
2123/*********************************************************/
2124/* Continuation functions */
2125
2126/* cont_set_global_env
2127 sp-1 : Key-symbol
2128 */
2129static void cont_set_global_env(eval_context_t *ctx){
2130
2131 lbm_value key;
2132 lbm_value val = ctx->r;
2133
2134 lbm_pop(&ctx->K, &key);
2135 lbm_uint dec_key = lbm_dec_sym(key);
2136 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
2137 lbm_value *global_env = lbm_get_global_env();
2138 lbm_uint orig_env = global_env[ix_key];
2139 lbm_value new_env;
2140 // A key is a symbol and should not need to be remembered.
2141 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2142
2143 global_env[ix_key] = new_env;
2144 ctx->r = val;
2145
2146 ctx->app_cont = true1;
2147
2148 return;
2149}
2150
2151static void cont_resume(eval_context_t *ctx) {
2152 lbm_pop_2(&ctx->K, &ctx->curr_env, &ctx->curr_exp);
2153}
2154
2155static void cont_progn_rest(eval_context_t *ctx) {
2156 lbm_value *sptr = get_stack_ptr(ctx, 3);
2157
2158 lbm_value rest = sptr[2];
2159 lbm_value env = sptr[0];
2160
2161 lbm_value rest_car, rest_cdr;
2162 get_car_and_cdr(rest, &rest_car, &rest_cdr);
2163 ctx->curr_exp = rest_car;
2164 ctx->curr_env = env;
2165 if (lbm_is_symbol_nil(rest_cdr)) {
2166 // allow for tail recursion
2167 lbm_stack_drop(&ctx->K, 3);
2168 } else {
2169 sptr[2] = rest_cdr;
2170 stack_reserve(ctx, 1)[0] = PROGN_REST(((4) << 2) | 0xF8000001u);
2171 }
2172}
2173
2174static void cont_wait(eval_context_t *ctx) {
2175
2176 lbm_value cid_val;
2177 lbm_pop(&ctx->K, &cid_val);
2178 lbm_cid cid = (lbm_cid)lbm_dec_i(cid_val);
2179
2180 bool_Bool exists = false0;
2181
2182 lbm_blocked_iterator(context_exists, &cid, &exists);
2183 lbm_running_iterator(context_exists, &cid, &exists);
2184
2185 if (ctx_running->id == cid) {
2186 exists = true1;
2187 }
2188
2189 if (exists) {
2190 lbm_value *sptr = stack_reserve(ctx, 2);
2191 sptr[0] = lbm_enc_i(cid);
2192 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2193 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2194 ctx->app_cont = true1;
2195 yield_ctx(50000);
2196 } else {
2197 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2198 ctx->app_cont = true1;
2199 }
2200}
2201
2202static lbm_value perform_setvar(lbm_value key, lbm_value val, lbm_value env) {
2203
2204 lbm_uint s = lbm_dec_sym(key);
2205 if (s >= RUNTIME_SYMBOLS_START0x40000) {
2206 lbm_value new_env = lbm_env_modify_binding(env, key, val);
2207 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2208 lbm_uint ix_key = lbm_dec_sym(key) & GLOBAL_ENV_MASK0x1F;
2209 lbm_value *glob_env = lbm_get_global_env();
2210 new_env = lbm_env_modify_binding(glob_env[ix_key], key, val);
2211 glob_env[ix_key] = new_env;
2212 }
2213 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2214 lbm_set_error_reason((char*)lbm_error_str_variable_not_bound);
2215 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), key);
2216 }
2217 return val;
2218 }
2219 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2220 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // unreachable
2221}
2222
2223static void apply_setvar(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2224 if (nargs == 2 && lbm_is_symbol(args[0])) {
2225 lbm_value res;
2226 WITH_GC(res, perform_setvar(args[0], args[1], ctx->curr_env))(res) = (perform_setvar(args[0], args[1], ctx->curr_env));
if (lbm_is_symbol_merror((res))) { gc(); (res) = (perform_setvar
(args[0], args[1], ctx->curr_env)); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2227 ctx->r = args[1];
2228 lbm_stack_drop(&ctx->K, nargs+1);
2229 ctx->app_cont = true1;
2230 } else {
2231 if (nargs == 2) lbm_set_error_reason((char*)lbm_error_str_incorrect_arg);
2232 else lbm_set_error_reason((char*)lbm_error_str_num_args);
2233 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2234 }
2235}
2236
2237static void apply_read_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, bool_Bool program, bool_Bool incremental) {
2238 if (nargs == 1) {
2239 lbm_value chan = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2240 if (lbm_type_of_functional(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2241 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2242 gc();
2243 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2244 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2245 }
2246 }
2247 } else if (lbm_type_of(args[0]) == LBM_TYPE_CHANNEL0x90000000u) {
2248 chan = args[0];
2249 } else {
2250 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2251 }
2252 lbm_value *sptr = get_stack_ptr(ctx, 2);
2253
2254 // If we are inside a reader, its settings are stored.
2255 sptr[0] = lbm_enc_u(ctx->flags); // flags stored.
2256 sptr[1] = chan;
2257 lbm_value *rptr = stack_reserve(ctx,1);
2258 rptr[0] = READ_DONE(((20) << 2) | 0xF8000001u);
2259
2260 // Each reader starts in a fresh situation
2261 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
2262
2263 if (program) {
2264 if (incremental) {
2265 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2266 lbm_value *rptr1 = stack_reserve(ctx,3);
2267 rptr1[0] = chan;
2268 rptr1[1] = ctx->curr_env;
2269 rptr1[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
2270 } else {
2271 ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2272 lbm_value *rptr1 = stack_reserve(ctx,4);
2273 rptr1[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2274 rptr1[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2275 rptr1[2] = chan;
2276 rptr1[3] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
2277 }
2278 }
2279 rptr = stack_reserve(ctx,3); // reuse of variable rptr
2280 rptr[0] = chan;
2281 rptr[1] = lbm_enc_u(1);
2282 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
2283 ctx->app_cont = true1;
2284 } else {
2285 lbm_set_error_reason((char*)lbm_error_str_num_args);
2286 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2287 }
2288}
2289
2290static void apply_read_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2291 apply_read_base(args,nargs,ctx,true1,false0);
2292}
2293
2294static void apply_read_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2295 apply_read_base(args,nargs,ctx,true1,true1);
2296}
2297
2298static void apply_read(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2299 apply_read_base(args,nargs,ctx,false0,false0);
2300}
2301
2302static void apply_spawn_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, uint32_t context_flags) {
2303
2304 lbm_uint stack_size = EVAL_CPS_DEFAULT_STACK_SIZE256;
2305 lbm_uint closure_pos = 0;
2306 char *name = NULL((void*)0);
2307
2308 if (nargs >= 1 &&
2309 lbm_is_closure(args[0])) {
2310 closure_pos = 0;
2311 } else if (nargs >= 2 &&
2312 lbm_is_number(args[0]) &&
2313 lbm_is_closure(args[1])) {
2314 stack_size = lbm_dec_as_u32(args[0]);
2315 closure_pos = 1;
2316 } else if (nargs >= 2 &&
2317 lbm_is_array_r(args[0]) &&
2318 lbm_is_closure(args[1])) {
2319 name = lbm_dec_str(args[0]);
2320 closure_pos = 1;
2321 }else if (nargs >= 3 &&
2322 lbm_is_array_r(args[0]) &&
2323 lbm_is_number(args[1]) &&
2324 lbm_is_closure(args[2])) {
2325 stack_size = lbm_dec_as_u32(args[1]);
2326 closure_pos = 2;
2327 name = lbm_dec_str(args[0]);
2328 } else {
2329 if (context_flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01)
2330 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN_TRAP(((0x30005) << 4) | 0x00000000u));
2331 else
2332 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN(((0x30004) << 4) | 0x00000000u));
2333 }
2334
2335 lbm_value cl[3];
2336 extract_n(get_cdr(args[closure_pos]), cl, 3);
2337 lbm_value curr_param = cl[CLO_PARAMS0];
2338 lbm_value clo_env = cl[CLO_ENV2];
2339 lbm_uint i = closure_pos + 1;
2340 while (lbm_is_cons(curr_param) && i <= nargs) {
2341 lbm_value entry = cons_with_gc(get_car(curr_param), args[i], clo_env);
2342 lbm_value aug_env = cons_with_gc(entry, clo_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2343 clo_env = aug_env;
2344 curr_param = get_cdr(curr_param);
2345 i ++;
2346 }
2347
2348 lbm_stack_drop(&ctx->K, nargs+1);
2349
2350 lbm_value program = cons_with_gc(cl[CLO_BODY1], ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), clo_env);
2351
2352 lbm_cid cid = lbm_create_ctx_parent(program,
2353 clo_env,
2354 stack_size,
2355 lbm_get_current_cid(),
2356 context_flags,
2357 name);
2358 ctx->r = lbm_enc_i(cid);
2359 ctx->app_cont = true1;
2360}
2361
2362static void apply_spawn(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2363 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00);
2364}
2365
2366static void apply_spawn_trap(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2367 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01);
2368}
2369
2370static void apply_yield(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2371 if (is_atomic) {
2372 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2373 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2374 }
2375 if (nargs == 1 && lbm_is_number(args[0])) {
2376 lbm_uint ts = lbm_dec_as_u32(args[0]);
2377 lbm_stack_drop(&ctx->K, nargs+1);
2378 yield_ctx(ts);
2379 } else {
2380 lbm_set_error_reason((char*)lbm_error_str_no_number);
2381 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2382 }
2383}
2384
2385static void apply_sleep(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2386 if (is_atomic) {
2387 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2388 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2389 }
2390 if (nargs == 1 && lbm_is_number(args[0])) {
2391 lbm_uint ts = (lbm_uint)(1000000.0f * lbm_dec_as_float(args[0]));
2392 lbm_stack_drop(&ctx->K, nargs+1);
2393 yield_ctx(ts);
2394 } else {
2395 lbm_set_error_reason((char*)lbm_error_str_no_number);
2396 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2397 }
2398}
2399
2400static void apply_wait(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2401 if (nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2402 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2403 lbm_value *sptr = get_stack_ptr(ctx, 2);
2404 sptr[0] = lbm_enc_i(cid);
2405 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2406 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2407 ctx->app_cont = true1;
2408 yield_ctx(50000);
2409 } else {
2410 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_WAIT(((0x30007) << 4) | 0x00000000u));
2411 }
2412}
2413
2414/* (eval expr)
2415 (eval env expr) */
2416static void apply_eval(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2417 if ( nargs == 1) {
2418 ctx->curr_exp = args[0];
2419 } else if (nargs == 2) {
2420 ctx->curr_exp = args[1];
2421 ctx->curr_env = args[0];
2422 } else {
2423 lbm_set_error_reason((char*)lbm_error_str_num_args);
2424 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL(((0x30008) << 4) | 0x00000000u));
2425 }
2426 lbm_stack_drop(&ctx->K, nargs+1);
2427}
2428
2429static void apply_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2430 int prg_pos = 0;
2431 if (nargs == 2) {
2432 prg_pos = 1;
2433 ctx->curr_env = args[0];
2434 }
2435 if (nargs == 1 || nargs == 2) {
2436 lbm_value prg = args[prg_pos];
2437 lbm_value app_cont;
2438 lbm_value app_cont_prg;
2439 lbm_value new_prg;
2440 lbm_value prg_copy;
2441
2442 int len = -1;
2443 WITH_GC(prg_copy, lbm_list_copy(&len, prg))(prg_copy) = (lbm_list_copy(&len, prg)); if (lbm_is_symbol_merror
((prg_copy))) { gc(); (prg_copy) = (lbm_list_copy(&len, prg
)); if (lbm_is_symbol_merror((prg_copy))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2444 lbm_stack_drop(&ctx->K, nargs+1);
2445
2446 if (ctx->K.sp > nargs+2) { // if there is a continuation
2447 app_cont = cons_with_gc(ENC_SYM_APP_CONT(((0x111) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2448 app_cont_prg = cons_with_gc(app_cont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2449 new_prg = lbm_list_append(app_cont_prg, ctx->program);
2450 new_prg = lbm_list_append(prg_copy, new_prg);
2451 } else {
2452 new_prg = lbm_list_append(prg_copy, ctx->program);
2453 }
2454 if (!lbm_is_list(new_prg)) {
2455 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2456 }
2457 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);
2458 ctx->program = get_cdr(new_prg);
2459 ctx->curr_exp = get_car(new_prg);
2460 } else {
2461 lbm_set_error_reason((char*)lbm_error_str_num_args);
2462 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2463 }
2464}
2465
2466static void apply_send(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2467 if (nargs == 2) {
2468 if (lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2469 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2470 lbm_value msg = args[1];
2471 lbm_value status = lbm_find_receiver_and_send(cid, msg);
2472 /* return the status */
2473 lbm_stack_drop(&ctx->K, nargs+1);
2474 ctx->r = status;
2475 ctx->app_cont = true1;
2476 } else {
2477 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2478 }
2479 } else {
2480 lbm_set_error_reason((char*)lbm_error_str_num_args);
2481 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2482 }
2483}
2484
2485static void apply_ok(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2486 lbm_value ok_val = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2487 if (nargs >= 1) {
2488 ok_val = args[0];
2489 }
2490 ctx->r = ok_val;
2491 ok_ctx();
2492}
2493
2494static void apply_error(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2495 (void) ctx;
2496 lbm_value err_val = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
2497 if (nargs >= 1) {
2498 err_val = args[0];
2499 }
2500 error_at_ctx(err_val, ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
2501}
2502
2503// (map f arg-list)
2504static void apply_map(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2505 if (nargs == 2 && lbm_is_cons(args[1])) {
2506 lbm_value *sptr = get_stack_ptr(ctx, 3);
2507
2508 lbm_value f = args[0];
2509 lbm_value h = get_car(args[1]);
2510 lbm_value t = get_cdr(args[1]);
2511
2512 lbm_value appli_1;
2513 lbm_value appli;
2514 WITH_GC(appli_1, lbm_heap_allocate_list(2))(appli_1) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli_1))) { gc(); (appli_1) = (lbm_heap_allocate_list(2));
if (lbm_is_symbol_merror((appli_1))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2515 WITH_GC_RMBR_1(appli, lbm_heap_allocate_list(2), appli_1)(appli) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli))) { lbm_gc_mark_phase(appli_1); gc(); (appli) = (lbm_heap_allocate_list
(2)); if (lbm_is_symbol_merror((appli))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2516
2517 lbm_value appli_0 = get_cdr(appli_1);
2518
2519 lbm_set_car_and_cdr(appli_0, h, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2520 lbm_set_car(appli_1, ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u));
2521
2522 lbm_set_car_and_cdr(get_cdr(appli), appli_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2523 lbm_set_car(appli, f);
2524
2525 lbm_value elt = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), appli);
2526 sptr[0] = t; // reuse stack space
2527 sptr[1] = ctx->curr_env;
2528 sptr[2] = elt;
2529 lbm_value *rptr = stack_reserve(ctx,4);
2530 rptr[0] = elt;
2531 rptr[1] = appli;
2532 rptr[2] = appli_0;
2533 rptr[3] = MAP(((26) << 2) | 0xF8000001u);
2534 ctx->curr_exp = appli;
2535 } else if (nargs == 2 && lbm_is_symbol_nil(args[1])) {
2536 lbm_stack_drop(&ctx->K, 3);
2537 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2538 ctx->app_cont = true1;
2539 return;
2540 } else {
2541 lbm_set_error_reason((char*)lbm_error_str_num_args);
2542 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_MAP(((0x3000D) << 4) | 0x00000000u));
2543 }
2544}
2545
2546static void apply_reverse(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2547 if (nargs == 1 && lbm_is_list(args[0])) {
2548 lbm_value curr = args[0];
2549
2550 lbm_value new_list = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2551 while (lbm_is_cons(curr)) {
2552 lbm_value tmp = cons_with_gc(get_car(curr), new_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2553 new_list = tmp;
2554 curr = get_cdr(curr);
2555 }
2556 lbm_stack_drop(&ctx->K, 2);
2557 ctx->r = new_list;
2558 ctx->app_cont = true1;
2559 } else {
2560 lbm_set_error_reason("Reverse requires a list argument");
2561 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_REVERSE(((0x3000E) << 4) | 0x00000000u));
2562 }
2563}
2564
2565static void apply_flatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2566 if (nargs == 1) {
2567
2568 lbm_value v = flatten_value(args[0]);
2569 if ( v == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)) {
2570 gc();
2571 v = flatten_value(args[0]);
2572 }
2573
2574 if (lbm_is_symbol(v)) {
2575 error_at_ctx(v, ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2576 } else {
2577 lbm_stack_drop(&ctx->K, 2);
2578 ctx->r = v;
2579 ctx->app_cont = true1;
2580 }
2581 return;
2582 }
2583 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2584}
2585
2586static void apply_unflatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2587 if(nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2588 lbm_array_header_t *array;
2589 array = (lbm_array_header_t *)get_car(args[0]);
2590
2591 lbm_flat_value_t fv;
2592 fv.buf = (uint8_t*)array->data;
2593 fv.buf_size = array->size;
2594 fv.buf_pos = 0;
2595
2596 lbm_value res;
2597
2598 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2599 if (lbm_unflatten_value(&fv, &res)) {
2600 ctx->r = res;
2601 }
2602 lbm_stack_drop(&ctx->K, 2);
2603 ctx->app_cont = true1;
2604 return;
2605 }
2606 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_UNFLATTEN(((0x30010) << 4) | 0x00000000u));
2607}
2608
2609static void apply_kill(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2610 if (nargs == 2 && lbm_is_number(args[0])) {
2611 lbm_cid cid = lbm_dec_as_i32(args[0]);
2612
2613 if (ctx->id == cid) {
2614 ctx->r = args[1];
2615 finish_ctx();
2616 return;
2617 }
2618 mutex_lock(&qmutex);
2619 eval_context_t *found = NULL((void*)0);
2620 found = lookup_ctx_nm(&blocked, cid);
2621 if (found)
2622 drop_ctx_nm(&blocked, found);
2623 else
2624 found = lookup_ctx_nm(&queue, cid);
2625 if (found)
2626 drop_ctx_nm(&queue, found);
2627
2628 if (found) {
2629 found->K.data[found->K.sp - 1] = KILL(((40) << 2) | 0xF8000001u);
2630 found->r = args[1];
2631 found->app_cont = true1;
2632 enqueue_ctx_nm(&queue,found);
2633 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2634 } else {
2635 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2636 }
2637 lbm_stack_drop(&ctx->K, 3);
2638 ctx->app_cont = true1;
2639 mutex_unlock(&qmutex);
2640 return;
2641 }
2642 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_KILL(((0x30011) << 4) | 0x00000000u));
2643}
2644
2645// (merge comparator list1 list2)
2646static void apply_merge(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2647 if (nargs == 3 && lbm_is_list(args[1]) && lbm_is_list(args[2])) {
2648
2649 if (!lbm_is_closure(args[0])) {
2650 lbm_value closure;
2651 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2652 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2653 lbm_value cl1 = lbm_cdr(closure);
2654 lbm_value par;
2655 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2656 lbm_set_car(cl1, par);
2657 lbm_value cl2 = lbm_cdr(cl1);
2658 lbm_value body;
2659 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2660 lbm_set_car(cl2, body);
2661 lbm_value cl3 = lbm_cdr(cl2);
2662 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2663
2664 // Replace operator on stack with closure and rest of the code is
2665 // compatible.
2666 args[0] = closure;
2667 }
2668
2669 // Copy input lists for functional behaviour at top-level
2670 // merge itself is in-place in the copied lists.
2671 lbm_value a;
2672 lbm_value b;
2673 int len_a = -1;
2674 int len_b = -1;
2675 WITH_GC(a, lbm_list_copy(&len_a, args[1]))(a) = (lbm_list_copy(&len_a, args[1])); if (lbm_is_symbol_merror
((a))) { gc(); (a) = (lbm_list_copy(&len_a, args[1])); if
(lbm_is_symbol_merror((a))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } };
2676 WITH_GC_RMBR_1(b, lbm_list_copy(&len_b, args[2]), a)(b) = (lbm_list_copy(&len_b, args[2])); if (lbm_is_symbol_merror
((b))) { lbm_gc_mark_phase(a); gc(); (b) = (lbm_list_copy(&
len_b, args[2])); if (lbm_is_symbol_merror((b))) { error_ctx(
(((0x23) << 4) | 0x00000000u)); } };
2677
2678 if (len_a == 0) {
2679 ctx->r = b;
2680 lbm_stack_drop(&ctx->K, 4);
2681 ctx->app_cont = true1;
2682 return;
2683 }
2684 if (len_b == 0) {
2685 ctx->r = a;
2686 lbm_stack_drop(&ctx->K, 4);
2687 ctx->app_cont = true1;
2688 return;
2689 }
2690
2691 args[1] = a; // keep safe by replacing the original on stack.
2692 args[2] = b;
2693
2694 lbm_value a_1 = a;
2695 lbm_value a_rest = lbm_cdr(a);
2696 lbm_value b_1 = b;
2697 lbm_value b_rest = lbm_cdr(b);
2698
2699 lbm_value cl[3]; // Comparator closure
2700 extract_n(lbm_cdr(args[0]), cl, 3);
2701 lbm_value cmp_env = cl[CLO_ENV2];
2702 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2703 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2704 lbm_uint len = lbm_list_length(cl[CLO_PARAMS0]);
2705 if (len == 2) {
2706 par1 = get_car(cl[CLO_PARAMS0]);
2707 par2 = get_cadr(cl[CLO_PARAMS0]);
2708 lbm_value new_env0;
2709 lbm_value new_env;
2710 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a_1)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a_1))); if (
lbm_is_symbol_merror((new_env0))) { gc(); (new_env0) = (lbm_env_set
(cmp_env, par1, lbm_car(a_1))); if (lbm_is_symbol_merror((new_env0
))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2711 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b_1)),new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1))); if (
lbm_is_symbol_merror((new_env))) { lbm_gc_mark_phase(new_env0
); gc(); (new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1
))); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2712 cmp_env = new_env;
2713 } else {
2714 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2715 }
2716 lbm_set_cdr(a_1, b_1);
2717 lbm_set_cdr(b_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2718 lbm_value cmp = cl[CLO_BODY1];
2719
2720 lbm_stack_drop(&ctx->K, 4); // TODO: Optimize drop 4 alloc 10 into alloc 6
2721 lbm_uint *sptr = stack_reserve(ctx, 10);
2722 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged list
2723 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged list
2724 sptr[2] = a_1;
2725 sptr[3] = a_rest;
2726 sptr[4] = b_rest;
2727 sptr[5] = cmp;
2728 sptr[6] = cmp_env;
2729 sptr[7] = par1;
2730 sptr[8] = par2;
2731 sptr[9] = MERGE_REST(((43) << 2) | 0xF8000001u);
2732 ctx->curr_exp = cl[CLO_BODY1];
2733 ctx->curr_env = cmp_env;
2734 return;
2735 }
2736 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MERGE(((0x30013) << 4) | 0x00000000u));
2737}
2738
2739// (sort comparator list)
2740static void apply_sort(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2741 if (nargs == 2 && lbm_is_list(args[1])) {
2742
2743 if (!lbm_is_closure(args[0])) {
2744 lbm_value closure;
2745 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2746 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2747 lbm_value cl1 = lbm_cdr(closure);
2748 lbm_value par;
2749 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2750 lbm_set_car(cl1, par);
2751 lbm_value cl2 = lbm_cdr(cl1);
2752 lbm_value body;
2753 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2754 lbm_set_car(cl2, body);
2755 lbm_value cl3 = lbm_cdr(cl2);
2756 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2757
2758 // Replace operator on stack with closure and rest of the code is
2759 // compatible.
2760 args[0] = closure;
2761 }
2762
2763 int len = -1;
2764 lbm_value list_copy;
2765 WITH_GC(list_copy, lbm_list_copy(&len, args[1]))(list_copy) = (lbm_list_copy(&len, args[1])); if (lbm_is_symbol_merror
((list_copy))) { gc(); (list_copy) = (lbm_list_copy(&len,
args[1])); if (lbm_is_symbol_merror((list_copy))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2766 if (len <= 1) {
2767 lbm_stack_drop(&ctx->K, 3);
2768 ctx->r = list_copy;
2769 ctx->app_cont = true1;
2770 return;
2771 }
2772
2773 args[1] = list_copy; // Keep safe, original replaced on stack.
2774
2775 // Take the headmost 2, 1-element sublists.
2776 lbm_value a = list_copy;
2777 lbm_value b = lbm_cdr(a);
2778 lbm_value rest = lbm_cdr(b);
2779 // Do not terminate b. keep rest of list safe from GC in the following
2780 // closure extraction.
2781 //lbm_set_cdr(a, b); // This is void
2782
2783 lbm_value cl[3]; // Comparator closure
2784 extract_n(lbm_cdr(args[0]), cl, 3);
2785 lbm_value cmp_env = cl[CLO_ENV2];
2786 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2787 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2788 lbm_uint cl_len = lbm_list_length(cl[CLO_PARAMS0]);
2789 if (cl_len == 2) {
2790 par1 = get_car(cl[CLO_PARAMS0]);
2791 par2 = get_cadr(cl[CLO_PARAMS0]);
2792 lbm_value new_env0;
2793 lbm_value new_env;
2794 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a))); if (lbm_is_symbol_merror
((new_env0))) { gc(); (new_env0) = (lbm_env_set(cmp_env, par1
, lbm_car(a))); if (lbm_is_symbol_merror((new_env0))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2795 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b)), new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { lbm_gc_mark_phase(new_env0); gc(); (new_env) =
(lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { error_ctx((((0x23) << 4) | 0x00000000u))
; } };
2796 cmp_env = new_env;
2797 } else {
2798 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2799 }
2800 lbm_value cmp = cl[CLO_BODY1];
2801
2802 // Terminate the comparator argument list.
2803 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2804
2805 lbm_stack_drop(&ctx->K, 3); //TODO: optimize drop 3, alloc 20 into alloc 17
2806 lbm_uint *sptr = stack_reserve(ctx, 20);
2807 sptr[0] = cmp;
2808 sptr[1] = cmp_env;
2809 sptr[2] = par1;
2810 sptr[3] = par2;
2811 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged accumulation of sublists
2812 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged accumulation of sublists
2813 sptr[6] = rest;
2814 sptr[7] = lbm_enc_i(1);
2815 sptr[8] = lbm_enc_i(len); //TODO: 28 bit i vs 32 bit i
2816 sptr[9] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
2817 sptr[10] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged sublist
2818 sptr[11] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged sublist
2819 sptr[12] = a;
2820 sptr[13] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no a_rest, 1 element lists in layer 1.
2821 sptr[14] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no b_rest, 1 element lists in layer 1.
2822 sptr[15] = cmp;
2823 sptr[16] = cmp_env;
2824 sptr[17] = par1;
2825 sptr[18] = par2;
2826 sptr[19] = MERGE_REST(((43) << 2) | 0xF8000001u);
2827 ctx->curr_exp = cmp;
2828 ctx->curr_env = cmp_env;
2829 return;
2830 }
2831 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
2832}
2833
2834static void apply_rest_args(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2835 lbm_value res;
2836 if (lbm_env_lookup_b(&res, ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ctx->curr_env)) {
2837 if (nargs == 1 && lbm_is_number(args[0])) {
2838 int32_t ix = lbm_dec_as_i32(args[0]);
2839 res = lbm_index_list(res, ix);
2840 }
2841 ctx->r = res;
2842 } else {
2843 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2844 }
2845 lbm_stack_drop(&ctx->K, nargs+1);
2846 ctx->app_cont = true1;
2847}
2848
2849/* (rotate list-expr dist/dir-expr) */
2850static void apply_rotate(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2851 if (nargs == 2 && lbm_is_list(args[0]) && lbm_is_number(args[1])) {
2852 int len = -1;
2853 lbm_value ls = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2854 WITH_GC(ls, lbm_list_copy(&len, args[0]))(ls) = (lbm_list_copy(&len, args[0])); if (lbm_is_symbol_merror
((ls))) { gc(); (ls) = (lbm_list_copy(&len, args[0])); if
(lbm_is_symbol_merror((ls))) { error_ctx((((0x23) << 4
) | 0x00000000u)); } };
2855 int dist = lbm_dec_as_i32(args[1]);
2856 if (len > 0 && dist != 0) {
2857 int d = dist;
2858 if (dist > 0) {
2859 ls = lbm_list_destructive_reverse(ls);
2860 } else {
2861 d = -dist;
2862 }
2863
2864 lbm_value start = ls;
2865 lbm_value end = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2866 lbm_value curr = start;
2867 while (lbm_is_cons(curr)) {
2868 end = curr;
2869 curr = get_cdr(curr);
2870 }
2871
2872 for (int i = 0; i < d; i ++) {
2873 lbm_value a = start;
2874 start = lbm_cdr(start);
2875 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2876 lbm_set_cdr(end, a);
2877 end = a;
2878 }
2879 ls = start;
2880 if (dist > 0) {
2881 ls = lbm_list_destructive_reverse(ls);
2882 }
2883 }
2884 lbm_stack_drop(&ctx->K, nargs+1);
2885 ctx->app_cont = true1;
2886 ctx->r = ls;
2887 return;
2888 }
2889 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2890}
2891
2892/***************************************************/
2893/* Application lookup table */
2894
2895typedef void (*apply_fun)(lbm_value *, lbm_uint, eval_context_t *);
2896static const apply_fun fun_table[] =
2897 {
2898 apply_setvar,
2899 apply_read,
2900 apply_read_program,
2901 apply_read_eval_program,
2902 apply_spawn,
2903 apply_spawn_trap,
2904 apply_yield,
2905 apply_wait,
2906 apply_eval,
2907 apply_eval_program,
2908 apply_send,
2909 apply_ok,
2910 apply_error,
2911 apply_map,
2912 apply_reverse,
2913 apply_flatten,
2914 apply_unflatten,
2915 apply_kill,
2916 apply_sleep,
2917 apply_merge,
2918 apply_sort,
2919 apply_rest_args,
2920 apply_rotate,
2921 };
2922
2923/***************************************************/
2924/* Application of function that takes arguments */
2925/* passed over the stack. */
2926
2927static void application(eval_context_t *ctx, lbm_value *fun_args, lbm_uint arg_count) {
2928 /* If arriving here, we know that the fun is a symbol.
2929 * and can be a built in operation or an extension.
2930 */
2931 lbm_value fun = fun_args[0];
2932
2933 lbm_uint fun_val = lbm_dec_sym(fun);
2934 lbm_uint fun_kind = SYMBOL_KIND(fun_val)((fun_val) >> 16);
2935
2936 switch (fun_kind) {
2937 case SYMBOL_KIND_EXTENSION1: {
2938 extension_fptr f = extension_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)].fptr;
2939
2940 lbm_value ext_res;
2941 WITH_GC(ext_res, f(&fun_args[1], arg_count))(ext_res) = (f(&fun_args[1], arg_count)); if (lbm_is_symbol_merror
((ext_res))) { gc(); (ext_res) = (f(&fun_args[1], arg_count
)); if (lbm_is_symbol_merror((ext_res))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2942 if (lbm_is_error(ext_res)) { //Error other than merror
2943 error_at_ctx(ext_res, fun);
2944 }
2945 lbm_stack_drop(&ctx->K, arg_count + 1);
2946
2947 ctx->app_cont = true1;
2948 ctx->r = ext_res;
2949
2950 if (blocking_extension) {
2951 blocking_extension = false0;
2952 if (blocking_extension_timeout) {
2953 blocking_extension_timeout = false0;
2954 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, blocking_extension_timeout_us,true1);
2955 } else {
2956 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,true1);
2957 }
2958 mutex_unlock(&blocking_extension_mutex);
2959 }
2960 } break;
2961 case SYMBOL_KIND_FUNDAMENTAL2:
2962 call_fundamental(SYMBOL_IX(fun_val)((fun_val) & 0xFFFF), &fun_args[1], arg_count, ctx);
2963 break;
2964 case SYMBOL_KIND_APPFUN3:
2965 fun_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)](&fun_args[1], arg_count, ctx);
2966 break;
2967 default:
2968 // Symbols that are "special" but not in the way caught above
2969 // ends up here.
2970 lbm_set_error_reason("Symbol does not represent a function");
2971 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),fun_args[0]);
2972 break;
2973 }
2974}
2975
2976static void cont_closure_application_args(eval_context_t *ctx) {
2977 lbm_uint* sptr = get_stack_ptr(ctx, 5);
2978
2979 lbm_value arg_env = (lbm_value)sptr[0];
2980 lbm_value exp = (lbm_value)sptr[1];
2981 lbm_value clo_env = (lbm_value)sptr[2];
2982 lbm_value params = (lbm_value)sptr[3];
2983 lbm_value args = (lbm_value)sptr[4];
2984
2985 lbm_value car_params, cdr_params;
2986 get_car_and_cdr(params, &car_params, &cdr_params);
1
Calling 'get_car_and_cdr'
→
5
←
Returning from 'get_car_and_cdr'
→
2987
2988 bool_Bool a_nil = lbm_is_symbol_nil(args);
6
←
Calling 'lbm_is_symbol_nil'
→
9
←
Returning from 'lbm_is_symbol_nil'
→
2989 bool_Bool p_nil = lbm_is_symbol_nil(cdr_params);
10
←
Calling 'lbm_is_symbol_nil'
→
13
←
Returning from 'lbm_is_symbol_nil'
→
2990
2991 lbm_value binder = allocate_binding(car_params, ctx->r, clo_env);
2992
2993 if (!a_nil
13.1
'a_nil' is false
13.1
'a_nil' is false
 && !p_nil
13.2
'p_nil' is false
13.2
'p_nil' is false
) {
14
←
Taking true branch
→
2994 lbm_value car_args, cdr_args;
15
←
'cdr_args' declared without an initial value
→
2995 get_car_and_cdr(args, &car_args, &cdr_args);
16
←
Calling 'get_car_and_cdr'
→
21
←
Returning from 'get_car_and_cdr'
→
2996 sptr[2] = binder;
2997 sptr[3] = cdr_params;
2998 sptr[4] = cdr_args;
22
←
Assigned value is garbage or undefined
2999 stack_reserve(ctx,1)[0] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
3000 ctx->curr_exp = car_args;
3001 ctx->curr_env = arg_env;
3002 } else if (a_nil && p_nil) {
3003 // Arguments and parameters match up in number
3004 lbm_stack_drop(&ctx->K, 5);
3005 ctx->curr_env = binder;
3006 ctx->curr_exp = exp;
3007 } else if (p_nil) {
3008 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), binder);
3009 sptr[2] = rest_binder;
3010 sptr[3] = get_cdr(args);
3011 sptr[4] = get_car(rest_binder); // last element of rest_args so far
3012 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3013 ctx->curr_exp = get_car(args);
3014 ctx->curr_env = arg_env;
3015 } else {
3016 lbm_set_error_reason((char*)lbm_error_str_num_args);
3017 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
3018 }
3019}
3020
3021
3022static void cont_closure_args_rest(eval_context_t *ctx) {
3023 lbm_uint* sptr = get_stack_ptr(ctx, 5);
3024 lbm_value arg_env = (lbm_value)sptr[0];
3025 lbm_value exp = (lbm_value)sptr[1];
3026 lbm_value clo_env = (lbm_value)sptr[2];
3027 lbm_value args = (lbm_value)sptr[3];
3028 lbm_value last = (lbm_value)sptr[4];
3029 lbm_cons_t* heap = lbm_heap_state.heap;
3030
3031 lbm_value binding = lbm_heap_state.freelist;
3032 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3033 gc();
3034 binding = lbm_heap_state.freelist;
3035 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3036 }
3037 lbm_uint binding_ix = lbm_dec_ptr(binding);
3038 lbm_heap_state.freelist = heap[binding_ix].cdr;
3039 lbm_heap_state.num_alloc += 1;
3040 heap[binding_ix].car = ctx->r;
3041 heap[binding_ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3042
3043
3044 lbm_set_cdr(last, binding);
3045 sptr[4] = binding;
3046
3047 if (args == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3048 lbm_stack_drop(&ctx->K, 5);
3049 ctx->curr_env = clo_env;
3050 ctx->curr_exp = exp;
3051 } else {
3052 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3053 sptr[3] = get_cdr(args);
3054 ctx->curr_exp = get_car(args);
3055 ctx->curr_env = arg_env;
3056 }
3057}
3058
3059static void cont_application_args(eval_context_t *ctx) {
3060 lbm_uint *sptr = get_stack_ptr(ctx, 3);
3061
3062 lbm_value env = sptr[0];
3063 lbm_value rest = sptr[1];
3064 lbm_value count = sptr[2];
3065
3066 ctx->curr_env = env;
3067 sptr[0] = ctx->r; // Function 1st then Arguments
3068 if (lbm_is_cons(rest)) {
3069 lbm_cons_t *cell = lbm_ref_cell(rest);
3070 sptr[1] = env;
3071 sptr[2] = cell->cdr;
3072 lbm_value *rptr = stack_reserve(ctx,2);
3073 rptr[0] = count + (1 << LBM_VAL_SHIFT4);
3074 rptr[1] = APPLICATION_ARGS(((5) << 2) | 0xF8000001u);
3075 ctx->curr_exp = cell->car;
3076 } else {
3077 // No more arguments
3078 lbm_stack_drop(&ctx->K, 2);
3079 lbm_uint nargs = lbm_dec_u(count);
3080 lbm_value *args = get_stack_ptr(ctx, (uint32_t)(nargs + 1));
3081 application(ctx,args, nargs);
3082 }
3083}
3084
3085static void cont_and(eval_context_t *ctx) {
3086 lbm_value env;
3087 lbm_value rest;
3088 lbm_value arg = ctx->r;
3089 lbm_pop_2(&ctx->K, &rest, &env);
3090 if (lbm_is_symbol_nil(arg)) {
3091 ctx->app_cont = true1;
3092 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3093 } else if (lbm_is_symbol_nil(rest)) {
3094 ctx->app_cont = true1;
3095 } else {
3096 lbm_value *sptr = stack_reserve(ctx, 3);
3097 sptr[0] = env;
3098 sptr[1] = get_cdr(rest);
3099 sptr[2] = AND(((6) << 2) | 0xF8000001u);
3100 ctx->curr_env = env;
3101 ctx->curr_exp = get_car(rest);
3102 }
3103}
3104
3105static void cont_or(eval_context_t *ctx) {
3106 lbm_value env;
3107 lbm_value rest;
3108 lbm_value arg = ctx->r;
3109 lbm_pop_2(&ctx->K, &rest, &env);
3110 if (!lbm_is_symbol_nil(arg)) {
3111 ctx->app_cont = true1;
3112 } else if (lbm_is_symbol_nil(rest)) {
3113 ctx->app_cont = true1;
3114 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3115 } else {
3116 lbm_value *sptr = stack_reserve(ctx, 3);
3117 sptr[0] = env;
3118 sptr[1] = get_cdr(rest);
3119 sptr[2] = OR(((7) << 2) | 0xF8000001u);
3120 ctx->curr_exp = get_car(rest);
3121 ctx->curr_env = env;
3122 }
3123}
3124
3125static int fill_binding_location(lbm_value key, lbm_value value, lbm_value env) {
3126 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) {
3127 if (key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return FB_OK0;
3128 lbm_env_modify_binding(env,key,value);
3129 return FB_OK0;
3130 } else if (lbm_is_cons(key) &&
3131 lbm_is_cons(value)) {
3132 int r = fill_binding_location(get_car(key), get_car(value), env);
3133 if (r == FB_OK0) {
3134 r = fill_binding_location(get_cdr(key), get_cdr(value), env);
3135 }
3136 return r;
3137 }
3138 return FB_TYPE_ERROR-1;
3139}
3140
3141static void cont_bind_to_key_rest(eval_context_t *ctx) {
3142
3143 lbm_value *sptr = get_stack_ptr(ctx, 4);
3144
3145 lbm_value rest = sptr[1];
3146 lbm_value env = sptr[2];
3147 lbm_value key = sptr[3];
3148
3149 if (fill_binding_location(key, ctx->r, env) < 0) {
3150 lbm_set_error_reason("Incorrect type of name/key in let-binding");
3151 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
3152 }
3153
3154 if (lbm_is_cons(rest)) {
3155 lbm_value car_rest = get_car(rest);
3156 lbm_value key_val[2];
3157 extract_n(car_rest, key_val, 2);
3158
3159 sptr[1] = get_cdr(rest);
3160 sptr[3] = key_val[0];
3161 stack_reserve(ctx,1)[0] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
3162 ctx->curr_exp = key_val[1];
3163 ctx->curr_env = env;
3164 } else {
3165 // Otherwise evaluate the expression in the populated env
3166 ctx->curr_exp = sptr[0];
3167 ctx->curr_env = env;
3168 lbm_stack_drop(&ctx->K, 4);
3169 }
3170}
3171
3172static void cont_if(eval_context_t *ctx) {
3173
3174 lbm_value arg = ctx->r;
3175
3176 lbm_value *sptr = pop_stack_ptr(ctx, 2);
3177
3178 ctx->curr_env = sptr[1];
3179 if (lbm_is_symbol_nil(arg)) {
3180 ctx->curr_exp = get_cadr(sptr[0]); // else branch
3181 } else {
3182 ctx->curr_exp = get_car(sptr[0]); // then branch
3183 }
3184}
3185
3186static void cont_match(eval_context_t *ctx) {
3187 lbm_value e = ctx->r;
3188 bool_Bool do_gc = false0;
3189
3190 lbm_uint *sptr = get_stack_ptr(ctx, 2);
3191 lbm_value patterns = (lbm_value)sptr[0];
3192 lbm_value orig_env = (lbm_value)sptr[1]; // restore enclosing environment.
3193 lbm_value new_env = orig_env;
3194
3195 if (lbm_is_symbol_nil(patterns)) {
3196 // no more patterns
3197 lbm_stack_drop(&ctx->K, 2);
3198 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
3199 ctx->app_cont = true1;
3200 } else if (lbm_is_cons(patterns)) {
3201 lbm_value match_case = get_car(patterns);
3202 lbm_value pattern = get_car(match_case);
3203 lbm_value n1 = get_cadr(match_case);
3204 lbm_value n2 = get_cadr(get_cdr(match_case));
3205 lbm_value body;
3206 bool_Bool check_guard = false0;
3207 if (lbm_is_symbol_nil(n2)) { // TODO: Not a very robust check.
3208 body = n1;
3209 } else {
3210 body = n2;
3211 check_guard = true1;
3212 }
3213
3214 bool_Bool is_match = match(pattern, e, &new_env, &do_gc);
3215 if (do_gc) {
3216 gc();
3217 do_gc = false0;
3218 new_env = orig_env;
3219 is_match = match(pattern, e, &new_env, &do_gc);
3220 if (do_gc) {
3221 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3222 }
3223 }
3224 if (is_match) {
3225 if (check_guard) {
3226 lbm_value *rptr = stack_reserve(ctx,5);
3227 sptr[0] = get_cdr(patterns);
3228 sptr[1] = ctx->curr_env;
3229 rptr[0] = MATCH(((9) << 2) | 0xF8000001u);
3230 rptr[1] = new_env;
3231 rptr[2] = body;
3232 rptr[3] = e;
3233 rptr[4] = MATCH_GUARD(((27) << 2) | 0xF8000001u);
3234 ctx->curr_env = new_env;
3235 ctx->curr_exp = n1; // The guard
3236 } else {
3237 lbm_stack_drop(&ctx->K, 2);
3238 ctx->curr_env = new_env;
3239 ctx->curr_exp = body;
3240 }
3241 } else {
3242 // set up for checking of next pattern
3243 sptr[0] = get_cdr(patterns);
3244 sptr[1] = orig_env;
3245 stack_reserve(ctx,1)[0] = MATCH(((9) << 2) | 0xF8000001u);
3246 // leave r unaltered
3247 ctx->app_cont = true1;
3248 }
3249 } else {
3250 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MATCH(((0x108) << 4) | 0x00000000u));
3251 }
3252}
3253
3254static void cont_exit_atomic(eval_context_t *ctx) {
3255 is_atomic --;
3256 ctx->app_cont = true1;
3257}
3258
3259static void cont_map(eval_context_t *ctx) {
3260 lbm_value *sptr = get_stack_ptr(ctx, 6);
3261
3262 lbm_value ls = sptr[0];
3263 lbm_value env = sptr[1];
3264 lbm_value t = sptr[3];
3265 lbm_set_car(t, ctx->r); // update car field tailmost position.
3266 if (lbm_is_cons(ls)) {
3267 lbm_value next, rest;
3268 get_car_and_cdr(ls, &next, &rest);
3269 sptr[0] = rest;
3270 stack_reserve(ctx,1)[0] = MAP(((26) << 2) | 0xF8000001u);
3271 lbm_set_car(sptr[5], next); // new arguments
3272
3273 lbm_value elt = cons_with_gc(ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3274 lbm_set_cdr(t, elt);
3275 sptr[3] = elt; // (r1 ... rN . (nil . nil))
3276 ctx->curr_exp = sptr[4];
3277 ctx->curr_env = env;
3278 } else {
3279 ctx->r = sptr[2]; //head of result list
3280 ctx->curr_env = env;
3281 lbm_stack_drop(&ctx->K, 6);
3282 ctx->app_cont = true1;
3283 }
3284}
3285
3286static void cont_match_guard(eval_context_t *ctx) {
3287 if (lbm_is_symbol_nil(ctx->r)) {
3288 lbm_value e;
3289 lbm_pop(&ctx->K, &e);
3290 lbm_stack_drop(&ctx->K, 2);
3291 ctx->r = e;
3292 ctx->app_cont = true1;
3293 } else {
3294 lbm_value body;
3295 lbm_value env;
3296 lbm_stack_drop(&ctx->K, 1);
3297 lbm_pop_2(&ctx->K, &body, &env);
3298 lbm_stack_drop(&ctx->K, 3);
3299 ctx->curr_env = env;
3300 ctx->curr_exp = body;
3301 }
3302}
3303
3304static void cont_terminate(eval_context_t *ctx) {
3305 error_ctx(ctx->r);
3306}
3307
3308static void cont_loop(eval_context_t *ctx) {
3309 lbm_value *sptr = get_stack_ptr(ctx, 2);
3310 stack_reserve(ctx,1)[0] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
3311 ctx->curr_exp = sptr[1];
3312}
3313
3314static void cont_loop_condition(eval_context_t *ctx) {
3315 if (lbm_is_symbol_nil(ctx->r)) {
3316 lbm_stack_drop(&ctx->K, 2);
3317 ctx->app_cont = true1; // A loop returns nil? Makes sense to me... but in general?
3318 return;
3319 }
3320 lbm_value *sptr = get_stack_ptr(ctx, 2);
3321 stack_reserve(ctx,1)[0] = LOOP(((41) << 2) | 0xF8000001u);
3322 ctx->curr_exp = sptr[0];
3323}
3324
3325static void cont_merge_rest(eval_context_t *ctx) {
3326 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3327
3328 // If comparator returns true (result is in ctx->r):
3329 // "a" should be moved to the last element position in merged list.
3330 // A new element from "a_rest" should be moved into comparator argument 1 pos.
3331 // else
3332 // "b" should be moved to last element position in merged list.
3333 // A new element from "b_rest" should be moved into comparator argument 2 pos.
3334 //
3335 // If a_rest or b_rest is NIL:
3336 // we are done, the remaining elements of
3337 // non_nil list should be appended to merged list.
3338 // else
3339 // Set up for a new comparator evaluation and recurse.
3340 lbm_value a = sptr[2];
3341 lbm_value b = lbm_cdr(a);
3342 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate 1 element list
3343
3344 if (ctx->r == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) { // Comparison false
3345
3346 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3347 sptr[0] = b;
3348 sptr[1] = b;
3349 } else {
3350 lbm_set_cdr(sptr[1], b);
3351 sptr[1] = b;
3352 }
3353 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3354 lbm_set_cdr(a, sptr[3]);
3355 lbm_set_cdr(sptr[1], a);
3356 ctx->r = sptr[0];
3357 lbm_stack_drop(&ctx->K, 9);
3358 ctx->app_cont = true1;
3359 return;
3360 } else {
3361 b = sptr[4];
3362 sptr[4] = lbm_cdr(sptr[4]);
3363 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3364 }
3365 } else {
3366 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3367 sptr[0] = a;
3368 sptr[1] = a;
3369 } else {
3370 lbm_set_cdr(sptr[1], a);
3371 sptr[1] = a;
3372 }
3373
3374 if (sptr[3] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3375 lbm_set_cdr(b, sptr[4]);
3376 lbm_set_cdr(sptr[1], b);
3377 ctx->r = sptr[0];
3378 lbm_stack_drop(&ctx->K, 9);
3379 ctx->app_cont = true1;
3380 return;
3381 } else {
3382 a = sptr[3];
3383 sptr[3] = lbm_cdr(sptr[3]);
3384 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3385 }
3386 }
3387 lbm_set_cdr(a, b);
3388 sptr[2] = a;
3389
3390 lbm_value par1 = sptr[7];
3391 lbm_value par2 = sptr[8];
3392 lbm_value cmp_body = sptr[5];
3393 lbm_value cmp_env = sptr[6];
3394 // Environment should be preallocated already at this point
3395 // and the operations below should never need GC.
3396 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3397 lbm_value new_env = lbm_env_set(new_env0, par2, lbm_car(b));
3398 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3399 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3400 }
3401 cmp_env = new_env;
3402
3403 stack_reserve(ctx,1)[0] = MERGE_REST(((43) << 2) | 0xF8000001u);
3404 ctx->curr_exp = cmp_body;
3405 ctx->curr_env = cmp_env;
3406}
3407
3408// merge_layer stack contents
3409// s[sp-9] = cmp
3410// s[sp-8] = cmp_env
3411// s[sp-7] = par1
3412// s[sp-6] = par2
3413// s[sp-5] = acc - first cell
3414// s[sp-4] = acc - last cell
3415// s[sp-3] = rest;
3416// s[sp-2] = layer
3417// s[sp-1] = length or original list
3418//
3419// ctx->r merged sublist
3420static void cont_merge_layer(eval_context_t *ctx) {
3421 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3422 lbm_int layer = lbm_dec_i(sptr[7]);
3423 lbm_int len = lbm_dec_i(sptr[8]);
3424
3425 lbm_value r_curr = ctx->r;
3426 while (lbm_is_cons(r_curr)) {
3427 lbm_value next = lbm_cdr(r_curr);
3428 if (next == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3429 break;
3430 }
3431 r_curr = next;
3432 }
3433
3434 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3435 sptr[4] = ctx->r;
3436 sptr[5] = r_curr;
3437 } else {
3438 lbm_set_cdr(sptr[5], ctx->r); // accumulate merged sublists.
3439 sptr[5] = r_curr;
3440 }
3441
3442 lbm_value layer_rest = sptr[6];
3443 // switch layer or done ?
3444 if (layer_rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3445 if (layer * 2 >= len) {
3446 ctx->r = sptr[4];
3447 ctx->app_cont = true1;
3448 lbm_stack_drop(&ctx->K, 9);
3449 return;
3450 } else {
3451 // Setup for merges of the next layer
3452 layer = layer * 2;
3453 sptr[7] = lbm_enc_i(layer);
3454 layer_rest = sptr[4]; // continue on the accumulation of all sublists.
3455 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3456 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3457 }
3458 }
3459 // merge another sublist based on current layer.
3460 lbm_value a_list = layer_rest;
3461 // build sublist a
3462 lbm_value curr = layer_rest;
3463 for (int i = 0; i < layer-1; i ++) {
3464 if (lbm_is_cons(curr)) {
3465 curr = lbm_cdr(curr);
3466 } else {
3467 break;
3468 }
3469 }
3470 layer_rest = lbm_cdr(curr);
3471 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3472
3473 lbm_value b_list = layer_rest;
3474 // build sublist b
3475 curr = layer_rest;
3476 for (int i = 0; i < layer-1; i ++) {
3477 if (lbm_is_cons(curr)) {
3478 curr = lbm_cdr(curr);
3479 } else {
3480 break;
3481 }
3482 }
3483 layer_rest = lbm_cdr(curr);
3484 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3485
3486 sptr[6] = layer_rest;
3487
3488 if (b_list == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3489 stack_reserve(ctx,1)[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3490 ctx->r = a_list;
3491 ctx->app_cont = true1;
3492 return;
3493 }
3494 // Set up for a merge of sublists.
3495
3496 lbm_value a_rest = lbm_cdr(a_list);
3497 lbm_value b_rest = lbm_cdr(b_list);
3498 lbm_value a = a_list;
3499 lbm_value b = b_list;
3500 lbm_set_cdr(a, b);
3501 // Terminating the b list would be incorrect here
3502 // if there was any chance that the environment update below
3503 // performs GC.
3504 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3505
3506 lbm_value cmp_body = sptr[0];
3507 lbm_value cmp_env = sptr[1];
3508 lbm_value par1 = sptr[2];
3509 lbm_value par2 = sptr[3];
3510 // Environment should be preallocated already at this point
3511 // and the operations below should never need GC.
3512 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3513 lbm_value new_env = lbm_env_set(cmp_env, par2, lbm_car(b));
3514 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3515 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3516 }
3517 cmp_env = new_env;
3518
3519 lbm_uint *merge_cont = stack_reserve(ctx, 11);
3520 merge_cont[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3521 merge_cont[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3522 merge_cont[2] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3523 merge_cont[3] = a;
3524 merge_cont[4] = a_rest;
3525 merge_cont[5] = b_rest;
3526 merge_cont[6] = cmp_body;
3527 merge_cont[7] = cmp_env;
3528 merge_cont[8] = par1;
3529 merge_cont[9] = par2;
3530 merge_cont[10] = MERGE_REST(((43) << 2) | 0xF8000001u);
3531 ctx->curr_exp = cmp_body;
3532 ctx->curr_env = cmp_env;
3533 return;
3534}
3535
3536/****************************************************/
3537/* READER */
3538
3539static void read_finish(lbm_char_channel_t *str, eval_context_t *ctx) {
3540
3541 /* Tokenizer reached "end of file"
3542 The parser could be in a state where it needs
3543 more tokens to correctly finish an expression.
3544
3545 Three cases
3546 1. The program / expression is malformed and the context should die.
3547 2. We are finished reading a program and should close off the
3548 internal representation with a closing parenthesis. Then
3549 apply continuation.
3550 3. We are finished reading an expression and should
3551 apply the continuation.
3552
3553 In case 3, we should find the READ_DONE at sp - 1.
3554 In case 2, we should find the READ_DONE at sp - 5.
3555
3556 */
3557
3558 if (lbm_is_symbol(ctx->r)) {
3559 lbm_uint sym_val = lbm_dec_sym(ctx->r);
3560 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
3561 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
3562 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3563 }
3564 }
3565
3566 if (ctx->K.data[ctx->K.sp-1] == READ_DONE(((20) << 2) | 0xF8000001u) &&
3567 lbm_dec_u(ctx->K.data[ctx->K.sp-3]) == 0) {
3568 /* successfully finished reading an expression (CASE 3) */
3569 ctx->app_cont = true1;
3570 } else if (ctx->K.sp > 4 && ctx->K.data[ctx->K.sp - 4] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3571 lbm_value env;
3572 lbm_value s;
3573 lbm_value sym;
3574 lbm_pop_3(&ctx->K, &sym, &env, &s);
3575 ctx->curr_env = env;
3576 ctx->app_cont = true1; // Program evaluated and result is in ctx->r.
3577 } else if (ctx->K.sp > 5 && ctx->K.data[ctx->K.sp - 5] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3578 /* successfully finished reading a program (CASE 2) */
3579 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3580 ctx->app_cont = true1;
3581 } else {
3582 /* Parsing failed */
3583 if (lbm_channel_row(str) == 1 &&
3584 lbm_channel_column(str) == 1 ){
3585 // eof at empty stream.
3586 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3587 ctx->app_cont = true1;
3588 } else {
3589 lbm_set_error_reason((char*)lbm_error_str_parse_eof);
3590 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3591 }
3592 lbm_channel_reader_close(str);
3593 }
3594}
3595
3596/* cont_read_next_token
3597 sp-2 : Stream
3598 sp-1 : Grab row
3599*/
3600static void cont_read_next_token(eval_context_t *ctx) {
3601 lbm_value *sptr = get_stack_ptr(ctx, 2);
3602 lbm_value stream = sptr[0];
3603 lbm_value grab_row0 = sptr[1];
3604
3605 lbm_char_channel_t *chan = lbm_dec_channel(stream);
3606 if (chan == NULL((void*)0) || chan->state == NULL((void*)0)) {
3607 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3608 }
3609
3610 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3611 lbm_stack_drop(&ctx->K, 2);
3612 read_finish(chan, ctx);
3613 return;
3614 }
3615 /* Eat whitespace and comments */
3616 if (!tok_clean_whitespace(chan)) {
3617 sptr[0] = stream;
3618 sptr[1] = lbm_enc_u(0);
3619 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3620 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3621 return;
3622 }
3623 /* After eating whitespace we may be at end of file/stream */
3624 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3625 lbm_stack_drop(&ctx->K, 2);
3626 read_finish(chan, ctx);
3627 return;
3628 }
3629
3630 if (lbm_dec_u(grab_row0)) {
3631 ctx->row0 = (int32_t)lbm_channel_row(chan);
3632 }
3633
3634 /* Attempt to extract tokens from the character stream */
3635 int n = 0;
3636 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3637 unsigned int string_len = 0;
3638
3639 /*
3640 * SYNTAX
3641 */
3642 uint32_t match;
3643 n = tok_syntax(chan, &match);
3644 if (n > 0) {
3645 if (!lbm_channel_drop(chan, (unsigned int)n)) {
3646 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3647 }
3648 ctx->app_cont = true1;
3649 lbm_uint do_next = 0;
3650 switch(match) {
3651 case TOKOPENPAR1u: {
3652 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3653 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3654 lbm_value *rptr = stack_reserve(ctx,5);
3655 rptr[0] = stream;
3656 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3657 rptr[2] = stream;
3658 rptr[3] = lbm_enc_u(0);
3659 rptr[4] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3660 ctx->r = ENC_SYM_OPENPAR(((0x70) << 4) | 0x00000000u);
3661 } return;
3662 case TOKCLOSEPAR2u: {
3663 lbm_stack_drop(&ctx->K, 2);
3664 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3665 } return;
3666 case TOKOPENBRACK3u: {
3667 sptr[0] = stream;
3668 sptr[1] = READ_START_ARRAY(((24) << 2) | 0xF8000001u);
3669 lbm_value *rptr = stack_reserve(ctx, 3);
3670 rptr[0] = stream;
3671 rptr[1] = lbm_enc_u(0);
3672 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3673 ctx->r = ENC_SYM_OPENBRACK(((0x80) << 4) | 0x00000000u);
3674 } return;
3675 case TOKCLOSEBRACK4u:
3676 lbm_stack_drop(&ctx->K, 2);
3677 ctx->r = ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u);
3678 return;
3679 case TOKDOT5u:
3680 lbm_stack_drop(&ctx->K, 2);
3681 ctx->r = ENC_SYM_DOT(((0x76) << 4) | 0x00000000u);
3682 return;
3683 case TOKDONTCARE6u:
3684 lbm_stack_drop(&ctx->K, 2);
3685 ctx->r = ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u);
3686 return;
3687 case TOKQUOTE7u:
3688 do_next = READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u);
3689 break;
3690 case TOKBACKQUOTE8u: {
3691 sptr[0] = QQ_EXPAND_START(((35) << 2) | 0xF8000001u);
3692 sptr[1] = stream;
3693 lbm_value *rptr = stack_reserve(ctx, 2);
3694 rptr[0] = lbm_enc_u(0);
3695 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3696 ctx->app_cont = true1;
3697 } return;
3698 case TOKCOMMAAT9u:
3699 do_next = READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u);
3700 break;
3701 case TOKCOMMA10u:
3702 do_next = READ_COMMA_RESULT(((23) << 2) | 0xF8000001u);
3703 break;
3704 case TOKMATCHANY11u:
3705 lbm_stack_drop(&ctx->K, 2);
3706 ctx->r = ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u);
3707 return;
3708 case TOKOPENCURL12u: {
3709 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3710 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3711 lbm_value *rptr = stack_reserve(ctx,2);
3712 rptr[0] = stream;
3713 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3714 ctx->r = ENC_SYM_PROGN(((0x102) << 4) | 0x00000000u);
3715 } return;
3716 case TOKCLOSECURL13u:
3717 lbm_stack_drop(&ctx->K, 2);
3718 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3719 return;
3720 case TOKCONSTSTART14u: /* fall through */
3721 case TOKCONSTEND15u:
3722 case TOKCONSTSYMSTR16u: {
3723 if (match == TOKCONSTSTART14u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3724 if (match == TOKCONSTEND15u) ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3725 if (match == TOKCONSTSYMSTR16u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04;
3726 sptr[0] = stream;
3727 sptr[1] = lbm_enc_u(0);
3728 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3729 ctx->app_cont = true1;
3730 } return;
3731 default:
3732 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3733 }
3734 sptr[0] = do_next;
3735 sptr[1] = stream;
3736 lbm_value *rptr = stack_reserve(ctx, 2);
3737 rptr[0] = lbm_enc_u(0);
3738 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3739 ctx->app_cont = true1;
3740 return;
3741 } else if (n < 0) goto retry_token;
3742
3743 /*
3744 * STRING
3745 */
3746 n = tok_string(chan, &string_len);
3747 if (n >= 2) {
3748 lbm_channel_drop(chan, (unsigned int)n);
3749 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3750 gc();
3751 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3752 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3753 return; // dead return but static analysis does not know that.
3754 }
3755 }
3756 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(res);
3757 char *data = (char*)arr->data;
3758 memset(data,0, string_len + 1);
3759 memcpy(data, tokpar_sym_str, string_len);
3760 lbm_stack_drop(&ctx->K, 2);
3761 ctx->r = res;
3762 ctx->app_cont = true1;
3763 return;
3764 } else if (n < 0) goto retry_token;
3765
3766 /*
3767 * FLOAT
3768 */
3769 token_float f_val;
3770 n = tok_double(chan, &f_val);
3771 if (n > 0) {
3772 lbm_channel_drop(chan, (unsigned int) n);
3773 switch(f_val.type) {
3774 case TOKTYPEF32107u:
3775 WITH_GC(res, lbm_enc_float((float)f_val.value))(res) = (lbm_enc_float((float)f_val.value)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (lbm_enc_float((float)f_val.value));
if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
3776 break;
3777 case TOKTYPEF64108u:
3778 res = lbm_enc_double(f_val.value);
3779 break;
3780 default:
3781 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3782 }
3783 lbm_stack_drop(&ctx->K, 2);
3784 ctx->r = res;
3785 ctx->app_cont = true1;
3786 return;
3787 } else if (n < 0) goto retry_token;
3788
3789 /*
3790 * INTEGER
3791 */
3792 token_int int_result;
3793 n = tok_integer(chan, &int_result);
3794 if (n > 0) {
3795 lbm_channel_drop(chan, (unsigned int)n);
3796 switch(int_result.type) {
3797 case TOKTYPEBYTE100u:
3798 res = lbm_enc_char((uint8_t)(int_result.negative ? -int_result.value : int_result.value));
3799 break;
3800 case TOKTYPEI101u:
3801 res = lbm_enc_i((lbm_int)(int_result.negative ? -int_result.value : int_result.value));
3802 break;
3803 case TOKTYPEU102u:
3804 res = lbm_enc_u((lbm_uint)(int_result.negative ? -int_result.value : int_result.value));
3805 break;
3806 case TOKTYPEI32103u:
3807 WITH_GC(res, lbm_enc_i32((int32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i32((int32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i32((int32_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3808 break;
3809 case TOKTYPEU32104u:
3810 WITH_GC(res,lbm_enc_u32((uint32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u32((uint32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u32((uint32_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3811 break;
3812 case TOKTYPEI64105u:
3813 WITH_GC(res,lbm_enc_i64((int64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i64((int64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i64((int64_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3814 break;
3815 case TOKTYPEU64106u:
3816 WITH_GC(res,lbm_enc_u64((uint64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u64((uint64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u64((uint64_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3817 break;
3818 default:
3819 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3820 }
3821 lbm_stack_drop(&ctx->K, 2);
3822 ctx->r = res;
3823 ctx->app_cont = true1;
3824 return;
3825 } else if (n < 0) goto retry_token;
3826
3827 /*
3828 * SYMBOL
3829 */
3830 n = tok_symbol(chan);
3831 if (n > 0) {
3832 lbm_channel_drop(chan, (unsigned int) n);
3833 lbm_uint symbol_id;
3834 if (lbm_get_symbol_by_name(tokpar_sym_str, &symbol_id)) {
3835 res = lbm_enc_sym(symbol_id);
3836 } else {
3837 int r = 0;
3838 if (n > 4 &&
3839 tokpar_sym_str[0] == 'e' &&
3840 tokpar_sym_str[1] == 'x' &&
3841 tokpar_sym_str[2] == 't' &&
3842 tokpar_sym_str[3] == '-') {
3843 lbm_uint ext_id;
3844 lbm_uint ext_name_len = (lbm_uint)n + 1;
3845 char *ext_name = lbm_malloc(ext_name_len);
3846 if (!ext_name) {
3847 gc();
3848 ext_name = lbm_malloc(ext_name_len);
3849 }
3850 if (ext_name) {
3851 memcpy(ext_name, tokpar_sym_str, ext_name_len);
3852 r = lbm_add_extension(ext_name, lbm_extensions_default);
3853 if (!lbm_lookup_extension_id(ext_name, &ext_id)) {
3854 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3855 }
3856 symbol_id = ext_id;
3857 } else {
3858 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3859 }
3860 } else {
3861 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04 &&
3862 ctx->flags & EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08) {
3863 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id, true1); //flash
3864 if (!r) {
3865 lbm_set_error_reason((char*)lbm_error_str_flash_error);
3866 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3867 }
3868 } else {
3869 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3870 if (!r) {
3871 gc();
3872 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3873 }
3874 }
3875 }
3876 if (r) {
3877 res = lbm_enc_sym(symbol_id);
3878 } else {
3879 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3880 }
3881 }
3882 lbm_stack_drop(&ctx->K, 2);
3883 ctx->r = res;
3884 ctx->app_cont = true1;
3885 return;
3886 } else if (n == TOKENIZER_NEED_MORE-1) {
3887 goto retry_token;
3888 } else if (n <= TOKENIZER_STRING_ERROR-2) {
3889 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3890 }
3891
3892 /*
3893 * CHAR
3894 */
3895 char c_val;
3896 n = tok_char(chan, &c_val);
3897 if(n > 0) {
3898 lbm_channel_drop(chan,(unsigned int) n);
3899 lbm_stack_drop(&ctx->K, 2);
3900 ctx->r = lbm_enc_char((uint8_t)c_val);
3901 ctx->app_cont = true1;
3902 return;
3903 }else if (n < 0) goto retry_token;
3904
3905 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3906
3907 retry_token:
3908 if (n == TOKENIZER_NEED_MORE-1) {
3909 sptr[0] = stream;
3910 sptr[1] = lbm_enc_u(0);
3911 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3912 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3913 return;
3914 }
3915 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3916}
3917
3918static void cont_read_start_array(eval_context_t *ctx) {
3919 lbm_value *sptr = get_stack_ptr(ctx, 1);
3920 lbm_value stream = sptr[0];
3921
3922 lbm_char_channel_t *str = lbm_dec_channel(stream);
3923 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
3924 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3925 }
3926
3927 lbm_uint num_free = lbm_memory_longest_free();
3928 lbm_uint initial_size = (lbm_uint)((float)num_free * 0.9);
3929 if (initial_size == 0) {
3930 gc();
3931 num_free = lbm_memory_longest_free();
3932 initial_size = (lbm_uint)((float)num_free * 0.9);
3933 if (initial_size == 0) {
3934 lbm_channel_reader_close(str);
3935 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3936 }
3937 }
3938
3939 if (lbm_is_number(ctx->r)) {
3940 lbm_value array;
3941 initial_size = sizeof(lbm_uint) * initial_size;
3942
3943 if (!lbm_heap_allocate_array(&array, initial_size)) {
3944 lbm_set_error_reason("Out of memory while reading.");
3945 lbm_channel_reader_close(str);
3946 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3947 // NOTE: If array is not created evaluation ends here.
3948 // Static analysis seems unaware.
3949 }
3950
3951 sptr[0] = array;
3952 lbm_value *rptr = stack_reserve(ctx, 4);
3953 rptr[0] = lbm_enc_u(initial_size);
3954 rptr[1] = lbm_enc_u(0);
3955 rptr[2] = stream;
3956 rptr[3] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3957 ctx->app_cont = true1;
3958 } else {
3959 lbm_channel_reader_close(str);
3960 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3961 }
3962}
3963
3964static void cont_read_append_array(eval_context_t *ctx) {
3965 lbm_uint *sptr = get_stack_ptr(ctx, 4);
3966
3967 lbm_value array = sptr[0];
3968 lbm_value size = lbm_dec_as_u32(sptr[1]);
3969 lbm_value ix = lbm_dec_as_u32(sptr[2]);
3970 lbm_value stream = sptr[3];
3971
3972 if (ix >= (size - 1)) {
3973 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3974 }
3975
3976 // get_car can return nil. Whose value is 0!
3977 // So static Analysis is right about this being a potential NULL pointer.
3978 // However, if the array was created correcly to begin with, it should be fine.
3979 lbm_value arr_car = get_car(array);
3980 lbm_array_header_t *arr = (lbm_array_header_t*)arr_car;
3981
3982 if (lbm_is_number(ctx->r)) {
3983 ((uint8_t*)arr->data)[ix] = (uint8_t)lbm_dec_as_u32(ctx->r);
3984
3985 sptr[2] = lbm_enc_u(ix + 1);
3986 lbm_value *rptr = stack_reserve(ctx, 4);
3987 rptr[0] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3988 rptr[1] = stream;
3989 rptr[2] = lbm_enc_u(0);
3990 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3991 ctx->app_cont = true1;
3992 } else if (lbm_is_symbol(ctx->r) && ctx->r == ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u)) {
3993 lbm_uint array_size = ix / sizeof(lbm_uint);
3994
3995 if (ix % sizeof(lbm_uint) != 0) {
3996 array_size = array_size + 1;
3997 }
3998 lbm_memory_shrink((lbm_uint*)arr->data, array_size);
3999 arr->size = ix;
4000 lbm_stack_drop(&ctx->K, 4);
4001 ctx->r = array;
4002 ctx->app_cont = true1;
4003 } else {
4004 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
4005 }
4006}
4007
4008static void cont_read_append_continue(eval_context_t *ctx) {
4009 lbm_value *sptr = get_stack_ptr(ctx, 3);
4010
4011 lbm_value first_cell = sptr[0];
4012 lbm_value last_cell = sptr[1];
4013 lbm_value stream = sptr[2];
4014
4015 lbm_char_channel_t *str = lbm_dec_channel(stream);
4016 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4017 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4018 }
4019
4020 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4021
4022 switch(ctx->r) {
4023 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4024 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4025 lbm_set_cdr(last_cell, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate the list
4026 ctx->r = first_cell;
4027 } else {
4028 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4029 }
4030 lbm_stack_drop(&ctx->K, 3);
4031 /* Skip reading another token and apply the continuation */
4032 ctx->app_cont = true1;
4033 return;
4034 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4035 lbm_value *rptr = stack_reserve(ctx, 4);
4036 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4037 rptr[1] = stream;
4038 rptr[2] = lbm_enc_u(0);
4039 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4040 ctx->app_cont = true1;
4041 } return;
4042 }
4043 }
4044 lbm_value new_cell = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4045 if (lbm_is_symbol_merror(new_cell)) {
4046 lbm_channel_reader_close(str);
4047 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4048 return;
4049 }
4050 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4051 lbm_set_cdr(last_cell, new_cell);
4052 last_cell = new_cell;
4053 } else {
4054 first_cell = last_cell = new_cell;
4055 }
4056 sptr[0] = first_cell;
4057 sptr[1] = last_cell;
4058 sptr[2] = stream; // unchanged.
4059 lbm_value *rptr = stack_reserve(ctx, 4);
4060 rptr[0] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
4061 rptr[1] = stream;
4062 rptr[2] = lbm_enc_u(0);
4063 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4064 ctx->app_cont = true1;
4065}
4066
4067static void cont_read_eval_continue(eval_context_t *ctx) {
4068 lbm_value env;
4069 lbm_value stream;
4070 lbm_pop_2(&ctx->K, &env, &stream);
4071
4072 lbm_char_channel_t *str = lbm_dec_channel(stream);
4073 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4074 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4075 }
4076
4077 ctx->row1 = (lbm_int)str->row(str);
4078
4079 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4080
4081 switch(ctx->r) {
4082 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4083 ctx->app_cont = true1;
4084 return;
4085 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4086 // This case is a bit mysterious.
4087 // A dot, may in reality be an error in this location.
4088 lbm_value *rptr = stack_reserve(ctx, 4);
4089 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4090 rptr[1] = stream;
4091 rptr[2] = lbm_enc_u(0);
4092 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4093 ctx->app_cont = true1;
4094 } return;
4095 }
4096 }
4097
4098 lbm_value *rptr = stack_reserve(ctx, 6);
4099 rptr[0] = stream;
4100 rptr[1] = env;
4101 rptr[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
4102 rptr[3] = stream;
4103 rptr[4] = lbm_enc_u(1);
4104 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4105 rptr[6] = lbm_enc_u(ctx->flags);
4106 rptr[7] = POP_READER_FLAGS(((47) << 2) | 0xF8000001u);
4107 ctx->curr_env = env;
4108 ctx->curr_exp = ctx->r;
4109}
4110
4111static void cont_read_expect_closepar(eval_context_t *ctx) {
4112 lbm_value res;
4113 lbm_value stream;
4114
4115 lbm_pop_2(&ctx->K, &res, &stream);
4116
4117 lbm_char_channel_t *str = lbm_dec_channel(stream);
4118 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4119 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4120 }
4121
4122 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4123 ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u)) {
4124 ctx->r = res;
4125 ctx->app_cont = true1;
4126 } else {
4127 lbm_channel_reader_close(str);
4128 lbm_set_error_reason((char*)lbm_error_str_parse_close);
4129 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4130 }
4131}
4132
4133static void cont_read_dot_terminate(eval_context_t *ctx) {
4134 lbm_value *sptr = get_stack_ptr(ctx, 3);
4135
4136 lbm_value first_cell = sptr[0];
4137 lbm_value last_cell = sptr[1];
4138 lbm_value stream = sptr[2];
4139
4140 lbm_char_channel_t *str = lbm_dec_channel(stream);
4141 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4142 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4143 }
4144
4145 lbm_stack_drop(&ctx->K ,3);
4146
4147 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4148 (ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u) ||
4149 ctx->r == ENC_SYM_DOT(((0x76) << 4) | 0x00000000u))) {
4150 lbm_channel_reader_close(str);
4151 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4152 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4153 } else {
4154 if (lbm_is_cons(last_cell)) {
4155 lbm_set_cdr(last_cell, ctx->r);
4156 ctx->r = first_cell;
4157 lbm_value *rptr = stack_reserve(ctx, 6);
4158 rptr[0] = stream;
4159 rptr[1] = ctx->r;
4160 rptr[2] = READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u);
4161 rptr[3] = stream;
4162 rptr[4] = lbm_enc_u(0);
4163 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4164 ctx->app_cont = true1;
4165 } else {
4166 lbm_channel_reader_close(str);
4167 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4168 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4169 }
4170 }
4171}
4172
4173static void cont_read_done(eval_context_t *ctx) {
4174 lbm_value stream;
4175 lbm_value f_val;
4176 lbm_pop_2(&ctx->K, &stream ,&f_val);
4177
4178 uint32_t flags = lbm_dec_as_u32(f_val);
4179 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4180 ctx->flags |= (flags & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4181
4182 lbm_char_channel_t *str = lbm_dec_channel(stream);
4183 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4184 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4185 }
4186
4187 lbm_channel_reader_close(str);
4188 if (lbm_is_symbol(ctx->r)) {
4189 lbm_uint sym_val = lbm_dec_sym(ctx->r);
4190 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
4191 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
4192 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4193 }
4194 }
4195
4196 ctx->row0 = -1;
4197 ctx->row1 = -1;
4198 ctx->app_cont = true1;
4199}
4200
4201static void cont_read_quote_result(eval_context_t *ctx) {
4202 lbm_value cell;
4203 WITH_GC(cell, lbm_heap_allocate_list_init(2,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4204 ENC_SYM_QUOTE,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4205 ctx->r))(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
};
4206 ctx->r = cell;
4207 ctx->app_cont = true1;
4208}
4209
4210static void cont_read_commaat_result(eval_context_t *ctx) {
4211 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4212 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4213 ctx->r = cell1;
4214 ctx->app_cont = true1;
4215}
4216
4217static void cont_read_comma_result(eval_context_t *ctx) {
4218 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u),ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4219 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4220 ctx->r = cell1;
4221 ctx->app_cont = true1;
4222}
4223
4224static void cont_application_start(eval_context_t *ctx) {
4225
4226 /* sptr[0] = env
4227 * sptr[1] = args
4228 * ctx->r = function
4229 */
4230
4231 if (lbm_is_symbol(ctx->r)) {
4232 stack_reserve(ctx,1)[0] = lbm_enc_u(0);
4233 cont_application_args(ctx);
4234 } else if (lbm_is_cons(ctx->r)) {
4235 lbm_uint *sptr = get_stack_ptr(ctx, 2);
4236 lbm_value args = (lbm_value)sptr[1];
4237 switch (get_car(ctx->r)) {
4238 case ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u): {
4239 lbm_value cl[3];
4240 extract_n(get_cdr(ctx->r), cl, 3);
4241 lbm_value arg_env = (lbm_value)sptr[0];
4242 lbm_value arg0, arg_rest;
4243 get_car_and_cdr(args, &arg0, &arg_rest);
4244 sptr[1] = cl[CLO_BODY1];
4245 bool_Bool a_nil = lbm_is_symbol_nil(args);
4246 bool_Bool p_nil = lbm_is_symbol_nil(cl[CLO_PARAMS0]);
4247 lbm_value *reserved = stack_reserve(ctx, 4);
4248
4249 if (!a_nil && !p_nil) {
4250 reserved[0] = cl[CLO_ENV2];
4251 reserved[1] = cl[CLO_PARAMS0];
4252 reserved[2] = arg_rest;
4253 reserved[3] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
4254 ctx->curr_exp = arg0;
4255 ctx->curr_env = arg_env;
4256 } else if (a_nil && p_nil) {
4257 // No params, No args
4258 lbm_stack_drop(&ctx->K, 6);
4259 ctx->curr_exp = cl[CLO_BODY1];
4260 ctx->curr_env = cl[CLO_ENV2];
4261 } else if (p_nil) {
4262 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), cl[CLO_ENV2]);
4263 reserved[0] = rest_binder;
4264 reserved[1] = get_cdr(args);
4265 reserved[2] = get_car(rest_binder);
4266 reserved[3] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
4267 ctx->curr_exp = get_car(args);
4268 ctx->curr_env = arg_env;
4269 } else {
4270 lbm_set_error_reason((char*)lbm_error_str_num_args);
4271 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->r);
4272 }
4273 } break;
4274 case ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u):{
4275 /* Continuation created using call-cc.
4276 * ((SYM_CONT . cont-array) arg0 )
4277 */
4278 lbm_value c = get_cdr(ctx->r); /* should be the continuation array*/
4279
4280 if (!lbm_is_lisp_array_r(c)) {
4281 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4282 }
4283
4284 lbm_uint arg_count = lbm_list_length(args);
4285 lbm_value arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4286 switch (arg_count) {
4287 case 0:
4288 arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4289 break;
4290 case 1:
4291 arg = get_car(args);
4292 break;
4293 default:
4294 lbm_set_error_reason((char*)lbm_error_str_num_args);
4295 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4296 }
4297 lbm_stack_clear(&ctx->K);
4298
4299 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(c);
4300
4301 ctx->K.sp = arr->size / sizeof(lbm_uint);
4302 memcpy(ctx->K.data, arr->data, arr->size);
4303
4304 ctx->curr_exp = arg;
4305 break;
4306 }
4307 case ENC_SYM_MACRO(((0x10D) << 4) | 0x00000000u):{
4308 /*
4309 * Perform macro expansion.
4310 * Macro expansion is really just evaluation in an
4311 * environment augmented with the unevaluated expressions passed
4312 * as arguments.
4313 */
4314 lbm_value env = (lbm_value)sptr[0];
4315
4316 lbm_value curr_param = get_cadr(ctx->r);
4317 lbm_value curr_arg = args;
4318 lbm_value expand_env = env;
4319 while (lbm_is_cons(curr_param) &&
4320 lbm_is_cons(curr_arg)) {
4321 lbm_value car_curr_param, cdr_curr_param;
4322 lbm_value car_curr_arg, cdr_curr_arg;
4323 get_car_and_cdr(curr_param, &car_curr_param, &cdr_curr_param);
4324 get_car_and_cdr(curr_arg, &car_curr_arg, &cdr_curr_arg);
4325
4326 lbm_value entry = cons_with_gc(car_curr_param, car_curr_arg, expand_env);
4327 lbm_value aug_env = cons_with_gc(entry, expand_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4328 expand_env = aug_env;
4329
4330 curr_param = cdr_curr_param;
4331 curr_arg = cdr_curr_arg;
4332 }
4333 /* Two rounds of evaluation is performed.
4334 * First to instantiate the arguments into the macro body.
4335 * Second to evaluate the resulting program.
4336 */
4337 sptr[1] = EVAL_R(((11) << 2) | 0xF8000001u);
4338 lbm_value exp = get_cadr(get_cdr(ctx->r));
4339 ctx->curr_exp = exp;
4340 ctx->curr_env = expand_env;
4341 } break;
4342 default:
4343 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4344 }
4345 } else {
4346 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4347 }
4348}
4349
4350static void cont_eval_r(eval_context_t* ctx) {
4351 lbm_value env;
4352 lbm_pop(&ctx->K, &env);
4353 ctx->curr_exp = ctx->r;
4354 ctx->curr_env = env;
4355}
4356
4357static void cont_progn_var(eval_context_t* ctx) {
4358
4359 lbm_value key;
4360 lbm_value env;
4361
4362 lbm_pop_2(&ctx->K, &key, &env);
4363
4364 if (fill_binding_location(key, ctx->r, env) < 0) {
4365 lbm_set_error_reason("Incorrect type of name/key in let-binding");
4366 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
4367 }
4368
4369 ctx->app_cont = true1;
4370}
4371
4372static void cont_setq(eval_context_t *ctx) {
4373 lbm_value sym;
4374 lbm_value env;
4375 lbm_pop_2(&ctx->K, &sym, &env);
4376 lbm_value res;
4377 WITH_GC(res, perform_setvar(sym, ctx->r, env))(res) = (perform_setvar(sym, ctx->r, env)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (perform_setvar(sym, ctx->r, env)
); if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
4378 ctx->r = res;
4379 ctx->app_cont = true1;
4380}
4381
4382lbm_flash_status request_flash_storage_cell(lbm_value val, lbm_value *res) {
4383
4384 lbm_value flash_cell;
4385 lbm_flash_status s = lbm_allocate_const_cell(&flash_cell);
4386 if (s != LBM_FLASH_WRITE_OK)
4387 return s;
4388 lbm_value new_val = val;
4389 new_val &= ~LBM_PTR_VAL_MASK0x03FFFFFCu; // clear the value part of the ptr
4390 new_val |= (flash_cell & LBM_PTR_VAL_MASK0x03FFFFFCu);
4391 new_val |= LBM_PTR_TO_CONSTANT_BIT0x04000000u;
4392 *res = new_val;
4393 return s;
4394}
4395
4396static void cont_move_to_flash(eval_context_t *ctx) {
4397
4398 lbm_value args;
4399 lbm_pop(&ctx->K, &args);
4400
4401 if (lbm_is_symbol_nil(args)) {
4402 // Done looping over arguments. return true.
4403 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
4404 ctx->app_cont = true1;
4405 return;
4406 }
4407
4408 lbm_value first_arg, rest;
4409 get_car_and_cdr(args, &first_arg, &rest);
4410
4411 lbm_value val;
4412 if (lbm_is_symbol(first_arg) && lbm_global_env_lookup(&val, first_arg)) {
4413 // Prepare to copy the rest of the arguments when done with first.
4414 lbm_value *rptr = stack_reserve(ctx, 2);
4415 rptr[0] = rest;
4416 rptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
4417 if (lbm_is_ptr(val) &&
4418 (!(val & LBM_PTR_TO_CONSTANT_BIT0x04000000u))) {
4419 lbm_value * rptr1 = stack_reserve(ctx, 3);
4420 rptr1[0] = first_arg;
4421 rptr1[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
4422 rptr1[2] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4423 ctx->r = val;
4424 }
4425 ctx->app_cont = true1;
4426 return;
4427 }
4428 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4429}
4430
4431static void cont_move_val_to_flash_dispatch(eval_context_t *ctx) {
4432
4433 lbm_value val = ctx->r;
4434
4435 if (lbm_is_cons(val)) {
4436 lbm_value *rptr = stack_reserve(ctx, 5);
4437 rptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // fst cell of list
4438 rptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last cell of list
4439 rptr[2] = get_cdr(val);
4440 rptr[3] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4441 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4442 ctx->r = get_car(val);
4443 ctx->app_cont = true1;
4444 return;
4445 }
4446
4447 if (lbm_is_ptr(val) && (val & LBM_PTR_TO_CONSTANT_BIT0x04000000u)) {
4448 ctx->r = val;
4449 ctx->app_cont = true1;
4450 return;
4451 }
4452
4453 if (lbm_is_ptr(val)) {
4454 lbm_cons_t *ref = lbm_ref_cell(val);
4455 if (lbm_type_of(ref->cdr) == LBM_TYPE_SYMBOL0x00000000u) {
4456 switch (ref->cdr) {
4457 case ENC_SYM_RAW_I_TYPE(((0x31) << 4) | 0x00000000u): /* fall through */
4458 case ENC_SYM_RAW_U_TYPE(((0x32) << 4) | 0x00000000u):
4459 case ENC_SYM_RAW_F_TYPE(((0x33) << 4) | 0x00000000u): {
4460 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4461 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4462 handle_flash_status(write_const_car(flash_cell, ref->car));
4463 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4464 ctx->r = flash_cell;
4465 } break;
4466 case ENC_SYM_IND_I_TYPE(((0x34) << 4) | 0x00000000u): /* fall through */
4467 case ENC_SYM_IND_U_TYPE(((0x35) << 4) | 0x00000000u):
4468 case ENC_SYM_IND_F_TYPE(((0x36) << 4) | 0x00000000u): {
4469#ifndef LBM64
4470 /* 64 bit values are in lbm mem on 32bit platforms. */
4471 lbm_uint *lbm_mem_ptr = (lbm_uint*)ref->car;
4472 lbm_uint flash_ptr;
4473
4474 handle_flash_status(lbm_write_const_raw(lbm_mem_ptr, 2, &flash_ptr));
4475 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4476 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4477 handle_flash_status(write_const_car(flash_cell, flash_ptr));
4478 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4479 ctx->r = flash_cell;
4480#else
4481 // There are no indirect types in LBM64
4482 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4483#endif
4484 } break;
4485 case ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u): {
4486 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4487 lbm_uint size = arr->size / sizeof(lbm_uint);
4488 lbm_uint flash_addr;
4489 lbm_value *arrdata = (lbm_value *)arr->data;
4490 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4491 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4492 handle_flash_status(lbm_allocate_const_raw(size, &flash_addr));
4493 lift_array_flash(flash_cell,
4494 false0,
4495 (char *)flash_addr,
4496 arr->size);
4497 // Move array contents to flash recursively
4498 lbm_value *rptr = stack_reserve(ctx, 5);
4499 rptr[0] = flash_cell;
4500 rptr[1] = lbm_enc_u(0);
4501 rptr[2] = val;
4502 rptr[3] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4503 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4504 ctx->r = arrdata[0];
4505 ctx->app_cont = true1;
4506 return;
4507 }
4508 case ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u): {
4509 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4510 // arbitrary address: flash_arr.
4511 lbm_uint flash_arr;
4512 handle_flash_status(lbm_write_const_array_padded((uint8_t*)arr->data, arr->size, &flash_arr));
4513 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4514 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4515 lift_array_flash(flash_cell,
4516 true1,
4517 (char *)flash_arr,
4518 arr->size);
4519 ctx->r = flash_cell;
4520 } break;
4521 case ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u): /* fall through */
4522 case ENC_SYM_CUSTOM_TYPE(((0x38) << 4) | 0x00000000u):
4523 lbm_set_error_reason((char *)lbm_error_str_flash_not_possible);
4524 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4525 }
4526 } else {
4527 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4528 }
4529 ctx->app_cont = true1;
4530 return;
4531 }
4532 ctx->r = val;
4533 ctx->app_cont = true1;
4534}
4535
4536static void cont_move_list_to_flash(eval_context_t *ctx) {
4537
4538 // ctx->r holds the value that should go in car
4539
4540 lbm_value *sptr = get_stack_ptr(ctx, 3);
4541
4542 lbm_value fst = sptr[0];
4543 lbm_value lst = sptr[1];
4544 lbm_value val = sptr[2];
4545
4546
4547 lbm_value new_lst = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4548 // Allocate element ptr storage after storing the element to flash.
4549 handle_flash_status(request_flash_storage_cell(lbm_enc_cons_ptr(LBM_PTR_NULL(0x03FFFFFCu >> 2)), &new_lst));
4550
4551 if (lbm_is_symbol_nil(fst)) {
4552 lst = new_lst;
4553 fst = new_lst;
4554 handle_flash_status(write_const_car(lst, ctx->r));
4555 } else {
4556 handle_flash_status(write_const_cdr(lst, new_lst)); // low before high
4557 handle_flash_status(write_const_car(new_lst, ctx->r));
4558 lst = new_lst;
4559 }
4560
4561 if (lbm_is_cons(val)) {
4562 sptr[0] = fst;
4563 sptr[1] = lst;//rest_cell;
4564 sptr[2] = get_cdr(val);
4565 lbm_value *rptr = stack_reserve(ctx, 2);
4566 rptr[0] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4567 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4568 ctx->r = get_car(val);
4569 } else {
4570 sptr[0] = fst;
4571 sptr[1] = lst;
4572 sptr[2] = CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u);
4573 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4574 ctx->r = val;
4575 }
4576 ctx->app_cont = true1;
4577}
4578
4579static void cont_close_list_in_flash(eval_context_t *ctx) {
4580 lbm_value fst;
4581 lbm_value lst;
4582 lbm_pop_2(&ctx->K, &lst, &fst);
4583 lbm_value val = ctx->r;
4584 handle_flash_status(write_const_cdr(lst, val));
4585 ctx->r = fst;
4586 ctx->app_cont = true1;
4587}
4588
4589static void cont_move_array_elts_to_flash(eval_context_t *ctx) {
4590 lbm_value *sptr = get_stack_ptr(ctx, 3);
4591 // sptr[2] = source array in RAM
4592 // sptr[1] = current index
4593 // sptr[0] = target array in flash
4594 lbm_array_header_t *src_arr = (lbm_array_header_t*)get_car(sptr[2]);
4595 lbm_uint size = src_arr->size / sizeof(lbm_uint);
4596 lbm_value *srcdata = (lbm_value *)src_arr->data;
4597
4598 lbm_array_header_t *tgt_arr = (lbm_array_header_t*)get_car(sptr[0]);
4599 lbm_uint *tgtdata = (lbm_value *)tgt_arr->data;
4600 lbm_uint ix = lbm_dec_as_u32(sptr[1]);
4601 handle_flash_status(lbm_const_write(&tgtdata[ix], ctx->r));
4602 if (ix >= size-1) {
4603 ctx->r = sptr[0];
4604 lbm_stack_drop(&ctx->K, 3);
4605 ctx->app_cont = true1;
4606 return;
4607 }
4608 sptr[1] = lbm_enc_u(ix + 1);
4609 lbm_value *rptr = stack_reserve(ctx, 2);
4610 rptr[0] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4611 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4612 ctx->r = srcdata[ix+1];
4613 ctx->app_cont = true1;
4614 return;
4615}
4616
4617static void cont_qq_expand_start(eval_context_t *ctx) {
4618 lbm_value *rptr = stack_reserve(ctx, 2);
4619 rptr[0] = ctx->r;
4620 rptr[1] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4621 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4622 ctx->app_cont = true1;
4623}
4624
4625lbm_value quote_it(lbm_value qquoted) {
4626 if (lbm_is_symbol(qquoted) &&
4627 lbm_is_special(qquoted)) return qquoted;
4628
4629 lbm_value val = cons_with_gc(qquoted, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4630 return cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4631}
4632
4633bool_Bool is_append(lbm_value a) {
4634 return (lbm_is_cons(a) &&
4635 lbm_is_symbol(get_car(a)) &&
4636 (get_car(a) == ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u)));
4637}
4638
4639lbm_value append(lbm_value front, lbm_value back) {
4640 if (lbm_is_symbol_nil(front)) return back;
4641 if (lbm_is_symbol_nil(back)) return front;
4642
4643 if (lbm_is_quoted_list(front) &&
4644 lbm_is_quoted_list(back)) {
4645 lbm_value f = get_cadr(front);
4646 lbm_value b = get_cadr(back);
4647 return quote_it(lbm_list_append(f, b));
4648 }
4649
4650 if (is_append(back) &&
4651 lbm_is_quoted_list(get_cadr(back)) &&
4652 lbm_is_quoted_list(front)) {
4653 lbm_value ql = get_cadr(back);
4654 lbm_value f = get_cadr(front);
4655 lbm_value b = get_cadr(ql);
4656
4657 lbm_value v = lbm_list_append(f, b);
4658 lbm_set_car(get_cdr(ql), v);
4659 return back;
4660 }
4661
4662 if (is_append(back)) {
4663 back = get_cdr(back);
4664 lbm_value new = cons_with_gc(front, back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4665 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), new, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4666 }
4667
4668 lbm_value t0, t1;
4669
4670 t0 = cons_with_gc(back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), front);
4671 t1 = cons_with_gc(front, t0, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4672 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), t1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4673}
4674
4675/* Bawden's qq-expand implementation
4676(define (qq-expand x)
4677 (cond ((tag-comma? x)
4678 (tag-data x))
4679 ((tag-comma-atsign? x)
4680 (error "Illegal"))
4681 ((tag-backquote? x)
4682 (qq-expand
4683 (qq-expand (tag-data x))))
4684 ((pair? x)
4685 `(append
4686 ,(qq-expand-list (car x))
4687 ,(qq-expand (cdr x))))
4688 (else `',x)))
4689 */
4690static void cont_qq_expand(eval_context_t *ctx) {
4691 lbm_value qquoted;
4692 lbm_pop(&ctx->K, &qquoted);
4693
4694 switch(lbm_type_of(qquoted)) {
4695 case LBM_TYPE_CONS0x10000000u: {
4696 lbm_value car_val = get_car(qquoted);
4697 lbm_value cdr_val = get_cdr(qquoted);
4698 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4699 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4700 ctx->r = append(ctx->r, get_car(cdr_val));
4701 ctx->app_cont = true1;
4702 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4703 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4704 error_ctx(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u));
4705 } else {
4706 lbm_value *rptr = stack_reserve(ctx, 6);
4707 rptr[0] = ctx->r;
4708 rptr[1] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4709 rptr[2] = cdr_val;
4710 rptr[3] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4711 rptr[4] = car_val;
4712 rptr[5] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4713 ctx->app_cont = true1;
4714 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4715 }
4716
4717 } break;
4718 default: {
4719 lbm_value res = quote_it(qquoted);
4720 ctx->r = append(ctx->r, res);
4721 ctx->app_cont = true1;
4722 }
4723 }
4724}
4725
4726static void cont_qq_append(eval_context_t *ctx) {
4727 lbm_value head;
4728 lbm_pop(&ctx->K, &head);
4729 ctx->r = append(head, ctx->r);
4730 ctx->app_cont = true1;
4731}
4732
4733/* Bawden's qq-expand-list implementation
4734(define (qq-expand-list x)
4735 (cond ((tag-comma? x)
4736 `(list ,(tag-data x)))
4737 ((tag-comma-atsign? x)
4738 (tag-data x))
4739 ((tag-backquote? x)
4740 (qq-expand-list
4741 (qq-expand (tag-data x))))
4742 ((pair? x)
4743 `(list
4744 (append
4745 ,(qq-expand-list (car x))
4746 ,(qq-expand (cdr x)))))
4747 (else `'(,x))))
4748*/
4749
4750static void cont_qq_expand_list(eval_context_t* ctx) {
4751 lbm_value l;
4752 lbm_pop(&ctx->K, &l);
4753
4754 ctx->app_cont = true1;
4755 switch(lbm_type_of(l)) {
4756 case LBM_TYPE_CONS0x10000000u: {
4757 lbm_value car_val = get_car(l);
4758 lbm_value cdr_val = get_cdr(l);
4759 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4760 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4761 lbm_value tl = cons_with_gc(get_car(cdr_val), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4762 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4763 ctx->r = append(ctx->r, tmp);
4764 return;
4765 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4766 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4767 ctx->r = get_car(cdr_val);
4768 return;
4769 } else {
4770 lbm_value *rptr = stack_reserve(ctx, 7);
4771 rptr[0] = QQ_LIST(((39) << 2) | 0xF8000001u);
4772 rptr[1] = ctx->r;
4773 rptr[2] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4774 rptr[3] = cdr_val;
4775 rptr[4] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4776 rptr[5] = car_val;
4777 rptr[6] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4778 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4779 }
4780
4781 } break;
4782 default: {
4783 lbm_value a_list = cons_with_gc(l, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4784 lbm_value tl = cons_with_gc(a_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4785 lbm_value tmp = cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4786 ctx->r = append(ctx->r, tmp);
4787 }
4788 }
4789}
4790
4791static void cont_qq_list(eval_context_t *ctx) {
4792 lbm_value val = ctx->r;
4793 lbm_value apnd_app = cons_with_gc(val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4794 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), apnd_app, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4795 ctx->r = tmp;
4796 ctx->app_cont = true1;
4797}
4798
4799static void cont_kill(eval_context_t *ctx) {
4800 (void) ctx;
4801 finish_ctx();
4802}
4803
4804static void cont_pop_reader_flags(eval_context_t *ctx) {
4805 lbm_value flags;
4806 lbm_pop(&ctx->K, &flags);
4807 ctx->flags = ctx->flags & ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4808 ctx->flags |= (lbm_dec_as_u32(flags) & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4809 // r is unchanged.
4810 ctx->app_cont = true1;
4811}
4812
4813static void cont_exception_handler(eval_context_t *ctx) {
4814 lbm_value *sptr = pop_stack_ptr(ctx, 2);
4815 lbm_value retval = sptr[0];
4816 lbm_value flags = sptr[1];
4817 lbm_set_car(get_cdr(retval), ctx->r);
4818 ctx->flags = flags;
4819 ctx->r = retval;
4820 ctx->app_cont = true1;
4821}
4822
4823/*********************************************************/
4824/* Continuations table */
4825typedef void (*cont_fun)(eval_context_t *);
4826
4827static const cont_fun continuations[NUM_CONTINUATIONS49] =
4828 { advance_ctx, // CONT_DONE
4829 cont_set_global_env,
4830 cont_bind_to_key_rest,
4831 cont_if,
4832 cont_progn_rest,
4833 cont_application_args,
4834 cont_and,
4835 cont_or,
4836 cont_wait,
4837 cont_match,
4838 cont_application_start,
4839 cont_eval_r,
4840 cont_resume,
4841 cont_closure_application_args,
4842 cont_exit_atomic,
4843 cont_read_next_token,
4844 cont_read_append_continue,
4845 cont_read_eval_continue,
4846 cont_read_expect_closepar,
4847 cont_read_dot_terminate,
4848 cont_read_done,
4849 cont_read_quote_result,
4850 cont_read_commaat_result,
4851 cont_read_comma_result,
4852 cont_read_start_array,
4853 cont_read_append_array,
4854 cont_map,
4855 cont_match_guard,
4856 cont_terminate,
4857 cont_progn_var,
4858 cont_setq,
4859 cont_move_to_flash,
4860 cont_move_val_to_flash_dispatch,
4861 cont_move_list_to_flash,
4862 cont_close_list_in_flash,
4863 cont_qq_expand_start,
4864 cont_qq_expand,
4865 cont_qq_append,
4866 cont_qq_expand_list,
4867 cont_qq_list,
4868 cont_kill,
4869 cont_loop,
4870 cont_loop_condition,
4871 cont_merge_rest,
4872 cont_merge_layer,
4873 cont_closure_args_rest,
4874 cont_move_array_elts_to_flash,
4875 cont_pop_reader_flags,
4876 cont_exception_handler
4877 };
4878
4879/*********************************************************/
4880/* Evaluators lookup table (special forms) */
4881typedef void (*evaluator_fun)(eval_context_t *);
4882
4883static const evaluator_fun evaluators[] =
4884 {
4885 eval_quote,
4886 eval_define,
4887 eval_progn,
4888 eval_lambda,
4889 eval_if,
4890 eval_let,
4891 eval_and,
4892 eval_or,
4893 eval_match,
4894 eval_receive,
4895 eval_receive_timeout,
4896 eval_callcc,
4897 eval_atomic,
4898 eval_selfevaluating, // macro
4899 eval_selfevaluating, // cont
4900 eval_selfevaluating, // closure
4901 eval_cond,
4902 eval_app_cont,
4903 eval_var,
4904 eval_setq,
4905 eval_move_to_flash,
4906 eval_loop,
4907 eval_trap
4908 };
4909
4910
4911/*********************************************************/
4912/* Evaluator step function */
4913
4914static void evaluation_step(void){
4915 eval_context_t *ctx = ctx_running;
4916#ifdef VISUALIZE_HEAP
4917 heap_vis_gen_image();
4918#endif
4919
4920 if (ctx->app_cont) {
4921 lbm_value k;
4922 lbm_pop(&ctx->K, &k);
4923 ctx->app_cont = false0;
4924
4925 lbm_uint decoded_k = DEC_CONTINUATION(k)(((k) & ~0xF8000001u) >> 2);
4926
4927 if (decoded_k < NUM_CONTINUATIONS49) {
4928 continuations[decoded_k](ctx);
4929 } else {
4930 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4931 }
4932 return;
4933 }
4934
4935 if (lbm_is_symbol(ctx->curr_exp)) {
4936 eval_symbol(ctx);
4937 return;
4938 }
4939 if (lbm_is_cons(ctx->curr_exp)) {
4940 lbm_cons_t *cell = lbm_ref_cell(ctx->curr_exp);
4941 lbm_value h = cell->car;
4942 if (lbm_is_symbol(h) && ((h & ENC_SPECIAL_FORMS_MASK0xFFFFF000) == ENC_SPECIAL_FORMS_BIT0x00001000)) {
4943 lbm_uint eval_index = lbm_dec_sym(h) & SPECIAL_FORMS_INDEX_MASK0x000000FF;
4944 evaluators[eval_index](ctx);
4945 return;
4946 }
4947 /*
4948 * At this point head can be anything. It should evaluate
4949 * into a form that can be applied (closure, symbol, ...) though.
4950 */
4951 lbm_value *reserved = stack_reserve(ctx, 3);
4952 reserved[0] = ctx->curr_env;
4953 reserved[1] = cell->cdr;
4954 reserved[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
4955 ctx->curr_exp = h; // evaluate the function
4956 return;
4957 }
4958
4959 eval_selfevaluating(ctx);
4960 return;
4961}
4962
4963void lbm_pause_eval(void ) {
4964 eval_cps_next_state_arg = 0;
4965 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4966 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4967}
4968
4969void lbm_pause_eval_with_gc(uint32_t num_free) {
4970 eval_cps_next_state_arg = num_free;
4971 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4972 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4973}
4974
4975void lbm_continue_eval(void) {
4976 eval_cps_next_state = EVAL_CPS_STATE_RUNNING2;
4977 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4978}
4979
4980void lbm_kill_eval(void) {
4981 eval_cps_next_state = EVAL_CPS_STATE_KILL4;
4982 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4983}
4984
4985uint32_t lbm_get_eval_state(void) {
4986 return eval_cps_run_state;
4987}
4988
4989// Will wake up thread that is sleeping as well.
4990// Not sure this is good behavior.
4991static void handle_event_unblock_ctx(lbm_cid cid, lbm_value v) {
4992 eval_context_t *found = NULL((void*)0);
4993 mutex_lock(&qmutex);
4994
4995 found = lookup_ctx_nm(&blocked, cid);
4996 if (found) {
4997 drop_ctx_nm(&blocked,found);
4998 if (lbm_is_error(v)) {
4999 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
5000 found->app_cont = true1;
5001 }
5002 found->r = v;
5003 enqueue_ctx_nm(&queue,found);
5004 }
5005 mutex_unlock(&qmutex);
5006}
5007
5008static void handle_event_define(lbm_value key, lbm_value val) {
5009 lbm_uint dec_key = lbm_dec_sym(key);
5010 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
5011 lbm_value *global_env = lbm_get_global_env();
5012 lbm_uint orig_env = global_env[ix_key];
5013 lbm_value new_env;
5014 // A key is a symbol and should not need to be remembered.
5015 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
5016
5017 global_env[ix_key] = new_env;
5018}
5019
5020static lbm_value get_event_value(lbm_event_t *e) {
5021 lbm_value v;
5022 if (e->buf_len > 0) {
5023 lbm_flat_value_t fv;
5024 fv.buf = (uint8_t*)e->buf_ptr;
5025 fv.buf_size = e->buf_len;
5026 fv.buf_pos = 0;
5027 if (!lbm_unflatten_value(&fv, &v)) {
5028 lbm_set_flags(LBM_FLAG_HANDLER_EVENT_DELIVERY_FAILED(1 << 1));
5029 v = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
5030 }
5031 // Free the flat value buffer. GC is unaware of its existence.
5032 lbm_free(fv.buf);
5033 } else {
5034 v = (lbm_value)e->buf_ptr;
5035 }
5036 return v;
5037}
5038
5039static void process_events(void) {
5040
5041 if (!lbm_events) return;
5042 lbm_event_t e;
5043
5044 while (lbm_event_pop(&e)) {
5045
5046 lbm_value event_val = get_event_value(&e);
5047 switch(e.type) {
5048 case LBM_EVENT_UNBLOCK_CTX:
5049 handle_event_unblock_ctx((lbm_cid)e.parameter, event_val);
5050 break;
5051 case LBM_EVENT_DEFINE:
5052 handle_event_define((lbm_value)e.parameter, event_val);
5053 break;
5054 case LBM_EVENT_FOR_HANDLER:
5055 if (lbm_event_handler_pid >= 0) {
5056 lbm_find_receiver_and_send(lbm_event_handler_pid, event_val);
5057 }
5058 break;
5059 }
5060 }
5061}
5062
5063/* eval_cps_run can be paused
5064 I think it would be better use a mailbox for
5065 communication between other threads and the run_eval
5066 but for now a set of variables will be used. */
5067void lbm_run_eval(void){
5068
5069 if (setjmp(critical_error_jmp_buf)_setjmp (critical_error_jmp_buf) > 0) {
5070 printf_callback("GC stack overflow!\n");
5071 critical_error_callback();
5072 // terminate evaluation thread.
5073 return;
5074 }
5075
5076 setjmp(error_jmp_buf)_setjmp (error_jmp_buf);
5077
5078 while (eval_running) {
5079 if (eval_cps_state_changed || eval_cps_run_state == EVAL_CPS_STATE_PAUSED1) {
5080 eval_cps_state_changed = false0;
5081 switch (eval_cps_next_state) {
5082 case EVAL_CPS_STATE_PAUSED1:
5083 if (eval_cps_run_state != EVAL_CPS_STATE_PAUSED1) {
5084 if (lbm_heap_num_free() < eval_cps_next_state_arg) {
5085 gc();
5086 }
5087 eval_cps_next_state_arg = 0;
5088 }
5089 eval_cps_run_state = EVAL_CPS_STATE_PAUSED1;
5090 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5091 continue; /* jump back to start of eval_running loop */
5092 case EVAL_CPS_STATE_KILL4:
5093 eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
5094 eval_running = false0;
5095 continue;
5096 default: // running state
5097 eval_cps_run_state = eval_cps_next_state;
5098 break;
5099 }
5100 }
5101 while (true1) {
5102 if (eval_steps_quota && ctx_running) {
5103 eval_steps_quota--;
5104 evaluation_step();
5105 } else {
5106 if (eval_cps_state_changed) break;
5107 eval_steps_quota = eval_steps_refill;
5108 if (is_atomic) {
5109 if (!ctx_running) {
5110 lbm_set_flags(LBM_FLAG_ATOMIC_MALFUNCTION(1 << 0));
5111 is_atomic = 0;
5112 }
5113 } else {
5114 if (gc_requested) {
5115 gc();
5116 }
5117 process_events();
5118 mutex_lock(&qmutex);
5119 if (ctx_running) {
5120 enqueue_ctx_nm(&queue, ctx_running);
5121 ctx_running = NULL((void*)0);
5122 }
5123 wake_up_ctxs_nm();
5124 ctx_running = dequeue_ctx_nm(&queue);
5125 mutex_unlock(&qmutex);
5126 if (!ctx_running) {
5127 lbm_system_sleeping = true1;
5128 //Fixed sleep interval to poll events regularly.
5129 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5130 lbm_system_sleeping = false0;
5131 }
5132 }
5133 }
5134 }
5135 }
5136}
5137
5138lbm_cid lbm_eval_program(lbm_value lisp) {
5139 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), 256, NULL((void*)0));
5140}
5141
5142lbm_cid lbm_eval_program_ext(lbm_value lisp, unsigned int stack_size) {
5143 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), stack_size, NULL((void*)0));
5144}
5145
5146int lbm_eval_init() {
5147 if (!qmutex_initialized) {
5148 mutex_init(&qmutex);
5149 qmutex_initialized = true1;
5150 }
5151 if (!lbm_events_mutex_initialized) {
5152 mutex_init(&lbm_events_mutex);
5153 lbm_events_mutex_initialized = true1;
5154 }
5155 if (!blocking_extension_mutex_initialized) {
5156 mutex_init(&blocking_extension_mutex);
5157 blocking_extension_mutex_initialized = true1;
5158 }
5159
5160 mutex_lock(&qmutex);
5161 mutex_lock(&lbm_events_mutex);
5162
5163 blocked.first = NULL((void*)0);
5164 blocked.last = NULL((void*)0);
5165 queue.first = NULL((void*)0);
5166 queue.last = NULL((void*)0);
5167 ctx_running = NULL((void*)0);
5168
5169 eval_cps_run_state = EVAL_CPS_STATE_RUNNING2;
5170
5171 mutex_unlock(&lbm_events_mutex);
5172 mutex_unlock(&qmutex);
5173
5174 if (!lbm_init_env()) return 0;
5175 eval_running = true1;
5176 return 1;
5177}
5178
5179bool_Bool lbm_eval_init_events(unsigned int num_events) {
5180
5181 mutex_lock(&lbm_events_mutex);
5182 lbm_events = (lbm_event_t*)lbm_malloc(num_events * sizeof(lbm_event_t));
5183 bool_Bool r = false0;
5184 if (lbm_events) {
5185 lbm_events_max = num_events;
5186 lbm_events_head = 0;
5187 lbm_events_tail = 0;
5188 lbm_events_full = false0;
5189 lbm_event_handler_pid = -1;
5190 r = true1;
5191 }
5192 mutex_unlock(&lbm_events_mutex);
5193 return r;
5194}
+
+
←

./include/heap.h

+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1
2/*
3 Copyright 2018, 2024 Joel Svensson svenssonjoel@yahoo.se
4
5 This program is free software: you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation, either version 3 of the License, or
8 (at your option) any later version.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
14
15 You should have received a copy of the GNU General Public License
16 along with this program. If not, see <http://www.gnu.org/licenses/>.
17*/
18/** \file heap.h */
19
20#ifndef HEAP_H_
21#define HEAP_H_
22
23#include <string.h>
24#include <stdarg.h>
25
26#include "lbm_types.h"
27#include "symrepr.h"
28#include "stack.h"
29#include "lbm_memory.h"
30#include "lbm_defines.h"
31#include "lbm_channel.h"
32
33#ifdef __cplusplus
34extern "C" {
35#endif
36
37/*
38Planning for a more space efficient heap representation.
39TODO: Need to find a good reference to read up on this.
40 - List based heap
41 - Easy to implement and somewhat efficient
42
430000 0000 Size Free bits
44003F FFFF 4MB 10
45007F FFFF 8MB 9
4600FF FFFF 16MB 8
4701FF FFFF 32MB 7
4803FF FFFF 64MB 6 * Kind of heap size I am looking for
4907FF FFFF 128MB 5
500FFF FFFF 256MB 4
511FFF FFFF 512MB 3
52
53
54--- May 9 2021 ---
55Actually now I am much more interested in way smaller memories ;)
56
570000 0000 Size Free bits
580000 0FFF 4KB 20 |
590000 1FFF 8KB 19 |
600000 3FFF 16KB 18 |
610000 7FFF 32KB 17 |
620000 FFFF 64KB 16 |
630001 FFFF 128KB 15 |
640003 FFFF 256KB 14 | - This range is very interesting.
650007 FFFF 512KB 13
66000F FFFF 1MB 12
67001F FFFF 2MB 11
68003F FFFF 4MB 10
69007F FFFF 8MB 9
7000FF FFFF 16MB 8
7101FF FFFF 32MB 7
7203FF FFFF 64MB 6
7307FF FFFF 128MB 5
740FFF FFFF 256MB 4
751FFF FFFF 512MB 3
76
77Those are the kind of platforms that are fun... so a bunch of
78wasted bits in heap pointers if we run on small MCUs.
79
80-----------------
81
82it is also the case that not all addresses will be used if all "cells" are
83of the same size, 8 bytes...
84
85value 0: 0000 0000
86value 1: 0000 0008
87value 3: 0000 0010
88value 4: 0000 0018
89
90Means bits 0,1,2 will always be empty in a valid address.
91
92Cons cells also need to be have room for 2 pointers. So each ted cell from
93memory should be 8bytes.
94
95Things that needs to be represented within these bits:
96
97 - GC MARK one per cell
98 - TYPE: type of CAR and type of cons
99
100Types I would want:
101 - Full 32bit integer. Does not leave room for identification of type
102 - Float values. Same problem
103
104
105Free bits in pointers 64MB heap:
10631 30 29 28 27 26 2 1 0
1070 0 0 0 0 0 XX XXXX XXXX XXXX XXXX XXXX X 0 0 0
108
109
110Information needed for each cell:
111 Meaning | bits total | bits per car | bits per cdr
112 GC mark | 2 | 1 | 1 - only one of them will be used (the other is wasted)
113 Type | 2x | x | x
114 Ptr/!ptr | 2 | 1 | 1
115
116
117Types (unboxed):
118 - Symbols
119 - 28bit integer ( will need signed shift right functionality )
120 - 28bit unsigned integer
121 - Character
122
123If four types is all that should be possible (unboxed). then 2 bits are needed to differentiate.
1242 + 1 + 1 = 4 => 28bits for data.
125
126bit 0: ptr/!ptr
127bit 1: gc
128bit 2-3: type (if not ptr)
129bit 3 - 24 ptr (if ptr)
130bit 4 - 31 value (if value)
131
132An unboxed value can occupy a car or cdr field in a cons cell.
133
134types (boxed) extra information in pointer to cell can contain information
135 - 32 bit integer
136 - 32 bit unsigned integer
137 - 32 bit float
138
139boxed representation:
140 [ptr| cdr]
141 |
142 [Value | Aux + GC_MARK]
143
144Kinds of pointers:
145 - Pointer to cons cell.
146 - Pointer to unboxed value (fixnums not in a list, I hope this is so rare that it can be removed )
147 - integer
148 - unsigned integer
149 - symbol
150 - float
151 - Pointer to boxed value.
152 - 32 bit integer
153 - 32 bit unsigned integer
154 - 32 bit float
155 - (Maybe something else ? Vectors/strings allocated in memory not occupied by heap?)
156 - vector of int
157 - vector of uint
158 - vector of float
159 - vector of double
160 - String
161
16213 pointer"types" -> needs 4 bits
163for 64MB heap there are 6 free bits. So with this scheme going to 128MB or 256MB heap
164is also possible
165
166 a pointer to some off heap vector/string could be represented by
167
168 [ptr | cdr]
169 |
170 [full pointer | Aux + GC_MARK]
171 |
172 [VECTOR]
173
174Aux bits could be used for storing vector size. Up to 30bits should be available there
175>> This is problematic. Now the information that something is a vector is split up
176>> between 2 cons cells. This means GC needs both of these intact to be able to make
177>> proper decision.
178>> Will try to resolve this by adding some special symbols. But these must be symbols
179>> that cannot occur normally in programs. Then an array could be:
180
181 [Full pointer | ARRAY_SYM + GC_MARK]
182 |
183 [VECTOR]
184
185>> Boxed values same treatment as above.
186>> TODO: Could this be simpler?
187
188[ VALUE | TYPE_SYM + GC_MARK]
189
190
1910000 00XX XXXX XXXX XXXX XXXX XXXX X000 : 0x03FF FFF8
1921111 AA00 0000 0000 0000 0000 0000 0000 : 0xFC00 0000 (AA bits left unused for now, future heap growth?)
193 */
194
195typedef enum {
196 LBM_FLASH_WRITE_OK,
197 LBM_FLASH_FULL,
198 LBM_FLASH_WRITE_ERROR
199} lbm_flash_status;
200
201/** Struct representing a heap cons-cell.
202 *
203 */
204typedef struct {
205 lbm_value car;
206 lbm_value cdr;
207} lbm_cons_t;
208
209/**
210 * Heap state
211 */
212typedef struct {
213 lbm_cons_t *heap;
214 lbm_value freelist; // list of free cons cells.
215 lbm_stack_t gc_stack;
216
217 lbm_uint heap_size; // In number of cells.
218 lbm_uint heap_bytes; // In bytes.
219
220 lbm_uint num_alloc; // Number of cells allocated.
221 lbm_uint num_alloc_arrays; // Number of arrays allocated.
222
223 lbm_uint gc_num; // Number of times gc has been performed.
224 lbm_uint gc_marked; // Number of cells marked by mark phase.
225 lbm_uint gc_recovered; // Number of cells recovered by sweep phase.
226 lbm_uint gc_recovered_arrays;// Number of arrays recovered by sweep.
227 lbm_uint gc_least_free; // The smallest length of the freelist.
228 lbm_uint gc_last_free; // Number of elements on the freelist
229 // after most recent GC.
230} lbm_heap_state_t;
231
232extern lbm_heap_state_t lbm_heap_state;
233
234typedef bool_Bool (*const_heap_write_fun)(lbm_uint ix, lbm_uint w);
235
236typedef struct {
237 lbm_uint *heap;
238 lbm_uint next; // next free index.
239 lbm_uint size; // in lbm_uint words. (cons-cells = words / 2)
240} lbm_const_heap_t;
241
242/**
243 * The header portion of an array stored in array and symbol memory.
244 * An array is always a byte array. use the array-extensions for
245 * storing and reading larger values from arrays.
246 */
247typedef struct {
248 lbm_uint size; /// Number of elements
249 lbm_uint *data; /// pointer to lbm_memory array or C array.
250} lbm_array_header_t;
251
252typedef struct {
253 lbm_uint size;
254 lbm_uint *data;
255 uint32_t index; // Limits arrays to max 2^32-1 elements.
256} lbm_array_header_extended_t;
257
258/** Lock GC mutex
259 * Locks a mutex during GC marking when using the pointer reversal algorithm.
260 * Does nothing when using stack based GC mark.
261 */
262void lbm_gc_lock(void);
263/* Unlock GC mutex
264 */
265void lbm_gc_unlock(void);
266
267/** Initialize heap storage.
268 * \param addr Pointer to an array of lbm_cons_t elements. This array must at least be aligned 4.
269 * \param num_cells Number of lbm_cons_t elements in the array.
270 * \param gc_stack_size Size of the gc_stack in number of words.
271 * \return 1 on success or 0 for failure.
272 */
273int lbm_heap_init(lbm_cons_t *addr, lbm_uint num_cells,
274 lbm_uint gc_stack_size);
275
276/** Add GC time statistics to heap_stats
277 *
278 * \param dur Duration as reported by the timestamp callback.
279 */
280void lbm_heap_new_gc_time(lbm_uint dur);
281/** Add a new free_list length to the heap_stats.
282 * Calculates a new freelist length and updates
283 * the GC statistics.
284 */
285void lbm_heap_new_freelist_length(void);
286/** Check how many lbm_cons_t cells are on the free-list
287 *
288 * \return Number of free lbm_cons_t cells.
289 */
290lbm_uint lbm_heap_num_free(void);
291/** Check how many lbm_cons_t cells are allocated.
292 *
293 * \return Number of lbm_cons_t cells that are currently allocated.
294 */
295lbm_uint lbm_heap_num_allocated(void);
296/** Size of the heap in number of lbm_cons_t cells.
297 *
298 * \return Size of the heap in number of lbm_cons_t cells.
299 */
300lbm_uint lbm_heap_size(void);
301/** Size of the heap in bytes.
302 *
303 * \return Size of heap in bytes.
304 */
305lbm_uint lbm_heap_size_bytes(void);
306/** Allocate an lbm_cons_t cell from the heap.
307 *
308 * \param type A type that can be encoded onto the cell (most often LBM_PTR_TYPE_CONS).
309 * \param car Value to write into car position of allocated cell.
310 * \param cdr Value to write into cdr position of allocated cell.
311 * \return An lbm_value referring to a cons_cell or enc_sym(SYM_MERROR) in case the heap is full.
312 */
313lbm_value lbm_heap_allocate_cell(lbm_type type, lbm_value car, lbm_value cdr);
314/** Allocate a list of n heap-cells.
315 * \param n The number of heap-cells to allocate.
316 * \return A list of heap-cells of Memory error if unable to allocate.
317 */
318lbm_value lbm_heap_allocate_list(lbm_uint n);
319/** Allocate a list of n heap-cells and initialize the values.
320 * \pram ls The result list is passed through this ptr.
321 * \param n The length of list to allocate.
322 * \param valist The values in a va_list to initialize the list with.
323 * \return True of False depending on success of allocation.
324 */
325lbm_value lbm_heap_allocate_list_init_va(unsigned int n, va_list valist);
326/** Allocate a list of n heap-cells and initialize the values.
327 * \param n The length of list to allocate.
328 * \param ... The values to initialize the list with.
329 * \return allocated list or error symbol.
330 */
331lbm_value lbm_heap_allocate_list_init(unsigned int n, ...);
332/** Decode an lbm_value representing a string into a C string
333 *
334 * \param val Value
335 * \return allocated list or error symbol
336 */
337char *lbm_dec_str(lbm_value val);
338/** Decode an lbm_value representing a char channel into an lbm_char_channel_t pointer.
339 *
340 * \param val Value
341 * \return A pointer to an lbm_char_channel_t or NULL if the value does not encode a channel.
342 */
343lbm_char_channel_t *lbm_dec_channel(lbm_value val);
344/** Decode an lbm_value representing a custom type into a lbm_uint value.
345 *
346 * \param val Value.
347 * \return The custom type payload.
348 */
349lbm_uint lbm_dec_custom(lbm_value val);
350/** Decode a numerical value as if it is char
351 *
352 * \param val Value to decode
353 * \return The value encoded in val casted to a char. Returns 0 if val does not encode a number.
354 */
355uint8_t lbm_dec_as_char(lbm_value a);
356/** Decode a numerical value as if it is unsigned
357 *
358 * \param val Value to decode
359 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
360 */
361uint32_t lbm_dec_as_u32(lbm_value val);
362/** Decode a numerical value as a signed integer.
363 *
364 * \param val Value to decode
365 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
366 */
367int32_t lbm_dec_as_i32(lbm_value val);
368/** Decode a numerical value as a float.
369 *
370 * \param val Value to decode.
371 * \return The value encoded in val casted to a float. Returns 0 if val does not encode a number.
372 */
373float lbm_dec_as_float(lbm_value val);
374/** Decode a numerical value as if it is a 64bit unsigned
375 *
376 * \param val Value to decode
377 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
378 */
379uint64_t lbm_dec_as_u64(lbm_value val);
380/** Decode a numerical value as a 64bit signed integer.
381 *
382 * \param val Value to decode
383 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
384 */
385int64_t lbm_dec_as_i64(lbm_value val);
386/** Decode a numerical value as a float.
387 *
388 * \param val Value to decode.
389 * \return The value encoded in val casted to a float. Returns 0 if val does not encode a number.
390 */
391double lbm_dec_as_double(lbm_value val);
392
393/** Decode a numerical value into the architecture defined unsigned integer type.
394 *
395 * \param val Value to decode
396 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
397 */
398lbm_uint lbm_dec_as_uint(lbm_value val);
399
400/** Decode a numerical value into the architecture defined signed integer type.
401 *
402 * \param val Value to decode
403 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
404 */
405lbm_int lbm_dec_as_int(lbm_value val);
406
407lbm_uint lbm_dec_raw(lbm_value v);
408/** Allocates an lbm_cons_t cell from the heap and populates it.
409 *
410 * \param car The value to put in the car field of the allocated lbm_cons_t.
411 * \param cdr The value to put in the cdr field of the allocated lbm_cons_t.
412 * \return A value referencing the lbm_cons_t or enc_sym(SYM_MERROR) if heap is full.
413 */
414lbm_value lbm_cons(lbm_value car, lbm_value cdr);
415
416/** Accesses the car field of an lbm_cons_t.
417 *
418 * \param cons Value
419 * \return The car field of the lbm_cons_t if cons is a reference to a heap cell.
420 * If cons is nil, the return value is nil. If the value
421 * is not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
422 */
423lbm_value lbm_car(lbm_value cons);
424/** Accesses the car field the car field of an lbm_cons_t.
425 *
426 * \param cons Value
427 * \return The car of car field or nil.
428 */
429lbm_value lbm_caar(lbm_value c);
430/** Accesses the car of the cdr of an cons cell
431 *
432 * \param c Value
433 * \return the cdr field or type error.
434 */
435lbm_value lbm_cadr(lbm_value c);
436/** Accesses the cdr field of an lbm_cons_t.
437 *
438 * \param cons Value
439 * \return The cdr field of the lbm_cons_t if cons is a reference to a heap cell.
440 * If cons is nil, the return value is nil. If the value
441 * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
442 */
443lbm_value lbm_cdr(lbm_value cons);
444/** Accesses the cdr of an cdr field of an lbm_cons_t.
445 *
446 * \param cons Value
447 * \return The cdr of the cdr field of the lbm_cons_t if cons is a reference to a heap cell.
448 * If cons is nil, the return value is nil. If the value
449 * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
450 */
451lbm_value lbm_cddr(lbm_value c);
452/** Update the value stored in the car field of a heap cell.
453 *
454 * \param c Value referring to a heap cell.
455 * \param v Value to replace the car field with.
456 * \return 1 on success and 0 if the c value does not refer to a heap cell.
457 */
458int lbm_set_car(lbm_value c, lbm_value v);
459/** Update the value stored in the cdr field of a heap cell.
460 *
461 * \param c Value referring to a heap cell.
462 * \param v Value to replace the cdr field with.
463 * \return 1 on success and 0 if the c value does not refer to a heap cell.
464 */
465int lbm_set_cdr(lbm_value c, lbm_value v);
466/** Update the value stored in the car and cdr fields of a heap cell.
467 *
468 * \param c Value referring to a heap cell.
469 * \param car_val Value to replace the car field with.
470 * \param cdr_val Value to replace the cdr field with.
471 * \return 1 on success and 0 if the c value does not refer to a heap cell.
472 */
473int lbm_set_car_and_cdr(lbm_value c, lbm_value car_val, lbm_value cdr_val);
474// List functions
475/** Calculate the length of a proper list
476 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
477 * may lead to the function not terminating.
478 *
479 * \param c A list
480 * \return The length of the list. Unless the value is a cyclic structure on the heap, this function will terminate.
481 */
482lbm_uint lbm_list_length(lbm_value c);
483
484/** Calculate the length of a proper list and evaluate a predicate for each element.
485 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
486 * may lead to the function not terminating.
487 *
488 * \param c A list
489 * \param pres Boolean result of predicate, false if predicate is false for any of the elements in the list, otherwise true.
490 * \param pred Predicate to evaluate for each element of the list.
491 */
492unsigned int lbm_list_length_pred(lbm_value c, bool_Bool *pres, bool_Bool (*pred)(lbm_value));
493/** Reverse a proper list
494 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
495 * may lead to the function not terminating.
496 *
497 * \param list A list
498 * \return The list reversed or enc_sym(SYM_MERROR) if heap is full.
499 */
500lbm_value lbm_list_reverse(lbm_value list);
501/** Reverse a proper list destroying the original.
502 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
503 * may lead to the function not terminating.
504 *
505 * \param list A list
506 * \return The list reversed
507 */
508lbm_value lbm_list_destructive_reverse(lbm_value list);
509/** Copy a list
510 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
511 * may lead to the function not terminating.
512 *
513 * \param m Number of elements to copy or -1 for all. If 1, m will be updated with the length of the list
514 * \param list A list.
515 * \return Reversed list or enc_sym(SYM_MERROR) if heap is full.
516 */
517lbm_value lbm_list_copy(int *m, lbm_value list);
518
519/** A destructive append of two lists
520 *
521 * \param list1 A list
522 * \param list2 A list
523 * \return list1 with list2 appended at the end.
524 */
525lbm_value lbm_list_append(lbm_value list1, lbm_value list2);
526
527/** Drop values from the head of a list.
528 * \param n Number of values to drop.
529 * \param ls List to drop values from.
530 * \return The list with the n first elements removed.
531 */
532lbm_value lbm_list_drop(unsigned int n, lbm_value ls);
533/** Index into a list.
534 * \param l List to index into.
535 * \param n Position to read out of the list.
536 * \return Value at position n of l or nil if out of bounds.
537 */
538lbm_value lbm_index_list(lbm_value l, int32_t n);
539
540// State and statistics
541/** Get a copy of the heap statistics structure.
542 *
543 * \param A pointer to an lbm_heap_state_t to populate
544 * with the current statistics.
545 */
546void lbm_get_heap_state(lbm_heap_state_t *);
547/** Get the maximum stack level of the GC stack
548 * \return maximum value the gc stack sp reached so far.
549 */
550lbm_uint lbm_get_gc_stack_max(void);
551/** Get the size of the GC stack.
552 * \return the size of the gc stack.
553 */
554lbm_uint lbm_get_gc_stack_size(void);
555// Garbage collection
556/** Increment the counter that is counting the number of times GC ran
557 *
558 */
559void lbm_gc_state_inc(void);
560/** Set the freelist to NIL. Means that no memory will be available
561 * until after a garbage collection.
562 */
563void lbm_nil_freelist(void);
564/** Mark all heap cells reachable from an environment.
565 * \param environment.
566 */
567void lbm_gc_mark_env(lbm_value);
568/** Mark heap cells reachable from the lbm_value v.
569 * \param root
570 */
571void lbm_gc_mark_phase(lbm_value root);
572/** Performs lbm_gc_mark_phase on all the values of an array.
573 * This function is similar to lbm_gc_mark_roots but performs
574 * extra checks to not traverse into non-standard values.
575 * TODO: Check if this function is really needed.
576 * \param data Array of roots to traverse from.
577 * \param n Number of elements in roots-array.
578 */
579void lbm_gc_mark_aux(lbm_uint *data, lbm_uint n);
580/** Performs lbm_gc_mark_phase on all the values in the roots array.
581 * \param roots pointer to array of roots.
582 * \param num_roots size of array of roots.
583 */
584void lbm_gc_mark_roots(lbm_uint *roots, lbm_uint num_roots);
585/** Sweep up all non marked heap cells and place them on the free list.
586 *
587 * \return 1
588 */
589int lbm_gc_sweep_phase(void);
590
591// Array functionality
592/** Allocate an bytearray in symbols and arrays memory (lispbm_memory.h)
593 * and create a heap cell that refers to this bytearray.
594 * \param res The resulting lbm_value is returned through this argument.
595 * \param size Array size in number of 32 bit words.
596 * \return 1 for success of 0 for failure.
597 */
598int lbm_heap_allocate_array(lbm_value *res, lbm_uint size);
599/** Allocate an array in symbols and arrays memory (lispbm_memory.h)
600 * and create a heap cell that refers to this array.
601 * \param res The resulting lbm_value is returned through this argument.
602 * \param size Array size in number of 32 bit words.
603 * \return 1 for success of 0 for failure.
604 */
605int lbm_heap_allocate_lisp_array(lbm_value *res, lbm_uint size);
606/** Convert a C array into an lbm array. If the C array is allocated in LBM MEMORY
607 * the lifetime of the array will be managed by GC.
608 * \param res lbm_value result pointer for storage of the result array.
609 * \param data C array.
610 * \param type The type tag to assign to the resulting LBM array.
611 * \param num_elt Number of elements in the array.
612 * \return 1 for success and 0 for failure.
613 */
614int lbm_lift_array(lbm_value *value, char *data, lbm_uint num_elt);
615/** Get the size of an array value.
616 * \param arr lbm_value array to get size of.
617 * \return -1 for failure or length of array.
618 */
619lbm_int lbm_heap_array_get_size(lbm_value arr);
620/** Get a pointer to the data of an array for read only purposes.
621 * \param arr lbm_value array to get pointer from.
622 * \return NULL or valid pointer.
623 */
624const uint8_t *lbm_heap_array_get_data_ro(lbm_value arr);
625/** Get a pointer to the data of an array for read/write purposes.
626 * \param arr lbm_value array to get pointer from.
627 * \return NULL or valid pointer.
628 */
629uint8_t *lbm_heap_array_get_data_rw(lbm_value arr);
630/** Explicitly free an array.
631 * This function needs to be used with care and knowledge.
632 * \param arr Array value.
633 */
634int lbm_heap_explicit_free_array(lbm_value arr);
635/** Query the size in bytes of an lbm_type.
636 * \param t Type
637 * \return Size in bytes of type or 0 if the type represents a composite.
638 */
639lbm_uint lbm_size_of(lbm_type t);
640
641int lbm_const_heap_init(const_heap_write_fun w_fun,
642 lbm_const_heap_t *heap,
643 lbm_uint *addr,
644 lbm_uint num_words);
645
646lbm_flash_status lbm_allocate_const_cell(lbm_value *res);
647lbm_flash_status lbm_write_const_raw(lbm_uint *data, lbm_uint n, lbm_uint *res);
648lbm_flash_status lbm_allocate_const_raw(lbm_uint nwords, lbm_uint *res);
649lbm_flash_status write_const_cdr(lbm_value cell, lbm_value val);
650lbm_flash_status write_const_car(lbm_value cell, lbm_value val);
651lbm_flash_status lbm_const_write(lbm_uint *tgt, lbm_uint val);
652lbm_uint lbm_flash_memory_usage(void);
653
654/** Query the type information of a value.
655 *
656 * \param x Value to check the type of.
657 * \return The type information.
658 */
659static inline lbm_type lbm_type_of(lbm_value x) {
660 return (x & LBM_PTR_BIT0x00000001u) ? (x & LBM_PTR_TYPE_MASK0xFC000000u) : (x & LBM_VAL_TYPE_MASK0x0000000Cu);
661}
662
663// type-of check that is safe in functional code
664static inline lbm_type lbm_type_of_functional(lbm_value x) {
665 return (x & LBM_PTR_BIT0x00000001u) ?
666 (x & (LBM_PTR_TO_CONSTANT_MASK~0x04000000u & LBM_PTR_TYPE_MASK0xFC000000u)) :
667 (x & LBM_VAL_TYPE_MASK0x0000000Cu);
668}
669
670static inline lbm_value lbm_enc_cons_ptr(lbm_uint x) {
671 return ((x << LBM_ADDRESS_SHIFT2) | LBM_TYPE_CONS0x10000000u | LBM_PTR_BIT0x00000001u);
672}
673
674static inline lbm_uint lbm_dec_ptr(lbm_value p) {
675 return ((LBM_PTR_VAL_MASK0x03FFFFFCu & p) >> LBM_ADDRESS_SHIFT2);
676}
677
678extern lbm_cons_t *lbm_heaps[2];
679
680static inline lbm_uint lbm_dec_cons_cell_ptr(lbm_value p) {
681 lbm_uint h = (p & LBM_PTR_TO_CONSTANT_BIT0x04000000u) >> LBM_PTR_TO_CONSTANT_SHIFT26;
682 return lbm_dec_ptr(p) >> h;
683}
684
685static inline lbm_cons_t *lbm_dec_heap(lbm_value p) {
686 lbm_uint h = (p & LBM_PTR_TO_CONSTANT_BIT0x04000000u) >> LBM_PTR_TO_CONSTANT_SHIFT26;
687 return lbm_heaps[h];
688}
689
690static inline lbm_value lbm_set_ptr_type(lbm_value p, lbm_type t) {
691 return ((LBM_PTR_VAL_MASK0x03FFFFFCu & p) | t | LBM_PTR_BIT0x00000001u);
692}
693
694static inline lbm_value lbm_enc_sym(lbm_uint s) {
695 return (s << LBM_VAL_SHIFT4) | LBM_TYPE_SYMBOL0x00000000u;
696}
697
698static inline lbm_value lbm_enc_i(lbm_int x) {
699 return ((lbm_uint)x << LBM_VAL_SHIFT4) | LBM_TYPE_I0x00000008u;
700}
701
702static inline lbm_value lbm_enc_u(lbm_uint x) {
703 return (x << LBM_VAL_SHIFT4) | LBM_TYPE_U0x0000000Cu;
704}
705
706/** Encode 32 bit integer into an lbm_value.
707 * \param x Value to encode.
708 * \return result encoded value.
709 */
710extern lbm_value lbm_enc_i32(int32_t x);
711
712/** Encode 32 bit unsigned integer into an lbm_value.
713 * \param x Value to encode.
714 * \return result encoded value.
715 */
716extern lbm_value lbm_enc_u32(uint32_t x);
717
718/** Encode a float into an lbm_value.
719 * \param x float value to encode.
720 * \return result encoded value.
721 */
722extern lbm_value lbm_enc_float(float x);
723
724/** Encode a 64 bit integer into an lbm_value.
725 * \param x 64 bit integer to encode.
726 * \return result encoded value.
727 */
728extern lbm_value lbm_enc_i64(int64_t x);
729
730/** Encode a 64 bit unsigned integer into an lbm_value.
731 * \param x 64 bit unsigned integer to encode.
732 * \return result encoded value.
733 */
734extern lbm_value lbm_enc_u64(uint64_t x);
735
736/** Encode a double into an lbm_value.
737 * \param x double to encode.
738 * \return result encoded value.
739 */
740extern lbm_value lbm_enc_double(double x);
741
742static inline lbm_value lbm_enc_char(uint8_t x) {
743 return ((lbm_uint)x << LBM_VAL_SHIFT4) | LBM_TYPE_CHAR0x00000004u;
744}
745
746static inline lbm_int lbm_dec_i(lbm_value x) {
747 return (lbm_int)x >> LBM_VAL_SHIFT4;
748}
749
750static inline lbm_uint lbm_dec_u(lbm_value x) {
751 return x >> LBM_VAL_SHIFT4;
752}
753
754static inline uint8_t lbm_dec_char(lbm_value x) {
755 return (uint8_t)(x >> LBM_VAL_SHIFT4);
756}
757
758static inline lbm_uint lbm_dec_sym(lbm_value x) {
759 return x >> LBM_VAL_SHIFT4;
760}
761
762/** Decode an lbm_value representing a float.
763 * \param x Value to decode.
764 * \return decoded float.
765 */
766extern float lbm_dec_float(lbm_value x);
767
768/** Decode an lbm_value representing a double.
769 * \param x Value to decode.
770 * \return decoded float.
771 */
772extern double lbm_dec_double(lbm_value x);
773
774
775static inline uint32_t lbm_dec_u32(lbm_value x) {
776#ifndef LBM64
777 return (uint32_t)lbm_car(x);
778#else
779 return (uint32_t)(x >> LBM_VAL_SHIFT4);
780#endif
781}
782
783/** Decode an lbm_value representing a 64 bit unsigned integer.
784 * \param x Value to decode.
785 * \return decoded uint64_t.
786 */
787extern uint64_t lbm_dec_u64(lbm_value x);
788
789static inline int32_t lbm_dec_i32(lbm_value x) {
790#ifndef LBM64
791 return (int32_t)lbm_car(x);
792#else
793 return (int32_t)(x >> LBM_VAL_SHIFT4);
794#endif
795}
796
797/** Decode an lbm_value representing a 64 bit integer.
798 * \param x Value to decode.
799 * \return decoded int64_t.
800 */
801extern int64_t lbm_dec_i64(lbm_value x);
802
803/**
804 * Check if a value is a heap pointer
805 * \param x Value to check
806 * \return true if x is a pointer to a heap cell, false otherwise.
807 */
808static inline bool_Bool lbm_is_ptr(lbm_value x) {
809 return (x & LBM_PTR_BIT0x00000001u);
810}
811
812/**
813 * Check if a value is a Read/Writeable cons cell
814 * \param x Value to check
815 * \return true if x is a Read/Writeable cons cell, false otherwise.
816 */
817static inline bool_Bool lbm_is_cons_rw(lbm_value x) {
818 return (lbm_type_of(x) == LBM_TYPE_CONS0x10000000u);
819}
820
821/**
822 * Check if a value is a Readable cons cell
823 * \param x Value to check
824 * \return true if x is a readable cons cell, false otherwise.
825 */
826static inline bool_Bool lbm_is_cons(lbm_value x) {
827 return lbm_is_ptr(x) && ((x & LBM_CONS_TYPE_MASK0xF0000000u) == LBM_TYPE_CONS0x10000000u);
828}
829
830/** Check if a value represents a number
831 * \param x Value to check.
832 * \return true is x represents a number and false otherwise.
833 */
834static inline bool_Bool lbm_is_number(lbm_value x) {
835 return
836 (x & LBM_PTR_BIT0x00000001u) ?
837 ((x & LBM_NUMBER_MASK0x08000000u) == LBM_NUMBER_MASK0x08000000u) :
838 (x & LBM_VAL_TYPE_MASK0x0000000Cu);
839}
840
841/** Check if value is an array that can be READ
842 * \param x Value to check.
843 * \return true if x represents a readable array and false otherwise.
844 */
845static inline bool_Bool lbm_is_array_r(lbm_value x) {
846 lbm_type t = lbm_type_of(x);
847 return ((t & LBM_PTR_TO_CONSTANT_MASK~0x04000000u) == LBM_TYPE_ARRAY0x80000000u);
848}
849
850static inline bool_Bool lbm_is_array_rw(lbm_value x) {
851 return( (lbm_type_of(x) == LBM_TYPE_ARRAY0x80000000u) && !(x & LBM_PTR_TO_CONSTANT_BIT0x04000000u));
852}
853
854static inline bool_Bool lbm_is_lisp_array_r(lbm_value x) {
855 lbm_type t = lbm_type_of(x);
856 return ((t & LBM_PTR_TO_CONSTANT_MASK~0x04000000u) == LBM_TYPE_LISPARRAY0xB0000000u);
857}
858
859static inline bool_Bool lbm_is_lisp_array_rw(lbm_value x) {
860 return( (lbm_type_of(x) == LBM_TYPE_LISPARRAY0xB0000000u) && !(x & LBM_PTR_TO_CONSTANT_BIT0x04000000u));
861}
862
863
864static inline bool_Bool lbm_is_channel(lbm_value x) {
865 return (lbm_type_of(x) == LBM_TYPE_CHANNEL0x90000000u &&
866 lbm_type_of(lbm_cdr(x)) == LBM_TYPE_SYMBOL0x00000000u &&
867 lbm_cdr(x) == ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
868}
869static inline bool_Bool lbm_is_char(lbm_value x) {
870 return (lbm_type_of(x) == LBM_TYPE_CHAR0x00000004u);
871}
872
873static inline bool_Bool lbm_is_special(lbm_value symrep) {
874 return ((lbm_type_of(symrep) == LBM_TYPE_SYMBOL0x00000000u) &&
875 (lbm_dec_sym(symrep) < SPECIAL_SYMBOLS_END0xFFFF));
876}
877
878static inline bool_Bool lbm_is_closure(lbm_value exp) {
879 return ((lbm_is_cons(exp)) &&
880 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
881 (lbm_car(exp) == ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u)));
882}
883
884static inline bool_Bool lbm_is_continuation(lbm_value exp) {
885 return ((lbm_type_of(exp) == LBM_TYPE_CONS0x10000000u) &&
886 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
887 (lbm_car(exp) == ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u)));
888}
889
890static inline bool_Bool lbm_is_macro(lbm_value exp) {
891 return ((lbm_type_of(exp) == LBM_TYPE_CONS0x10000000u) &&
892 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
893 (lbm_car(exp) == ENC_SYM_MACRO(((0x10D) << 4) | 0x00000000u)));
894}
895
896static inline bool_Bool lbm_is_match_binder(lbm_value exp) {
897 return (lbm_is_cons(exp) &&
898 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
899 (lbm_car(exp) == ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u)));
900}
901
902static inline bool_Bool lbm_is_comma_qualified_symbol(lbm_value exp) {
903 return (lbm_is_cons(exp) &&
904 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
905 (lbm_car(exp) == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) &&
906 (lbm_type_of(lbm_cadr(exp)) == LBM_TYPE_SYMBOL0x00000000u));
907}
908
909static inline bool_Bool lbm_is_symbol(lbm_value exp) {
910 return !(exp & LBM_LOW_RESERVED_BITS0x0000000Fu);
911}
912
913static inline bool_Bool lbm_is_symbol_nil(lbm_value exp) {
914 return !exp;
7
←
Assuming 'exp' is not equal to 0, which participates in a condition later
→
8
←
Returning zero, which participates in a condition later
→
11
←
Assuming 'exp' is not equal to 0, which participates in a condition later
→
12
←
Returning zero, which participates in a condition later
→
915}
916
917static inline bool_Bool lbm_is_symbol_true(lbm_value exp) {
918 return (lbm_is_symbol(exp) && exp == ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u));
919}
920
921static inline bool_Bool lbm_is_symbol_eval(lbm_value exp) {
922 return (lbm_is_symbol(exp) && exp == ENC_SYM_EVAL(((0x30008) << 4) | 0x00000000u));
923}
924
925static inline bool_Bool lbm_is_symbol_merror(lbm_value exp) {
926 return lbm_is_symbol(exp) && (exp == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
927}
928
929static inline bool_Bool lbm_is_list(lbm_value x) {
930 return (lbm_is_cons(x) || lbm_is_symbol_nil(x));
931}
932
933static inline bool_Bool lbm_is_list_rw(lbm_value x) {
934 return (lbm_is_cons_rw(x) || lbm_is_symbol_nil(x));
935}
936
937static inline bool_Bool lbm_is_quoted_list(lbm_value x) {
938 return (lbm_is_cons(x) &&
939 lbm_is_symbol(lbm_car(x)) &&
940 (lbm_car(x) == ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u)) &&
941 lbm_is_cons(lbm_cdr(x)) &&
942 lbm_is_cons(lbm_cadr(x)));
943}
944
945#ifndef LBM64
946#define ERROR_SYMBOL_MASK0xFFFFFFF0 0xFFFFFFF0
947#else
948#define ERROR_SYMBOL_MASK0xFFFFFFF0 0xFFFFFFFFFFFFFFF0
949#endif
950
951/* all error signaling symbols are in the range 0x20 - 0x2F */
952static inline bool_Bool lbm_is_error(lbm_value v){
953 return (lbm_is_symbol(v) &&
954 ((lbm_dec_sym(v) & ERROR_SYMBOL_MASK0xFFFFFFF0) == 0x20));
955}
956
957// ref_cell: returns a reference to the cell addressed by bits 3 - 26
958// Assumes user has checked that is_ptr was set
959static inline lbm_cons_t* lbm_ref_cell(lbm_value addr) {
960 return &lbm_dec_heap(addr)[lbm_dec_cons_cell_ptr(addr)];
961 //return &lbm_heap_state.heap[lbm_dec_ptr(addr)];
962}
963
964
965// lbm_uint a = lbm_heaps[0];
966// lbm_uint b = lbm_heaps[1];
967// lbm_uint i = (addr & LBM_PTR_TO_CONSTANT_BIT) >> LBM_PTR_TO_CONSTANT_SHIFT) - 1;
968// lbm_uint h = (a & i) | (b & ~i);
969
970#ifdef __cplusplus
971}
972#endif
973#endif
diff --git a/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-6504f5.html b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-6504f5.html new file mode 100644 index 00000000..35799d3d --- /dev/null +++ b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-6504f5.html @@ -0,0 +1,6543 @@ + + + +src/eval_cps.c + + + + + + + + + + + + + + + + + + + + + + + + + + +

Bug Summary

+ + + + +
File:eval_cps.c
Warning:line 3000, column 19
Assigned value is garbage or undefined
+ +

Annotated Source Code

+

Press '?' + to see keyboard shortcuts

+ + +
clang -cc1 -triple i386-pc-linux-gnu -analyze -disable-free -disable-llvm-verifier -discard-value-names -main-file-name eval_cps.c -analyzer-store=region -analyzer-opt-analyze-nested-blocks -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -mrelocation-model static -mthread-model posix -mframe-pointer=none -fmath-errno -fno-rounding-math -masm-verbose -mconstructor-aliases -target-cpu i686 -dwarf-column-info -fno-split-dwarf-inlining -debugger-tuning=gdb -resource-dir /usr/lib/llvm-10/lib/clang/10.0.0 -I ./include -I ./include/extensions -I platform/linux/include -D _PRELUDE -internal-isystem /usr/local/include -internal-isystem /usr/lib/llvm-10/lib/clang/10.0.0/include -internal-externc-isystem /usr/include/i386-linux-gnu -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -std=c99 -fdebug-compilation-dir /home/joels/Current/lispbm -ferror-limit 19 -fmessage-length 0 -fgnuc-version=4.2.1 -fobjc-runtime=gcc -fdiagnostics-show-option -vectorize-loops -vectorize-slp -analyzer-output=html -faddrsig -o /home/joels/Current/lispbm/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1 -x c src/eval_cps.c +
+ + + +
+ + +
+ + + + +
+

src/eval_cps.c

+
→
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1/*
2 Copyright 2018, 2020 - 2024 Joel Svensson svenssonjoel@yahoo.se
3
4 This program is free software: you can redistribute it and/or modify
5 it under the terms of the GNU General Public License as published by
6 the Free Software Foundation, either version 3 of the License, or
7 (at your option) any later version.
8
9 This program is distributed in the hope that it will be useful,
10 but WITHOUT ANY WARRANTY; without even the implied warranty of
11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 GNU General Public License for more details.
13
14 You should have received a copy of the GNU General Public License
15 along with this program. If not, see <http://www.gnu.org/licenses/>.
16*/
17
18#include <lbm_memory.h>
19#include <lbm_types.h>
20#include "symrepr.h"
21#include "heap.h"
22#include "env.h"
23#include "eval_cps.h"
24#include "stack.h"
25#include "fundamental.h"
26#include "extensions.h"
27#include "tokpar.h"
28#include "lbm_channel.h"
29#include "print.h"
30#include "platform_mutex.h"
31#include "lbm_flat_value.h"
32#include "lbm_flags.h"
33
34#ifdef VISUALIZE_HEAP
35#include "heap_vis.h"
36#endif
37
38#include <setjmp.h>
39#include <stdarg.h>
40
41static jmp_buf error_jmp_buf;
42static jmp_buf critical_error_jmp_buf;
43
44#define S_TO_US(X)(lbm_uint)((X) * 1000000) (lbm_uint)((X) * 1000000)
45
46#define DEC_CONTINUATION(x)(((x) & ~0xF8000001u) >> 2) (((x) & ~LBM_CONTINUATION_INTERNAL0xF8000001u) >> LBM_ADDRESS_SHIFT2)
47#define IS_CONTINUATION(x)(((x) & 0xF8000001u) == 0xF8000001u) (((x) & LBM_CONTINUATION_INTERNAL0xF8000001u) == LBM_CONTINUATION_INTERNAL0xF8000001u)
48#define CONTINUATION(x)(((x) << 2) | 0xF8000001u) (((x) << LBM_ADDRESS_SHIFT2) | LBM_CONTINUATION_INTERNAL0xF8000001u)
49
50#define DONE(((0) << 2) | 0xF8000001u) CONTINUATION(0)(((0) << 2) | 0xF8000001u)
51#define SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u) CONTINUATION(1)(((1) << 2) | 0xF8000001u)
52#define BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u) CONTINUATION(2)(((2) << 2) | 0xF8000001u)
53#define IF(((3) << 2) | 0xF8000001u) CONTINUATION(3)(((3) << 2) | 0xF8000001u)
54#define PROGN_REST(((4) << 2) | 0xF8000001u) CONTINUATION(4)(((4) << 2) | 0xF8000001u)
55#define APPLICATION_ARGS(((5) << 2) | 0xF8000001u) CONTINUATION(5)(((5) << 2) | 0xF8000001u)
56#define AND(((6) << 2) | 0xF8000001u) CONTINUATION(6)(((6) << 2) | 0xF8000001u)
57#define OR(((7) << 2) | 0xF8000001u) CONTINUATION(7)(((7) << 2) | 0xF8000001u)
58#define WAIT(((8) << 2) | 0xF8000001u) CONTINUATION(8)(((8) << 2) | 0xF8000001u)
59#define MATCH(((9) << 2) | 0xF8000001u) CONTINUATION(9)(((9) << 2) | 0xF8000001u)
60#define APPLICATION_START(((10) << 2) | 0xF8000001u) CONTINUATION(10)(((10) << 2) | 0xF8000001u)
61#define EVAL_R(((11) << 2) | 0xF8000001u) CONTINUATION(11)(((11) << 2) | 0xF8000001u)
62#define RESUME(((12) << 2) | 0xF8000001u) CONTINUATION(12)(((12) << 2) | 0xF8000001u)
63#define CLOSURE_ARGS(((13) << 2) | 0xF8000001u) CONTINUATION(13)(((13) << 2) | 0xF8000001u)
64#define EXIT_ATOMIC(((14) << 2) | 0xF8000001u) CONTINUATION(14)(((14) << 2) | 0xF8000001u)
65#define READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u) CONTINUATION(15)(((15) << 2) | 0xF8000001u)
66#define READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u) CONTINUATION(16)(((16) << 2) | 0xF8000001u)
67#define READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u) CONTINUATION(17)(((17) << 2) | 0xF8000001u)
68#define READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u) CONTINUATION(18)(((18) << 2) | 0xF8000001u)
69#define READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u) CONTINUATION(19)(((19) << 2) | 0xF8000001u)
70#define READ_DONE(((20) << 2) | 0xF8000001u) CONTINUATION(20)(((20) << 2) | 0xF8000001u)
71#define READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u) CONTINUATION(21)(((21) << 2) | 0xF8000001u)
72#define READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u) CONTINUATION(22)(((22) << 2) | 0xF8000001u)
73#define READ_COMMA_RESULT(((23) << 2) | 0xF8000001u) CONTINUATION(23)(((23) << 2) | 0xF8000001u)
74#define READ_START_ARRAY(((24) << 2) | 0xF8000001u) CONTINUATION(24)(((24) << 2) | 0xF8000001u)
75#define READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u) CONTINUATION(25)(((25) << 2) | 0xF8000001u)
76#define MAP(((26) << 2) | 0xF8000001u) CONTINUATION(26)(((26) << 2) | 0xF8000001u)
77#define MATCH_GUARD(((27) << 2) | 0xF8000001u) CONTINUATION(27)(((27) << 2) | 0xF8000001u)
78#define TERMINATE(((28) << 2) | 0xF8000001u) CONTINUATION(28)(((28) << 2) | 0xF8000001u)
79#define PROGN_VAR(((29) << 2) | 0xF8000001u) CONTINUATION(29)(((29) << 2) | 0xF8000001u)
80#define SETQ(((30) << 2) | 0xF8000001u) CONTINUATION(30)(((30) << 2) | 0xF8000001u)
81#define MOVE_TO_FLASH(((31) << 2) | 0xF8000001u) CONTINUATION(31)(((31) << 2) | 0xF8000001u)
82#define MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u) CONTINUATION(32)(((32) << 2) | 0xF8000001u)
83#define MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u) CONTINUATION(33)(((33) << 2) | 0xF8000001u)
84#define CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u) CONTINUATION(34)(((34) << 2) | 0xF8000001u)
85#define QQ_EXPAND_START(((35) << 2) | 0xF8000001u) CONTINUATION(35)(((35) << 2) | 0xF8000001u)
86#define QQ_EXPAND(((36) << 2) | 0xF8000001u) CONTINUATION(36)(((36) << 2) | 0xF8000001u)
87#define QQ_APPEND(((37) << 2) | 0xF8000001u) CONTINUATION(37)(((37) << 2) | 0xF8000001u)
88#define QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u) CONTINUATION(38)(((38) << 2) | 0xF8000001u)
89#define QQ_LIST(((39) << 2) | 0xF8000001u) CONTINUATION(39)(((39) << 2) | 0xF8000001u)
90#define KILL(((40) << 2) | 0xF8000001u) CONTINUATION(40)(((40) << 2) | 0xF8000001u)
91#define LOOP(((41) << 2) | 0xF8000001u) CONTINUATION(41)(((41) << 2) | 0xF8000001u)
92#define LOOP_CONDITION(((42) << 2) | 0xF8000001u) CONTINUATION(42)(((42) << 2) | 0xF8000001u)
93#define MERGE_REST(((43) << 2) | 0xF8000001u) CONTINUATION(43)(((43) << 2) | 0xF8000001u)
94#define MERGE_LAYER(((44) << 2) | 0xF8000001u) CONTINUATION(44)(((44) << 2) | 0xF8000001u)
95#define CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u) CONTINUATION(45)(((45) << 2) | 0xF8000001u)
96#define MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u) CONTINUATION(46)(((46) << 2) | 0xF8000001u)
97#define POP_READER_FLAGS(((47) << 2) | 0xF8000001u) CONTINUATION(47)(((47) << 2) | 0xF8000001u)
98#define EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u) CONTINUATION(48)(((48) << 2) | 0xF8000001u)
99#define NUM_CONTINUATIONS49 49
100
101#define FM_NEED_GC-1 -1
102#define FM_NO_MATCH-2 -2
103#define FM_PATTERN_ERROR-3 -3
104
105typedef enum {
106 BL_OK = 0,
107 BL_NO_MEMORY,
108 BL_INCORRECT_KEY
109} binding_location_status;
110
111#define FB_OK0 0
112#define FB_TYPE_ERROR-1 -1
113
114const char* lbm_error_str_parse_eof = "End of parse stream.";
115const char* lbm_error_str_parse_dot = "Incorrect usage of '.'.";
116const char* lbm_error_str_parse_close = "Expected closing parenthesis.";
117const char* lbm_error_str_num_args = "Incorrect number of arguments.";
118const char* lbm_error_str_forbidden_in_atomic = "Operation is forbidden in an atomic block.";
119const char* lbm_error_str_no_number = "Argument(s) must be a number.";
120const char* lbm_error_str_not_a_boolean = "Argument must be t or nil (true or false).";
121const char* lbm_error_str_incorrect_arg = "Incorrect argument.";
122const char* lbm_error_str_var_outside_progn = "Usage of var outside of progn.";
123const char* lbm_error_str_flash_not_possible = "Value cannot be written to flash.";
124const char* lbm_error_str_flash_error = "Error writing to flash.";
125const char* lbm_error_str_flash_full = "Flash memory is full.";
126const char* lbm_error_str_variable_not_bound = "Variable not bound.";
127
128static lbm_value lbm_error_suspect;
129static bool_Bool lbm_error_has_suspect = false0;
130#ifdef LBM_ALWAYS_GC
131
132#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
133 gc(); \
134 (y) = (x); \
135 if (lbm_is_symbol_merror((y))) { \
136 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
137 }
138
139#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
140 lbm_gc_mark_phase(r); \
141 gc(); \
142 (y) = (x); \
143 if (lbm_is_symbol_merror((y))) { \
144 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
145 }
146
147#else
148
149#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
150 (y) = (x); \
151 if (lbm_is_symbol_merror((y))) { \
152 gc(); \
153 (y) = (x); \
154 if (lbm_is_symbol_merror((y))) { \
155 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
156 } \
157 /* continue executing statements below */ \
158 }
159#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
160 (y) = (x); \
161 if (lbm_is_symbol_merror((y))) { \
162 lbm_gc_mark_phase(r); \
163 gc(); \
164 (y) = (x); \
165 if (lbm_is_symbol_merror((y))) { \
166 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
167 } \
168 /* continue executing statements below */ \
169 }
170
171#endif
172
173typedef struct {
174 eval_context_t *first;
175 eval_context_t *last;
176} eval_context_queue_t;
177
178#ifdef CLEAN_UP_CLOSURES
179static lbm_value clean_cl_env_symbol = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
180#endif
181
182static int gc(void);
183static void error_ctx(lbm_value);
184static void error_at_ctx(lbm_value err_val, lbm_value at);
185static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx);
186static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail);
187
188// The currently executing context.
189eval_context_t *ctx_running = NULL((void*)0);
190volatile bool_Bool lbm_system_sleeping = false0;
191
192static volatile bool_Bool gc_requested = false0;
193void lbm_request_gc(void) {
194 gc_requested = true1;
195}
196
197/*
198 On ChibiOs the CH_CFG_ST_FREQUENCY setting in chconf.h sets the
199 resolution of the timer used for sleep operations. If this is set
200 to 10KHz the resolution is 100us.
201
202 The CH_CFG_ST_TIMEDELTA specifies the minimum number of ticks that
203 can be safely specified in a timeout directive (wonder if that
204 means sleep-period). The timedelta is set to 2.
205
206 If I have understood these correctly it means that the minimum
207 sleep duration possible is 2 * 100us = 200us.
208*/
209
210#define EVAL_CPS_DEFAULT_STACK_SIZE256 256
211#define EVAL_CPS_MIN_SLEEP200 200
212#define EVAL_STEPS_QUOTA10 10
213
214static volatile uint32_t eval_steps_refill = EVAL_STEPS_QUOTA10;
215static uint32_t eval_steps_quota = EVAL_STEPS_QUOTA10;
216
217void lbm_set_eval_step_quota(uint32_t quota) {
218 eval_steps_refill = quota;
219}
220
221static uint32_t eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
222static volatile uint32_t eval_cps_next_state = EVAL_CPS_STATE_NONE0;
223static volatile uint32_t eval_cps_next_state_arg = 0;
224static volatile bool_Bool eval_cps_state_changed = false0;
225
226static void usleep_nonsense(uint32_t us) {
227 (void) us;
228}
229
230static bool_Bool dynamic_load_nonsense(const char *sym, const char **code) {
231 (void) sym;
232 (void) code;
233 return false0;
234}
235
236static uint32_t timestamp_nonsense(void) {
237 return 0;
238}
239
240static int printf_nonsense(const char *fmt, ...) {
241 (void) fmt;
242 return 0;
243}
244
245static void ctx_done_nonsense(eval_context_t *ctx) {
246 (void) ctx;
247}
248
249static void critical_nonsense(void) {
250 return;
251}
252
253static void (*critical_error_callback)(void) = critical_nonsense;
254static void (*usleep_callback)(uint32_t) = usleep_nonsense;
255static uint32_t (*timestamp_us_callback)(void) = timestamp_nonsense;
256static void (*ctx_done_callback)(eval_context_t *) = ctx_done_nonsense;
257static int (*printf_callback)(const char *, ...) = printf_nonsense;
258static bool_Bool (*dynamic_load_callback)(const char *, const char **) = dynamic_load_nonsense;
259
260void lbm_set_critical_error_callback(void (*fptr)(void)) {
261 if (fptr == NULL((void*)0)) critical_error_callback = critical_nonsense;
262 else critical_error_callback = fptr;
263}
264
265void lbm_set_usleep_callback(void (*fptr)(uint32_t)) {
266 if (fptr == NULL((void*)0)) usleep_callback = usleep_nonsense;
267 else usleep_callback = fptr;
268}
269
270void lbm_set_timestamp_us_callback(uint32_t (*fptr)(void)) {
271 if (fptr == NULL((void*)0)) timestamp_us_callback = timestamp_nonsense;
272 else timestamp_us_callback = fptr;
273}
274
275void lbm_set_ctx_done_callback(void (*fptr)(eval_context_t *)) {
276 if (fptr == NULL((void*)0)) ctx_done_callback = ctx_done_nonsense;
277 else ctx_done_callback = fptr;
278}
279
280void lbm_set_printf_callback(int (*fptr)(const char*, ...)){
281 if (fptr == NULL((void*)0)) printf_callback = printf_nonsense;
282 else printf_callback = fptr;
283}
284
285void lbm_set_dynamic_load_callback(bool_Bool (*fptr)(const char *, const char **)) {
286 if (fptr == NULL((void*)0)) dynamic_load_callback = dynamic_load_nonsense;
287 else dynamic_load_callback = fptr;
288}
289
290static volatile lbm_event_t *lbm_events = NULL((void*)0);
291static unsigned int lbm_events_head = 0;
292static unsigned int lbm_events_tail = 0;
293static unsigned int lbm_events_max = 0;
294static bool_Bool lbm_events_full = false0;
295static mutex_t lbm_events_mutex;
296static bool_Bool lbm_events_mutex_initialized = false0;
297static volatile lbm_cid lbm_event_handler_pid = -1;
298
299lbm_cid lbm_get_event_handler_pid(void) {
300 return lbm_event_handler_pid;
301}
302
303void lbm_set_event_handler_pid(lbm_cid pid) {
304 lbm_event_handler_pid = pid;
305}
306
307bool_Bool lbm_event_handler_exists(void) {
308 return(lbm_event_handler_pid > 0);
309}
310
311
312static bool_Bool event_internal(lbm_event_type_t event_type, lbm_uint parameter, lbm_uint buf_ptr, lbm_uint buf_len) {
313 bool_Bool r = false0;
314 if (lbm_events) {
315 mutex_lock(&lbm_events_mutex);
316 if (!lbm_events_full) {
317 lbm_event_t event;
318 event.type = event_type;
319 event.parameter = parameter;
320 event.buf_ptr = buf_ptr;
321 event.buf_len = buf_len;
322 lbm_events[lbm_events_head] = event;
323 lbm_events_head = (lbm_events_head + 1) % lbm_events_max;
324 lbm_events_full = lbm_events_head == lbm_events_tail;
325 r = true1;
326 }
327 mutex_unlock(&lbm_events_mutex);
328 }
329 return r;
330}
331
332bool_Bool lbm_event_define(lbm_value key, lbm_flat_value_t *fv) {
333 return event_internal(LBM_EVENT_DEFINE, key, (lbm_uint)fv->buf, fv->buf_size);
334}
335
336bool_Bool lbm_event_unboxed(lbm_value unboxed) {
337 lbm_uint t = lbm_type_of(unboxed);
338 if (t == LBM_TYPE_SYMBOL0x00000000u ||
339 t == LBM_TYPE_I0x00000008u ||
340 t == LBM_TYPE_U0x0000000Cu ||
341 t == LBM_TYPE_CHAR0x00000004u) {
342 if (lbm_event_handler_pid > 0) {
343 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)unboxed, 0);
344 }
345 }
346 return false0;
347}
348
349bool_Bool lbm_event(lbm_flat_value_t *fv) {
350 if (lbm_event_handler_pid > 0) {
351 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)fv->buf, fv->buf_size);
352 }
353 return false0;
354}
355
356static bool_Bool lbm_event_pop(lbm_event_t *event) {
357 mutex_lock(&lbm_events_mutex);
358 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
359 mutex_unlock(&lbm_events_mutex);
360 return false0;
361 }
362 *event = lbm_events[lbm_events_tail];
363 lbm_events_tail = (lbm_events_tail + 1) % lbm_events_max;
364 lbm_events_full = false0;
365 mutex_unlock(&lbm_events_mutex);
366 return true1;
367}
368
369bool_Bool lbm_event_queue_is_empty(void) {
370 mutex_lock(&lbm_events_mutex);
371 bool_Bool empty = false0;
372 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
373 empty = true1;
374 }
375 mutex_unlock(&lbm_events_mutex);
376 return empty;
377}
378
379static bool_Bool eval_running = false0;
380static volatile bool_Bool blocking_extension = false0;
381static mutex_t blocking_extension_mutex;
382static bool_Bool blocking_extension_mutex_initialized = false0;
383static lbm_uint blocking_extension_timeout_us = 0;
384static bool_Bool blocking_extension_timeout = false0;
385
386static uint32_t is_atomic = 0;
387
388/* Process queues */
389static eval_context_queue_t blocked = {NULL((void*)0), NULL((void*)0)};
390static eval_context_queue_t queue = {NULL((void*)0), NULL((void*)0)};
391
392/* one mutex for all queue operations */
393mutex_t qmutex;
394bool_Bool qmutex_initialized = false0;
395
396
397// MODES
398static volatile bool_Bool lbm_verbose = false0;
399
400void lbm_toggle_verbose(void) {
401 lbm_verbose = !lbm_verbose;
402}
403
404void lbm_set_verbose(bool_Bool verbose) {
405 lbm_verbose = verbose;
406}
407
408lbm_cid lbm_get_current_cid(void) {
409 if (ctx_running)
410 return ctx_running->id;
411 else
412 return -1;
413}
414
415eval_context_t *lbm_get_current_context(void) {
416 return ctx_running;
417}
418
419/****************************************************/
420/* Utilities used locally in this file */
421
422static lbm_value cons_with_gc(lbm_value head, lbm_value tail, lbm_value remember) {
423#ifdef LBM_ALWAYS_GC
424 lbm_value roots[3] = {head, tail, remember};
425 lbm_gc_mark_roots(roots, 3);
426 gc();
427 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
428 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
429 if (lbm_is_symbol_merror(res)) {
430 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
431 }
432 return res;
433#else
434 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
435 if (lbm_is_symbol_merror(res)) {
436 lbm_value roots[3] = {head, tail, remember};
437 lbm_gc_mark_roots(roots,3);
438 gc();
439 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
440 if (lbm_is_symbol_merror(res)) {
441 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
442 }
443 }
444 return res;
445#endif
446}
447
448static lbm_uint *get_stack_ptr(eval_context_t *ctx, unsigned int n) {
449 if (n <= ctx->K.sp) {
450 lbm_uint index = ctx->K.sp - n;
451 return &ctx->K.data[index];
452 }
453 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
454 return 0; // dead code cannot be reached, but C compiler doesn't realise.
455}
456
457// pop_stack_ptr is safe when no GC is performed and
458// the values of the stack will be dropped.
459static lbm_uint *pop_stack_ptr(eval_context_t *ctx, unsigned int n) {
460 if (n <= ctx->K.sp) {
461 ctx->K.sp -= n;
462 return &ctx->K.data[ctx->K.sp];
463 }
464 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
465 return 0; // dead code cannot be reached, but C compiler doesn't realise.
466}
467
468static inline lbm_uint *stack_reserve(eval_context_t *ctx, unsigned int n) {
469 if (ctx->K.sp + n < ctx->K.size) {
470 lbm_uint *ptr = &ctx->K.data[ctx->K.sp];
471 ctx->K.sp += n;
472 return ptr;
473 }
474 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
475 return 0; // dead code cannot be reached, but C compiler doesn't realise.
476}
477
478static void handle_flash_status(lbm_flash_status s) {
479 if ( s == LBM_FLASH_FULL) {
480 lbm_set_error_reason((char*)lbm_error_str_flash_full);
481 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
482 }
483 if (s == LBM_FLASH_WRITE_ERROR) {
484 lbm_set_error_reason((char*)lbm_error_str_flash_error);
485 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
486 }
487}
488
489static void lift_array_flash(lbm_value flash_cell, bool_Bool bytearray, char *data, lbm_uint num_elt) {
490
491 lbm_array_header_t flash_array_header;
492 flash_array_header.size = num_elt;
493 flash_array_header.data = (lbm_uint*)data;
494 lbm_uint flash_array_header_ptr;
495 handle_flash_status(lbm_write_const_raw((lbm_uint*)&flash_array_header,
496 sizeof(lbm_array_header_t) / sizeof(lbm_uint),
497 &flash_array_header_ptr));
498 handle_flash_status(write_const_car(flash_cell, flash_array_header_ptr));
499 lbm_uint t = bytearray ? ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u) : ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u);
500 handle_flash_status(write_const_cdr(flash_cell, t));
501}
502
503static void get_car_and_cdr(lbm_value a, lbm_value *a_car, lbm_value *a_cdr) {
504 if (lbm_is_ptr(a)) {
2
←
Assuming the condition is true
→
3
←
Taking true branch
→
17
←
Assuming the condition is false
→
18
←
Taking false branch
→
505 lbm_cons_t *cell = lbm_ref_cell(a);
506 *a_car = cell->car;
507 *a_cdr = cell->cdr;
4
←
Value assigned to 'cdr_params', which participates in a condition later
→
508 } else if (lbm_is_symbol_nil(a)) {
19
←
Taking false branch
→
509 *a_car = *a_cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
510 } else {
511 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
512 }
513}
20
←
Returning without writing to '*a_car'
→
514
515/* car cdr caar cadr replacements that are evaluator safe. */
516static lbm_value get_car(lbm_value a) {
517 if (lbm_is_ptr(a)) {
518 lbm_cons_t *cell = lbm_ref_cell(a);
519 return cell->car;
520 } else if (lbm_is_symbol_nil(a)) {
521 return a;
522 }
523 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
524 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
525}
526
527static lbm_value get_cdr(lbm_value a) {
528 if (lbm_is_ptr(a)) {
529 lbm_cons_t *cell = lbm_ref_cell(a);
530 return cell->cdr;
531 } else if (lbm_is_symbol_nil(a)) {
532 return a;
533 }
534 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
535 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
536}
537
538static lbm_value get_cadr(lbm_value a) {
539 if (lbm_is_ptr(a)) {
540 lbm_cons_t *cell = lbm_ref_cell(a);
541 lbm_value tmp = cell->cdr;
542 if (lbm_is_ptr(tmp)) {
543 return lbm_ref_cell(tmp)->car;
544 } else if (lbm_is_symbol_nil(tmp)) {
545 return tmp;
546 }
547 } else if (lbm_is_symbol_nil(a)) {
548 return a;
549 }
550 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
551 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
552}
553
554static lbm_value allocate_closure(lbm_value params, lbm_value body, lbm_value env) {
555
556#ifdef LBM_ALWAYS_GC
557 gc();
558 if (lbm_heap_num_free() < 4) {
559 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
560 }
561#else
562 if (lbm_heap_num_free() < 4) {
563 gc();
564 if (lbm_heap_num_free() < 4) {
565 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
566 }
567 }
568#endif
569 // The freelist will always contain just plain heap-cells.
570 // So dec_ptr is sufficient.
571 lbm_value res = lbm_heap_state.freelist;
572 if (lbm_type_of(res) == LBM_TYPE_CONS0x10000000u) {
573 lbm_cons_t *heap = lbm_heap_state.heap;
574 lbm_uint ix = lbm_dec_ptr(res);
575 heap[ix].car = ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u);
576 ix = lbm_dec_ptr(heap[ix].cdr);
577 heap[ix].car = params;
578 ix = lbm_dec_ptr(heap[ix].cdr);
579 heap[ix].car = body;
580 ix = lbm_dec_ptr(heap[ix].cdr);
581 heap[ix].car = env;
582 lbm_heap_state.freelist = heap[ix].cdr;
583 heap[ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
584 lbm_heap_state.num_alloc+=4;
585 } else {
586 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
587 }
588 return res;
589}
590
591// Allocate a binding and attach it to a list (if so desired)
592static lbm_value allocate_binding(lbm_value key, lbm_value val, lbm_value the_cdr) {
593 if (lbm_heap_num_free() < 2) {
594 gc();
595 if (lbm_heap_num_free() < 2) {
596 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
597 }
598 }
599 lbm_cons_t* heap = lbm_heap_state.heap;
600 lbm_value binding_cell = lbm_heap_state.freelist;
601 lbm_uint binding_cell_ix = lbm_dec_ptr(binding_cell);
602 lbm_value list_cell = heap[binding_cell_ix].cdr;
603 lbm_uint list_cell_ix = lbm_dec_ptr(list_cell);
604 lbm_heap_state.freelist = heap[list_cell_ix].cdr;
605 lbm_heap_state.num_alloc += 2;
606 heap[binding_cell_ix].car = key;
607 heap[binding_cell_ix].cdr = val;
608 heap[list_cell_ix].car = binding_cell;
609 heap[list_cell_ix].cdr = the_cdr;
610 return list_cell;
611}
612
613#define CLO_PARAMS0 0
614#define CLO_BODY1 1
615#define CLO_ENV2 2
616#define LOOP_BINDS0 0
617#define LOOP_COND1 1
618#define LOOP_BODY2 2
619
620// (a b c) -> [a b c]
621static lbm_value extract_n(lbm_value curr, lbm_value *res, unsigned int n) {
622 for (unsigned int i = 0; i < n; i ++) {
623 if (lbm_is_ptr(curr)) {
624 lbm_cons_t *cell = lbm_ref_cell(curr);
625 res[i] = cell->car;
626 curr = cell->cdr;
627 } else {
628 res[i] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
629 }
630 }
631 return curr; // Rest of list is returned here.
632}
633
634static void call_fundamental(lbm_uint fundamental, lbm_value *args, lbm_uint arg_count, eval_context_t *ctx) {
635 lbm_value res;
636 res = fundamental_table[fundamental](args, arg_count, ctx);
637 if (lbm_is_error(res)) {
638 if (lbm_is_symbol_merror(res)) {
639 gc();
640 res = fundamental_table[fundamental](args, arg_count, ctx);
641 }
642 if (lbm_is_error(res)) {
643 error_at_ctx(res, lbm_enc_sym(FUNDAMENTAL_SYMBOLS_START0x20000 | fundamental));
644 }
645 }
646 lbm_stack_drop(&ctx->K, arg_count+1);
647 ctx->app_cont = true1;
648 ctx->r = res;
649}
650
651// block_current_ctx blocks a context until it is
652// woken up externally or a timeout period of time passes.
653static void block_current_ctx(uint32_t state, lbm_uint sleep_us, bool_Bool do_cont) {
654 ctx_running->timestamp = timestamp_us_callback();
655 ctx_running->sleep_us = sleep_us;
656 ctx_running->state = state;
657 ctx_running->app_cont = do_cont;
658 enqueue_ctx(&blocked, ctx_running);
659 ctx_running = NULL((void*)0);
660}
661
662lbm_flash_status lbm_write_const_array_padded(uint8_t *data, lbm_uint n, lbm_uint *res) {
663 lbm_uint full_words = n / sizeof(lbm_uint);
664 lbm_uint n_mod = n % sizeof(lbm_uint);
665
666 if (n_mod == 0) { // perfect fit.
667 return lbm_write_const_raw((lbm_uint*)data, full_words, res);
668 } else {
669 lbm_uint last_word = 0;
670 memcpy(&last_word, &data[full_words * sizeof(lbm_uint)], n_mod);
671 if (full_words >= 1) {
672 lbm_flash_status s = lbm_write_const_raw((lbm_uint*)data, full_words, res);
673 if ( s == LBM_FLASH_WRITE_OK) {
674 lbm_uint dummy;
675 s = lbm_write_const_raw(&last_word, 1, &dummy);
676 }
677 return s;
678 } else {
679 return lbm_write_const_raw(&last_word, 1, res);
680 }
681 }
682}
683
684/****************************************************/
685/* Error message creation */
686
687#define ERROR_MESSAGE_BUFFER_SIZE_BYTES256 256
688
689void print_environments(char *buf, unsigned int size) {
690
691 lbm_value curr_l = ctx_running->curr_env;
692 printf_callback("\tCurrent local environment:\n");
693 while (lbm_type_of(curr_l) == LBM_TYPE_CONS0x10000000u) {
694 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_l));
695 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_l)));
696 printf_callback("\t%s = %s\n", buf, buf+(size/2));
697 curr_l = lbm_cdr(curr_l);
698 }
699 printf_callback("\n\n");
700 printf_callback("\tCurrent global environment:\n");
701 lbm_value *glob_env = lbm_get_global_env();
702
703 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
704 lbm_value curr_g = glob_env[i];;
705 while (lbm_type_of(curr_g) == LBM_TYPE_CONS0x10000000u) {
706
707 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_g));
708 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_g)));
709 printf_callback("\t%s = %s\n", buf, buf+(size/2));
710 curr_g = lbm_cdr(curr_g);
711 }
712 }
713}
714
715void print_error_message(lbm_value error, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int col, lbm_int row0, lbm_int row1) {
716 if (!printf_callback) return;
717
718 /* try to allocate a lbm_print_value buffer on the lbm_memory */
719 char *buf = lbm_malloc_reserve(ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
720 if (!buf) {
721 printf_callback("Error: Not enough free memory to create a human readable error message\n");
722 return;
723 }
724
725 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, error);
726 printf_callback( "*** Error: %s\n", buf);
727 if (has_at) {
728 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, at);
729 printf_callback("*** In: %s\n",buf);
730 if (lbm_error_has_suspect) {
731 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, lbm_error_suspect);
732 lbm_error_has_suspect = false0;
733 printf_callback("*** At: %s\n", buf);
734 } else {
735 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
736 printf_callback("*** After: %s\n",buf);
737 }
738 } else {
739 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
740 printf_callback("*** Near: %s\n",buf);
741 }
742
743 printf_callback("\n");
744
745 if (lbm_is_symbol(error) &&
746 error == ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u)) {
747 printf_callback("*** Line: %u\n", row);
748 printf_callback("*** Column: %u\n", col);
749 } else if (row0 != -1 || row1 != -1 ) {
750 printf_callback("*** Between rows: (-1 unknown) \n");
751 printf_callback("*** Start: %d\n", (int32_t)row0);
752 printf_callback("*** End: %d\n", (int32_t)row1);
753 }
754
755 printf_callback("\n");
756
757 if (ctx_running->error_reason) {
758 printf_callback("Reason:\n %s\n\n", ctx_running->error_reason);
759 }
760 if (lbm_verbose) {
761 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
762 printf_callback(" In context: %d\n", ctx_running->id);
763 printf_callback(" Current intermediate result: %s\n\n", buf);
764
765 print_environments(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
766 printf_callback("\n\n");
767
768 printf_callback(" Stack:\n");
769 for (unsigned int i = 0; i < ctx_running->K.sp; i ++) {
770 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->K.data[i]);
771 printf_callback(" %s\n", buf);
772 }
773 }
774 lbm_free(buf);
775}
776
777/****************************************************/
778/* Tokenizing and parsing */
779
780bool_Bool create_string_channel(char *str, lbm_value *res) {
781
782 lbm_char_channel_t *chan = NULL((void*)0);
783 lbm_string_channel_state_t *st = NULL((void*)0);
784
785 st = (lbm_string_channel_state_t*)lbm_memory_allocate(sizeof(lbm_string_channel_state_t) / sizeof(lbm_uint) +1);
786 if (st == NULL((void*)0)) {
787 return false0;
788 }
789 chan = (lbm_char_channel_t*)lbm_memory_allocate(sizeof(lbm_char_channel_t) / sizeof(lbm_uint) + 1);
790 if (chan == NULL((void*)0)) {
791 lbm_memory_free((lbm_uint*)st);
792 return false0;
793 }
794
795 lbm_create_string_char_channel(st, chan, str);
796 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
797 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
798 lbm_memory_free((lbm_uint*)st);
799 lbm_memory_free((lbm_uint*)chan);
800 return false0;
801 }
802
803 *res = cell;
804 return true1;
805}
806
807bool_Bool lift_char_channel(lbm_char_channel_t *chan , lbm_value *res) {
808 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
809 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
810 return false0;
811 }
812 *res = cell;
813 return true1;
814}
815
816
817/****************************************************/
818/* Queue functions */
819
820static void queue_iterator_nm(eval_context_queue_t *q, ctx_fun f, void *arg1, void *arg2) {
821 eval_context_t *curr;
822 curr = q->first;
823
824 while (curr != NULL((void*)0)) {
825 f(curr, arg1, arg2);
826 curr = curr->next;
827 }
828}
829
830void lbm_running_iterator(ctx_fun f, void *arg1, void *arg2){
831 mutex_lock(&qmutex);
832 queue_iterator_nm(&queue, f, arg1, arg2);
833 mutex_unlock(&qmutex);
834}
835
836void lbm_blocked_iterator(ctx_fun f, void *arg1, void *arg2){
837 mutex_lock(&qmutex);
838 queue_iterator_nm(&blocked, f, arg1, arg2);
839 mutex_unlock(&qmutex);
840}
841
842static void enqueue_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
843 if (q->last == NULL((void*)0)) {
844 ctx->prev = NULL((void*)0);
845 ctx->next = NULL((void*)0);
846 q->first = ctx;
847 q->last = ctx;
848 } else {
849 ctx->prev = q->last;
850 ctx->next = NULL((void*)0);
851 q->last->next = ctx;
852 q->last = ctx;
853 }
854}
855
856static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx) {
857 mutex_lock(&qmutex);
858 enqueue_ctx_nm(q,ctx);
859 mutex_unlock(&qmutex);
860}
861
862static eval_context_t *lookup_ctx_nm(eval_context_queue_t *q, lbm_cid cid) {
863 eval_context_t *curr;
864 curr = q->first;
865 while (curr != NULL((void*)0)) {
866 if (curr->id == cid) {
867 return curr;
868 }
869 curr = curr->next;
870 }
871 return NULL((void*)0);
872}
873
874static bool_Bool drop_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
875
876 bool_Bool res = false0;
877 if (q->first == NULL((void*)0) || q->last == NULL((void*)0)) {
878 if (!(q->last == NULL((void*)0) && q->first == NULL((void*)0))) {
879 /* error state that should not happen */
880 return res;
881 }
882 /* Queue is empty */
883 return res;
884 }
885
886 eval_context_t *curr = q->first;
887 while (curr) {
888 if (curr->id == ctx->id) {
889 res = true1;
890 eval_context_t *tmp = curr->next;
891 if (curr->prev == NULL((void*)0)) {
892 if (curr->next == NULL((void*)0)) {
893 q->last = NULL((void*)0);
894 q->first = NULL((void*)0);
895 } else {
896 q->first = tmp;
897 tmp->prev = NULL((void*)0);
898 }
899 } else { /* curr->prev != NULL */
900 if (curr->next == NULL((void*)0)) {
901 q->last = curr->prev;
902 q->last->next = NULL((void*)0);
903 } else {
904 curr->prev->next = tmp;
905 tmp->prev = curr->prev;
906 }
907 }
908 break;
909 }
910 curr = curr->next;
911 }
912 return res;
913}
914
915/* End execution of the running context. */
916static void finish_ctx(void) {
917
918 if (!ctx_running) {
919 return;
920 }
921 /* Drop the continuation stack immediately to free up lbm_memory */
922 lbm_stack_free(&ctx_running->K);
923 ctx_done_callback(ctx_running);
924 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->name)) {
925 lbm_free(ctx_running->name);
926 }
927 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->error_reason)) {
928 lbm_memory_free((lbm_uint*)ctx_running->error_reason);
929 }
930 lbm_memory_free((lbm_uint*)ctx_running->mailbox);
931 lbm_memory_free((lbm_uint*)ctx_running);
932 ctx_running = NULL((void*)0);
933}
934
935static void context_exists(eval_context_t *ctx, void *cid, void *b) {
936 if (ctx->id == *(lbm_cid*)cid) {
937 *(bool_Bool*)b = true1;
938 }
939}
940
941bool_Bool lbm_wait_ctx(lbm_cid cid, lbm_uint timeout_ms) {
942
943 bool_Bool exists;
944 uint32_t i = 0;
945
946 do {
947 exists = false0;
948 lbm_blocked_iterator(context_exists, &cid, &exists);
949 lbm_running_iterator(context_exists, &cid, &exists);
950
951 if (ctx_running &&
952 ctx_running->id == cid) {
953 exists = true1;
954 }
955
956 if (exists) {
957 if (usleep_callback) {
958 usleep_callback(1000);
959 }
960 if (timeout_ms > 0) i ++;
961 }
962 } while (exists && i < timeout_ms);
963
964 if (exists) return false0;
965 return true1;
966}
967
968void lbm_set_error_suspect(lbm_value suspect) {
969 lbm_error_suspect = suspect;
970 lbm_error_has_suspect = true1;
971}
972
973void lbm_set_error_reason(char *error_str) {
974 if (ctx_running != NULL((void*)0)) {
975 ctx_running->error_reason = error_str;
976 }
977}
978
979// Not possible to CONS_WITH_GC in error_ctx_base (potential loop)
980static void error_ctx_base(lbm_value err_val, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int column) {
981
982 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
983 if (lbm_heap_num_free() < 3) {
984 gc();
985 }
986
987 if (lbm_heap_num_free() >= 3) {
988 lbm_value msg = lbm_cons(err_val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
989 msg = lbm_cons(lbm_enc_i(ctx_running->id), msg);
990 msg = lbm_cons(ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u), msg);
991 if (!lbm_is_symbol_merror(msg)) {
992 lbm_find_receiver_and_send(ctx_running->parent, msg);
993 goto error_ctx_base_done;
994 }
995 }
996 }
997 if ((ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10) &&
998 (err_val != ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u))) {
999 lbm_uint v;
1000 while (ctx_running->K.sp > 0) {
1001 lbm_pop(&ctx_running->K, &v);
1002 if (v == EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u)) {
1003 lbm_value *sptr = get_stack_ptr(ctx_running, 2);
1004 lbm_set_car(sptr[0], ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
1005 stack_reserve(ctx_running, 1)[0] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1006 ctx_running->app_cont = true1;
1007 ctx_running->r = err_val;
1008 longjmp(error_jmp_buf, 1);
1009 }
1010 }
1011 err_val = ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u);
1012 }
1013 print_error_message(err_val,
1014 has_at,
1015 at,
1016 row,
1017 column,
1018 ctx_running->row0,
1019 ctx_running->row1);
1020 error_ctx_base_done:
1021 ctx_running->r = err_val;
1022 finish_ctx();
1023 longjmp(error_jmp_buf, 1);
1024}
1025
1026static void error_at_ctx(lbm_value err_val, lbm_value at) {
1027 error_ctx_base(err_val, true1, at, 0, 0);
1028}
1029
1030static void error_ctx(lbm_value err_val) {
1031 error_ctx_base(err_val, false0, 0, 0, 0);
1032}
1033
1034static void read_error_ctx(unsigned int row, unsigned int column) {
1035 error_ctx_base(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u), false0, 0, row, column);
1036}
1037
1038void lbm_critical_error(void) {
1039 longjmp(critical_error_jmp_buf, 1);
1040}
1041
1042// successfully finish a context
1043static void ok_ctx(void) {
1044 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
1045 lbm_value msg;
1046 WITH_GC(msg, lbm_heap_allocate_list_init(3,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1047 ENC_SYM_EXIT_OK,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1048 lbm_enc_i(ctx_running->id),(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1049 ctx_running->r))(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
1050 lbm_find_receiver_and_send(ctx_running->parent, msg);
1051 }
1052 finish_ctx();
1053}
1054
1055static eval_context_t *dequeue_ctx_nm(eval_context_queue_t *q) {
1056 if (q->last == NULL((void*)0)) {
1057 return NULL((void*)0);
1058 }
1059 // q->first should only be NULL if q->last is.
1060 eval_context_t *res = q->first;
1061
1062 if (q->first == q->last) { // One thing in queue
1063 q->first = NULL((void*)0);
1064 q->last = NULL((void*)0);
1065 } else {
1066 q->first = q->first->next;
1067 q->first->prev = NULL((void*)0);
1068 }
1069 res->prev = NULL((void*)0);
1070 res->next = NULL((void*)0);
1071 return res;
1072}
1073
1074static void wake_up_ctxs_nm(void) {
1075 lbm_uint t_now;
1076
1077 if (timestamp_us_callback) {
1078 t_now = timestamp_us_callback();
1079 } else {
1080 t_now = 0;
1081 }
1082
1083 eval_context_queue_t *q = &blocked;
1084 eval_context_t *curr = q->first;
1085
1086 while (curr != NULL((void*)0)) {
1087 lbm_uint t_diff;
1088 eval_context_t *next = curr->next;
1089 if (curr->state != LBM_THREAD_STATE_BLOCKED(uint32_t)1) {
1090 if ( curr->timestamp > t_now) {
1091 /* There was an overflow on the counter */
1092#ifndef LBM64
1093 t_diff = (0xFFFFFFFF - curr->timestamp) + t_now;
1094#else
1095 t_diff = (0xFFFFFFFFFFFFFFFF - curr->timestamp) + t_now;
1096#endif
1097 } else {
1098 t_diff = t_now - curr->timestamp;
1099 }
1100
1101 if (t_diff >= curr->sleep_us) {
1102 eval_context_t *wake_ctx = curr;
1103 if (curr == q->last) {
1104 if (curr->prev) {
1105 q->last = curr->prev;
1106 q->last->next = NULL((void*)0);
1107 } else {
1108 q->first = NULL((void*)0);
1109 q->last = NULL((void*)0);
1110 }
1111 } else if (curr->prev == NULL((void*)0)) {
1112 q->first = curr->next;
1113 q->first->prev = NULL((void*)0);
1114 } else {
1115 curr->prev->next = curr->next;
1116 if (curr->next) {
1117 curr->next->prev = curr->prev;
1118 }
1119 }
1120 wake_ctx->next = NULL((void*)0);
1121 wake_ctx->prev = NULL((void*)0);
1122 if (curr->state == LBM_THREAD_STATE_TIMEOUT(uint32_t)2) {
1123 mailbox_add_mail(wake_ctx, ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u));
1124 wake_ctx->r = ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u);
1125 }
1126 wake_ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1127 enqueue_ctx_nm(&queue, wake_ctx);
1128 }
1129 }
1130 curr = next;
1131 }
1132}
1133
1134static void yield_ctx(lbm_uint sleep_us) {
1135 if (timestamp_us_callback) {
1136 ctx_running->timestamp = timestamp_us_callback();
1137 ctx_running->sleep_us = sleep_us;
1138 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1139 } else {
1140 ctx_running->timestamp = 0;
1141 ctx_running->sleep_us = 0;
1142 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1143 }
1144 ctx_running->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1145 ctx_running->app_cont = true1;
1146 enqueue_ctx(&blocked,ctx_running);
1147 ctx_running = NULL((void*)0);
1148}
1149
1150static lbm_cid lbm_create_ctx_parent(lbm_value program, lbm_value env, lbm_uint stack_size, lbm_cid parent, uint32_t context_flags, char *name) {
1151
1152 if (!lbm_is_cons(program)) return -1;
1153
1154 eval_context_t *ctx = NULL((void*)0);
1155
1156 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1157 if (ctx == NULL((void*)0)) {
1158 lbm_uint roots[2] = {program, env};
1159 lbm_gc_mark_roots(roots, 2);
1160 gc();
1161 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1162 }
1163 if (ctx == NULL((void*)0)) return -1;
1164
1165 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1166 lbm_uint roots[2] = {program, env};
1167 lbm_gc_mark_roots(roots, 2);
1168 gc();
1169 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1170 lbm_memory_free((lbm_uint*)ctx);
1171 return -1;
1172 }
1173 }
1174
1175 lbm_value *mailbox = NULL((void*)0);
1176 mailbox = (lbm_value*)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1177 if (mailbox == NULL((void*)0)) {
1178 lbm_value roots[2] = {program, env};
1179 lbm_gc_mark_roots(roots,2);
1180 gc();
1181 mailbox = (lbm_value *)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1182 }
1183 if (mailbox == NULL((void*)0)) {
1184 lbm_stack_free(&ctx->K);
1185 lbm_memory_free((lbm_uint*)ctx);
1186 return -1;
1187 }
1188
1189 // TODO: Limit names to 19 chars + 1 char for 0? (or something similar).
1190 if (name) {
1191 lbm_uint name_len = strlen(name) + 1;
1192 ctx->name = lbm_malloc(strlen(name) + 1);
1193 if (ctx->name == NULL((void*)0)) {
1194 lbm_value roots[2] = {program, env};
1195 lbm_gc_mark_roots(roots, 2);
1196 gc();
1197 ctx->name = lbm_malloc(strlen(name) + 1);
1198 }
1199 if (ctx->name == NULL((void*)0)) {
1200 lbm_stack_free(&ctx->K);
1201 lbm_memory_free((lbm_uint*)mailbox);
1202 lbm_memory_free((lbm_uint*)ctx);
1203 return -1;
1204 }
1205 memcpy(ctx->name, name, name_len+1);
1206 } else {
1207 ctx->name = NULL((void*)0);
1208 }
1209
1210 lbm_int cid = lbm_memory_address_to_ix((lbm_uint*)ctx);
1211
1212 ctx->program = lbm_cdr(program);
1213 ctx->curr_exp = lbm_car(program);
1214 ctx->curr_env = env;
1215 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1216 ctx->error_reason = NULL((void*)0);
1217 ctx->mailbox = mailbox;
1218 ctx->mailbox_size = EVAL_CPS_DEFAULT_MAILBOX_SIZE10;
1219 ctx->flags = context_flags;
1220 ctx->num_mail = 0;
1221 ctx->app_cont = false0;
1222 ctx->timestamp = 0;
1223 ctx->sleep_us = 0;
1224 ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1225 ctx->prev = NULL((void*)0);
1226 ctx->next = NULL((void*)0);
1227
1228 ctx->row0 = -1;
1229 ctx->row1 = -1;
1230
1231 ctx->id = cid;
1232 ctx->parent = parent;
1233
1234 if (!lbm_push(&ctx->K, DONE(((0) << 2) | 0xF8000001u))) {
1235 lbm_memory_free((lbm_uint*)ctx->mailbox);
1236 lbm_stack_free(&ctx->K);
1237 lbm_memory_free((lbm_uint*)ctx);
1238 return -1;
1239 }
1240
1241 enqueue_ctx(&queue,ctx);
1242
1243 return ctx->id;
1244}
1245
1246lbm_cid lbm_create_ctx(lbm_value program, lbm_value env, lbm_uint stack_size, char *name) {
1247 // Creates a parentless context.
1248 return lbm_create_ctx_parent(program,
1249 env,
1250 stack_size,
1251 -1,
1252 EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00,
1253 name);
1254}
1255
1256bool_Bool lbm_mailbox_change_size(eval_context_t *ctx, lbm_uint new_size) {
1257
1258 lbm_value *mailbox = NULL((void*)0);
1259 mailbox = (lbm_value*)lbm_memory_allocate(new_size);
1260 if (mailbox == NULL((void*)0)) {
1261 gc();
1262 mailbox = (lbm_value *)lbm_memory_allocate(new_size);
1263 }
1264 if (mailbox == NULL((void*)0)) {
1265 return false0;
1266 }
1267
1268 for (lbm_uint i = 0; i < ctx->num_mail; i ++ ) {
1269 mailbox[i] = ctx->mailbox[i];
1270 }
1271 lbm_memory_free(ctx->mailbox);
1272 ctx->mailbox = mailbox;
1273 ctx->mailbox_size = (uint32_t)new_size;
1274 return true1;
1275}
1276
1277static void mailbox_remove_mail(eval_context_t *ctx, lbm_uint ix) {
1278
1279 for (lbm_uint i = ix; i < ctx->num_mail-1; i ++) {
1280 ctx->mailbox[i] = ctx->mailbox[i+1];
1281 }
1282 ctx->num_mail --;
1283}
1284
1285static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail) {
1286
1287 if (ctx->num_mail >= ctx->mailbox_size) {
1288 mailbox_remove_mail(ctx, 0);
1289 }
1290
1291 ctx->mailbox[ctx->num_mail] = mail;
1292 ctx->num_mail ++;
1293 return true1;
1294}
1295
1296/* Advance execution to the next expression in the program */
1297static void advance_ctx(eval_context_t *ctx) {
1298 if (lbm_is_cons(ctx->program)) {
1299 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);;
1300 get_car_and_cdr(ctx->program, &ctx->curr_exp, &ctx->program);
1301 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1302 } else {
1303 if (ctx_running == ctx) { // This should always be the case because of odd historical reasons.
1304 ok_ctx();
1305 }
1306 }
1307}
1308
1309bool_Bool lbm_unblock_ctx(lbm_cid cid, lbm_flat_value_t *fv) {
1310 return event_internal(LBM_EVENT_UNBLOCK_CTX, (lbm_uint)cid, (lbm_uint)fv->buf, fv->buf_size);
1311}
1312
1313bool_Bool lbm_unblock_ctx_r(lbm_cid cid) {
1314 mutex_lock(&blocking_extension_mutex);
1315 bool_Bool r = false0;
1316 eval_context_t *found = NULL((void*)0);
1317 mutex_lock(&qmutex);
1318 found = lookup_ctx_nm(&blocked, cid);
1319 if (found) {
1320 drop_ctx_nm(&blocked,found);
1321 enqueue_ctx_nm(&queue,found);
1322 r = true1;
1323 }
1324 mutex_unlock(&qmutex);
1325 mutex_unlock(&blocking_extension_mutex);
1326 return r;
1327}
1328
1329// unblock unboxed is also safe for rmbr:ed things.
1330bool_Bool lbm_unblock_ctx_unboxed(lbm_cid cid, lbm_value unboxed) {
1331 mutex_lock(&blocking_extension_mutex);
1332 bool_Bool r = false0;
1333 eval_context_t *found = NULL((void*)0);
1334 mutex_lock(&qmutex);
1335 found = lookup_ctx_nm(&blocked, cid);
1336 if (found) {
1337 drop_ctx_nm(&blocked,found);
1338 found->r = unboxed;
1339 if (lbm_is_error(unboxed)) {
1340 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
1341 found->app_cont = true1;
1342 }
1343 enqueue_ctx_nm(&queue,found);
1344 r = true1;
1345 }
1346 mutex_unlock(&qmutex);
1347 mutex_unlock(&blocking_extension_mutex);
1348 return r;
1349}
1350
1351static bool_Bool lbm_block_ctx_base(bool_Bool timeout, float t_s) {
1352 mutex_lock(&blocking_extension_mutex);
1353 blocking_extension = true1;
1354 if (timeout) {
1355 blocking_extension_timeout_us = S_TO_US(t_s)(lbm_uint)((t_s) * 1000000);
1356 blocking_extension_timeout = true1;
1357 } else {
1358 blocking_extension_timeout = false0;
1359 }
1360 return true1;
1361}
1362
1363void lbm_block_ctx_from_extension_timeout(float s) {
1364 lbm_block_ctx_base(true1, s);
1365}
1366
1367void lbm_block_ctx_from_extension(void) {
1368 lbm_block_ctx_base(false0, 0);
1369}
1370
1371// todo: May need to pop rmbrs from stack, if present.
1372// Suspect that the letting the discard cont run is really not a problem.
1373// Either way will be quite confusing what happens to allocated things when undoing block.
1374void lbm_undo_block_ctx_from_extension(void) {
1375 blocking_extension = false0;
1376 blocking_extension_timeout_us = 0;
1377 blocking_extension_timeout = false0;
1378 mutex_unlock(&blocking_extension_mutex);
1379}
1380
1381lbm_value lbm_find_receiver_and_send(lbm_cid cid, lbm_value msg) {
1382 mutex_lock(&qmutex);
1383 eval_context_t *found = NULL((void*)0);
1384 bool_Bool found_blocked = false0;
1385
1386 found = lookup_ctx_nm(&blocked, cid);
1387 if (found) found_blocked = true1;
1388
1389 if (found == NULL((void*)0)) {
1390 found = lookup_ctx_nm(&queue, cid);
1391 }
1392
1393 if (found) {
1394 if (!mailbox_add_mail(found, msg)) {
1395 mutex_unlock(&qmutex);
1396 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1397 }
1398
1399 if (found_blocked){
1400 drop_ctx_nm(&blocked,found);
1401 enqueue_ctx_nm(&queue,found);
1402 }
1403 mutex_unlock(&qmutex);
1404 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1405 }
1406
1407 /* check the current context */
1408 if (ctx_running && ctx_running->id == cid) {
1409 if (!mailbox_add_mail(ctx_running, msg)) {
1410 mutex_unlock(&qmutex);
1411 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1412 }
1413 mutex_unlock(&qmutex);
1414 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1415 }
1416 mutex_unlock(&qmutex);
1417 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1418}
1419
1420/* Pattern matching is currently implemented as a recursive
1421 function and make use of stack relative to the size of
1422 expressions that are being matched. */
1423static bool_Bool match(lbm_value p, lbm_value e, lbm_value *env, bool_Bool *gc) {
1424
1425 lbm_value binding;
1426
1427 if (lbm_is_match_binder(p)) {
1428 lbm_value var = get_cadr(p);
1429 lbm_value bindertype = get_car(p);
1430
1431 if (!lbm_is_symbol(var)) return false0;
1432
1433 switch (bindertype) {
1434 case ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u):
1435 if ( var == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) {
1436 return true1;
1437 }
1438 break;
1439 default: /* this should be an error case */
1440 return false0;
1441 }
1442 binding = lbm_cons(var, e);
1443 if ( lbm_type_of(binding) == LBM_TYPE_SYMBOL0x00000000u ) {
1444 *gc = true1;
1445 return false0;
1446 }
1447 *env = lbm_cons(binding, *env);
1448 if ( lbm_type_of(*env) == LBM_TYPE_SYMBOL0x00000000u ) {
1449 *gc = true1;
1450 return false0;
1451 }
1452 return true1;
1453 }
1454
1455 if (lbm_is_symbol(p)) {
1456 if (p == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return true1;
1457 return (p == e);
1458 }
1459 if (lbm_is_cons(p) &&
1460 lbm_is_cons(e) ) {
1461
1462 lbm_value headp, tailp;
1463 lbm_value heade, taile;
1464 get_car_and_cdr(p, &headp, &tailp);
1465 get_car_and_cdr(e, &heade, &taile); // Static analysis warns, but execution does not
1466 // past this point unless head and tail get initialized.
1467 if (!match(headp, heade, env, gc)) {
1468 return false0;
1469 }
1470 return match (tailp, taile, env, gc);
1471 }
1472 return struct_eq(p, e);
1473}
1474
1475// Find match is not very picky about syntax.
1476// A completely malformed recv form is most likely to
1477// just return no_match.
1478static int find_match(lbm_value plist, lbm_value *earr, lbm_uint num, lbm_value *e, lbm_value *env) {
1479
1480 // A pattern list is a list of pattern, expression lists.
1481 // ( (p1 e1) (p2 e2) ... (pn en))
1482 lbm_value curr_p = plist;
1483 int n = 0;
1484 bool_Bool gc = false0;
1485 for (int i = 0; i < (int)num; i ++ ) {
1486 lbm_value curr_e = earr[i];
1487 while (!lbm_is_symbol_nil(curr_p)) {
1488 lbm_value me = get_car(curr_p);
1489 if (match(get_car(me), curr_e, env, &gc)) {
1490 if (gc) return FM_NEED_GC-1;
1491 *e = get_cadr(me);
1492
1493 if (!lbm_is_symbol_nil(get_cadr(get_cdr(me)))) {
1494 return FM_PATTERN_ERROR-3;
1495 }
1496 return n;
1497 }
1498 curr_p = get_cdr(curr_p);
1499 }
1500 curr_p = plist; /* search all patterns against next exp */
1501 n ++;
1502 }
1503
1504 return FM_NO_MATCH-2;
1505}
1506
1507/****************************************************/
1508/* Garbage collection */
1509
1510static void mark_context(eval_context_t *ctx, void *arg1, void *arg2) {
1511 (void) arg1;
1512 (void) arg2;
1513 lbm_value roots[3] = {ctx->curr_exp, ctx->program, ctx->r };
1514 lbm_gc_mark_env(ctx->curr_env);
1515 lbm_gc_mark_roots(roots, 3);
1516 lbm_gc_mark_roots(ctx->mailbox, ctx->num_mail);
1517 lbm_gc_mark_aux(ctx->K.data, ctx->K.sp);
1518}
1519
1520static int gc(void) {
1521 if (ctx_running) {
1522 ctx_running->state = ctx_running->state | LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1523 }
1524
1525 gc_requested = false0;
1526 lbm_gc_state_inc();
1527
1528 // The freelist should generally be NIL when GC runs.
1529 lbm_nil_freelist();
1530 lbm_value *env = lbm_get_global_env();
1531 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
1532 lbm_gc_mark_env(env[i]);
1533 }
1534
1535 mutex_lock(&qmutex); // Lock the queues.
1536 // Any concurrent messing with the queues
1537 // while doing GC cannot possibly be good.
1538 queue_iterator_nm(&queue, mark_context, NULL((void*)0), NULL((void*)0));
1539 queue_iterator_nm(&blocked, mark_context, NULL((void*)0), NULL((void*)0));
1540
1541 if (ctx_running) {
1542 mark_context(ctx_running, NULL((void*)0), NULL((void*)0));
1543 }
1544 mutex_unlock(&qmutex);
1545
1546#ifdef VISUALIZE_HEAP
1547 heap_vis_gen_image();
1548#endif
1549
1550 int r = lbm_gc_sweep_phase();
1551 lbm_heap_new_freelist_length();
1552
1553 if (ctx_running) {
1554 ctx_running->state = ctx_running->state & ~LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1555 }
1556 return r;
1557}
1558
1559int lbm_perform_gc(void) {
1560 return gc();
1561}
1562
1563/****************************************************/
1564/* Evaluation functions */
1565
1566
1567static void eval_symbol(eval_context_t *ctx) {
1568 lbm_uint s = lbm_dec_sym(ctx->curr_exp);
1569 if (s >= RUNTIME_SYMBOLS_START0x40000) {
1570 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1571 if (lbm_env_lookup_b(&res, ctx->curr_exp, ctx->curr_env) ||
1572 lbm_global_env_lookup(&res, ctx->curr_exp)) {
1573 ctx->r = res;
1574 ctx->app_cont = true1;
1575 return;
1576 }
1577 // Dynamic load attempt
1578 // Only symbols of kind RUNTIME can be dynamically loaded.
1579 const char *sym_str = lbm_get_name_by_symbol(s);
1580 const char *code_str = NULL((void*)0);
1581 if (!dynamic_load_callback(sym_str, &code_str)) {
1582 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), ctx->curr_exp);
1583 }
1584 lbm_value *sptr = stack_reserve(ctx, 3);
1585 sptr[0] = ctx->curr_exp;
1586 sptr[1] = ctx->curr_env;
1587 sptr[2] = RESUME(((12) << 2) | 0xF8000001u);
1588
1589 lbm_value chan;
1590 if (!create_string_channel((char *)code_str, &chan)) {
1591 gc();
1592 if (!create_string_channel((char *)code_str, &chan)) {
1593 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1594 }
1595 }
1596
1597 lbm_value loader;
1598 WITH_GC_RMBR_1(loader, lbm_heap_allocate_list_init(2,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1599 ENC_SYM_READ,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1600 chan), chan)(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} };
1601 lbm_value evaluator;
1602 WITH_GC_RMBR_1(evaluator, lbm_heap_allocate_list_init(2,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1603 ENC_SYM_EVAL,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1604 loader), loader)(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } };
1605 ctx->curr_exp = evaluator;
1606 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // dynamics should be evaluable in empty local env
1607 } else {
1608 //special symbols and extensions can be handled the same way.
1609 ctx->r = ctx->curr_exp;
1610 ctx->app_cont = true1;
1611 }
1612}
1613
1614static void eval_quote(eval_context_t *ctx) {
1615 ctx->r = get_cadr(ctx->curr_exp);
1616 ctx->app_cont = true1;
1617}
1618
1619static void eval_selfevaluating(eval_context_t *ctx) {
1620 ctx->r = ctx->curr_exp;
1621 ctx->app_cont = true1;
1622}
1623
1624static void eval_progn(eval_context_t *ctx) {
1625 lbm_value exps = get_cdr(ctx->curr_exp);
1626
1627 if (lbm_is_cons(exps)) {
1628 lbm_uint *sptr = stack_reserve(ctx, 4);
1629 sptr[0] = ctx->curr_env; // env to restore between expressions in progn
1630 sptr[1] = lbm_enc_u(0); // Has env been copied (needed for progn local bindings)
1631 sptr[3] = PROGN_REST(((4) << 2) | 0xF8000001u);
1632 get_car_and_cdr(exps, &ctx->curr_exp, &sptr[2]);
1633 if (lbm_is_symbol(sptr[2])) /* The only symbol it can be is nil */
1634 lbm_stack_drop(&ctx->K, 4);
1635 } else if (lbm_is_symbol_nil(exps)) {
1636 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1637 ctx->app_cont = true1;
1638 } else {
1639 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1640 }
1641}
1642
1643static void eval_atomic(eval_context_t *ctx) {
1644 if (is_atomic) {
1645 lbm_set_error_reason("Atomic blocks cannot be nested!");
1646 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1647 }
1648 stack_reserve(ctx, 1)[0] = EXIT_ATOMIC(((14) << 2) | 0xF8000001u);
1649 is_atomic ++;
1650 eval_progn(ctx);
1651}
1652
1653/* (call-cc (lambda (k) .... )) */
1654static void eval_callcc(eval_context_t *ctx) {
1655 lbm_value cont_array;
1656 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1657 gc();
1658 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1659 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1660 return; // dead return but static analysis doesn't know :)
1661 }
1662 }
1663 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(cont_array);
1664 memcpy(arr->data, ctx->K.data, ctx->K.sp * sizeof(lbm_uint));
1665
1666 lbm_value acont = cons_with_gc(ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u), cont_array, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1667 lbm_value arg_list = cons_with_gc(acont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1668 // Go directly into application evaluation without passing go
1669 lbm_uint *sptr = stack_reserve(ctx, 3);
1670 sptr[0] = ctx->curr_env;
1671 sptr[1] = arg_list;
1672 sptr[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
1673 ctx->curr_exp = get_cadr(ctx->curr_exp);
1674}
1675
1676// (define sym exp)
1677#define KEY1 1
1678#define VAL2 2
1679static void eval_define(eval_context_t *ctx) {
1680 lbm_value parts[3];
1681 lbm_value rest = extract_n(ctx->curr_exp, parts, 3);
1682 lbm_uint *sptr = stack_reserve(ctx, 2);
1683 if (lbm_is_symbol(parts[KEY1]) && lbm_is_symbol_nil(rest)) {
1684 lbm_uint sym_val = lbm_dec_sym(parts[KEY1]);
1685 sptr[0] = parts[KEY1];
1686 if (sym_val >= RUNTIME_SYMBOLS_START0x40000) {
1687 sptr[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
1688 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02) {
1689 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
1690 }
1691 ctx->curr_exp = parts[VAL2];
1692 return;
1693 }
1694 }
1695 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
1696}
1697
1698
1699/* Eval lambda is cheating, a lot! It does this
1700 for performance reasons. The cheats are that
1701 1. When closure is created, a reference to the local env
1702 in which the lambda was evaluated is added to the closure.
1703 Ideally it should have created a list of free variables in the function
1704 and then looked up the values of these creating a new environment.
1705 2. The global env is considered global constant. As there is no copying
1706 of environment bindings into the closure, undefine may break closures.
1707
1708 Correct closure creation is a lot more expensive than what happens here.
1709 However, one can try to write programs in such a way that closures are created
1710 seldomly. If one does that the space-usage benefits of "correct" closures
1711 may outweigh the performance gain of "incorrect" ones.
1712
1713 some obscure programs such as test_setq_local_closure.lisp does not
1714 work properly due to this cheating.
1715 */
1716// (lambda param-list body-exp) -> (closure param-list body-exp env)
1717static void eval_lambda(eval_context_t *ctx) {
1718 lbm_value vals[3];
1719 extract_n(ctx->curr_exp, vals, 3);
1720 ctx->r = allocate_closure(vals[1],vals[2], ctx->curr_env);
1721#ifdef CLEAN_UP_CLOSURES
1722 lbm_uint sym_id = 0;
1723 if (clean_cl_env_symbol) {
1724 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1725 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1726 ctx->curr_exp = app;
1727 } else if (lbm_get_symbol_by_name("clean-cl-env", &sym_id)) {
1728 clean_cl_env_symbol = lbm_enc_sym(sym_id);
1729 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1730 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1731 ctx->curr_exp = app;
1732 } else {
1733 ctx->app_cont = true1;
1734 }
1735#else
1736 ctx->app_cont = true1;
1737#endif
1738}
1739
1740// (if cond-expr then-expr else-expr)
1741static void eval_if(eval_context_t *ctx) {
1742 lbm_value cdr = get_cdr(ctx->curr_exp);
1743 lbm_value *sptr = stack_reserve(ctx, 3);
1744 sptr[0] = get_cdr(cdr);
1745 sptr[1] = ctx->curr_env;
1746 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1747 ctx->curr_exp = get_car(cdr);
1748}
1749
1750// (cond (cond-expr-1 expr-1)
1751// ...
1752// (cond-expr-N expr-N))
1753static void eval_cond(eval_context_t *ctx) {
1754 lbm_value cond1[2];
1755 lbm_value rest_conds = extract_n(ctx->curr_exp, cond1, 2);
1756
1757 // end recursion at (cond )
1758 if (lbm_is_symbol_nil(cond1[1])) {
1759 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1760 ctx->app_cont = true1;
1761 } else {
1762 // Cond is one of the few places where a bit of syntax checking takes place at runtime..
1763 // Maybe dont bother?
1764 lbm_uint len = lbm_list_length(cond1[1]);
1765 if (len != 2) {
1766 lbm_set_error_reason("Incorrect syntax in cond");
1767 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1768 }
1769 lbm_value cond_expr[2];
1770 extract_n(cond1[1], cond_expr, 2);
1771 lbm_value rest;
1772 WITH_GC(rest, lbm_heap_allocate_list_init(2,(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1773 cond_expr[1], // Then branch(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1774 cons_with_gc(ENC_SYM_COND, rest_conds , ENC_SYM_NIL)))(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
1775 lbm_value *sptr = stack_reserve(ctx, 3);
1776 sptr[0] = rest;
1777 sptr[1] = ctx->curr_env;
1778 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1779 ctx->curr_exp = cond_expr[0]; //condition;
1780 }
1781}
1782
1783static void eval_app_cont(eval_context_t *ctx) {
1784 lbm_stack_drop(&ctx->K, 1);
1785 ctx->app_cont = true1;
1786}
1787
1788// Create a named location in an environment to later receive a value.
1789static binding_location_status create_binding_location_internal(lbm_value key, lbm_value *env) {
1790
1791 if (lbm_is_symbol(key) &&
1792 (key == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u) ||
1793 key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)))
1794 return BL_OK;
1795
1796 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) { // default case
1797 lbm_value binding;
1798 lbm_value new_env_tmp;
1799 binding = lbm_cons(key, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1800 new_env_tmp = lbm_cons(binding, *env);
1801 if (lbm_is_symbol(binding) || lbm_is_symbol(new_env_tmp)) {
1802 return BL_NO_MEMORY;
1803 }
1804 *env = new_env_tmp;
1805 } else if (lbm_is_cons(key)) { // deconstruct case
1806 int r = create_binding_location_internal(get_car(key), env);
1807 if (r == BL_OK) {
1808 r = create_binding_location_internal(get_cdr(key), env);
1809 }
1810 return r;
1811 }
1812 return BL_OK;
1813}
1814
1815static void create_binding_location(lbm_value key, lbm_value *env) {
1816
1817 lbm_value env_tmp = *env;
1818 binding_location_status r = create_binding_location_internal(key, &env_tmp);
1819 if (r != BL_OK) {
1820 if (r == BL_NO_MEMORY) {
1821 env_tmp = *env;
1822 lbm_gc_mark_phase(env_tmp);
1823 gc();
1824 r = create_binding_location_internal(key, &env_tmp);
1825 }
1826 switch(r) {
1827 case BL_OK:
1828 break;
1829 case BL_NO_MEMORY:
1830 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1831 break;
1832 case BL_INCORRECT_KEY:
1833 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
1834 break;
1835 }
1836 }
1837 *env = env_tmp;
1838}
1839
1840static void let_bind_values_eval(lbm_value binds, lbm_value exp, lbm_value env, eval_context_t *ctx) {
1841
1842 if (!lbm_is_cons(binds)) {
1843 // binds better be nil or there is a programmer error.
1844 ctx->curr_exp = exp;
1845 return;
1846 }
1847
1848 // Preallocate binding locations.
1849 lbm_value curr = binds;
1850 while (lbm_is_cons(curr)) {
1851 lbm_value new_env_tmp = env;
1852 lbm_value car_curr, cdr_curr;
1853 get_car_and_cdr(curr, &car_curr, &cdr_curr);
1854 lbm_value key = get_car(car_curr);
1855 create_binding_location(key, &new_env_tmp);
1856 env = new_env_tmp;
1857 curr = cdr_curr;
1858 }
1859
1860 lbm_value car_binds;
1861 lbm_value cdr_binds;
1862 get_car_and_cdr(binds, &car_binds, &cdr_binds);
1863 lbm_value key_val[2];
1864 extract_n(car_binds, key_val, 2);
1865
1866 lbm_uint *sptr = stack_reserve(ctx, 5);
1867 sptr[0] = exp;
1868 sptr[1] = cdr_binds;
1869 sptr[2] = env;
1870 sptr[3] = key_val[0];
1871 sptr[4] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
1872 ctx->curr_exp = key_val[1];
1873 ctx->curr_env = env;
1874}
1875
1876// (var x (...)) - local binding inside of an progn
1877// var has to take, place root-level nesting within progn.
1878// (progn ... (var a 10) ...) OK!
1879// (progn ... (something (var a 10)) ... ) NOT OK!
1880/* progn stack
1881 sp-4 : env
1882 sp-3 : 0
1883 sp-2 : rest
1884 sp-1 : PROGN_REST
1885*/
1886static void eval_var(eval_context_t *ctx) {
1887
1888 if (ctx->K.sp >= 4) { // Possibly in progn
1889 lbm_value sv = ctx->K.data[ctx->K.sp - 1];
1890 if (IS_CONTINUATION(sv)(((sv) & 0xF8000001u) == 0xF8000001u) && (sv == PROGN_REST(((4) << 2) | 0xF8000001u))) {
1891 lbm_uint sp = ctx->K.sp;
1892 uint32_t is_copied = lbm_dec_as_u32(ctx->K.data[sp-3]);
1893 if (is_copied == 0) {
1894 lbm_value env;
1895 WITH_GC(env, lbm_env_copy_spine(ctx->K.data[sp-4]))(env) = (lbm_env_copy_spine(ctx->K.data[sp-4])); if (lbm_is_symbol_merror
((env))) { gc(); (env) = (lbm_env_copy_spine(ctx->K.data[sp
-4])); if (lbm_is_symbol_merror((env))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1896 ctx->K.data[sp-3] = lbm_enc_u(1);
1897 ctx->K.data[sp-4] = env;
1898 }
1899 lbm_value new_env = ctx->K.data[sp-4];
1900 lbm_value args = get_cdr(ctx->curr_exp);
1901 lbm_value key = get_car(args);
1902 create_binding_location(key, &new_env);
1903 ctx->K.data[sp-4] = new_env;
1904
1905 lbm_value v_exp = get_cadr(args);
1906 lbm_value *sptr = stack_reserve(ctx, 3);
1907 sptr[0] = new_env;
1908 sptr[1] = key;
1909 sptr[2] = PROGN_VAR(((29) << 2) | 0xF8000001u);
1910 // Activating the new environment before the evaluation of the value to be bound,
1911 // means that other variables with same name will be shadowed already in the value
1912 // body.
1913 // The way closures work, the var-variable needs to be in scope during val evaluation
1914 // for a recursive closure to be possible.
1915 ctx->curr_env = new_env;
1916 ctx->curr_exp = v_exp;
1917 return;
1918 }
1919 }
1920 lbm_set_error_reason((char*)lbm_error_str_var_outside_progn);
1921 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1922}
1923
1924// (setq x (...)) - same as (set 'x (...)) or (setvar 'x (...))
1925static void eval_setq(eval_context_t *ctx) {
1926 lbm_value parts[3];
1927 extract_n(ctx->curr_exp, parts, 3);
1928 lbm_value *sptr = stack_reserve(ctx, 3);
1929 sptr[0] = ctx->curr_env;
1930 sptr[1] = parts[1];
1931 sptr[2] = SETQ(((30) << 2) | 0xF8000001u);
1932 ctx->curr_exp = parts[2];
1933}
1934
1935static void eval_move_to_flash(eval_context_t *ctx) {
1936 lbm_value args = get_cdr(ctx->curr_exp);
1937 lbm_value *sptr = stack_reserve(ctx,2);
1938 sptr[0] = args;
1939 sptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
1940 ctx->app_cont = true1;
1941}
1942
1943// (loop list-of-local-bindings
1944// condition-exp
1945// body-exp)
1946static void eval_loop(eval_context_t *ctx) {
1947 lbm_value env = ctx->curr_env;
1948 lbm_value parts[3];
1949 extract_n(get_cdr(ctx->curr_exp), parts, 3);
1950 lbm_value *sptr = stack_reserve(ctx, 3);
1951 sptr[0] = parts[LOOP_BODY2];
1952 sptr[1] = parts[LOOP_COND1];
1953 sptr[2] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
1954 let_bind_values_eval(parts[LOOP_BINDS0], parts[LOOP_COND1], env, ctx);
1955}
1956
1957/* (trap expression)
1958 *
1959 * suggested use:
1960 * (match (trap expression)
1961 * ((exit-error (? err)) (error-handler err))
1962 * ((exit-ok (? v)) (value-handler v)))
1963 */
1964static void eval_trap(eval_context_t *ctx) {
1965
1966 lbm_value expr = get_cadr(ctx->curr_exp);
1967 lbm_value retval;
1968 WITH_GC(retval, lbm_heap_allocate_list(2))(retval) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((retval))) { gc(); (retval) = (lbm_heap_allocate_list(2)); if
(lbm_is_symbol_merror((retval))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1969 lbm_set_car(retval, ENC_SYM_EXIT_OK(((0x3000B) << 4) | 0x00000000u)); // Assume things will go well.
1970 lbm_uint *sptr = stack_reserve(ctx,3);
1971 sptr[0] = retval;
1972 sptr[1] = ctx->flags;
1973 sptr[2] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1974 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10;
1975 ctx->curr_exp = expr;
1976}
1977
1978// (let list-of-binding s
1979// body-exp)
1980static void eval_let(eval_context_t *ctx) {
1981 lbm_value env = ctx->curr_env;
1982 lbm_value parts[3];
1983 extract_n(ctx->curr_exp, parts, 3);
1984 let_bind_values_eval(parts[1], parts[2], env, ctx);
1985}
1986
1987// (and exp0 ... expN)
1988static void eval_and(eval_context_t *ctx) {
1989 lbm_value rest = get_cdr(ctx->curr_exp);
1990 if (lbm_is_symbol_nil(rest)) {
1991 ctx->app_cont = true1;
1992 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1993 } else {
1994 lbm_value *sptr = stack_reserve(ctx, 3);
1995 sptr[0] = ctx->curr_env;
1996 sptr[1] = get_cdr(rest);
1997 sptr[2] = AND(((6) << 2) | 0xF8000001u);
1998 ctx->curr_exp = get_car(rest);
1999 }
2000}
2001
2002// (or exp0 ... expN)
2003static void eval_or(eval_context_t *ctx) {
2004 lbm_value rest = get_cdr(ctx->curr_exp);
2005 if (lbm_is_symbol_nil(rest)) {
2006 ctx->app_cont = true1;
2007 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2008 } else {
2009 lbm_value *sptr = stack_reserve(ctx, 3);
2010 sptr[0] = ctx->curr_env;
2011 sptr[1] = get_cdr(rest);
2012 sptr[2] = OR(((7) << 2) | 0xF8000001u);
2013 ctx->curr_exp = get_car(rest);
2014 }
2015}
2016
2017// Pattern matching
2018// format:
2019// (match e (pattern body)
2020// (pattern body)
2021// ... )
2022//
2023// There can be an optional pattern guard:
2024// (match e (pattern guard body)
2025// ... )
2026// a guard is a boolean expression.
2027// Guards make match, pattern matching more complicated
2028// than the recv pattern matching and requires staged execution
2029// via the continuation system rather than a while loop over a list.
2030static void eval_match(eval_context_t *ctx) {
2031
2032 lbm_value rest = get_cdr(ctx->curr_exp);
2033 if (lbm_type_of(rest) == LBM_TYPE_SYMBOL0x00000000u &&
2034 rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
2035 // Someone wrote the program (match)
2036 ctx->app_cont = true1;
2037 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2038 } else {
2039 lbm_value cdr_rest;
2040 get_car_and_cdr(rest, &ctx->curr_exp, &cdr_rest);
2041 lbm_value *sptr = stack_reserve(ctx, 3);
2042 sptr[0] = cdr_rest;
2043 sptr[1] = ctx->curr_env;
2044 sptr[2] = MATCH(((9) << 2) | 0xF8000001u);
2045 }
2046}
2047
2048static void receive_base(eval_context_t *ctx, lbm_value pats, float timeout_time, bool_Bool timeout) {
2049 if (ctx->num_mail == 0) {
2050 if (timeout) {
2051 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000), false0);
2052 } else {
2053 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1,0,false0);
2054 }
2055 } else {
2056 lbm_value *msgs = ctx->mailbox;
2057 lbm_uint num = ctx->num_mail;
2058
2059 if (lbm_is_symbol_nil(pats)) {
2060 /* A receive statement without any patterns */
2061 ctx->app_cont = true1;
2062 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2063 } else {
2064 /* The common case */
2065 lbm_value e;
2066 lbm_value new_env = ctx->curr_env;
2067 int n = find_match(pats, msgs, num, &e, &new_env);
2068 if (n == FM_NEED_GC-1) {
2069 gc();
2070 new_env = ctx->curr_env;
2071 n = find_match(pats, msgs, num, &e, &new_env);
2072 if (n == FM_NEED_GC-1) {
2073 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2074 }
2075 }
2076 if (n == FM_PATTERN_ERROR-3) {
2077 lbm_set_error_reason("Incorrect pattern format for recv");
2078 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),pats);
2079 } else if (n >= 0 ) { /* Match */
2080 mailbox_remove_mail(ctx, (lbm_uint)n);
2081 ctx->curr_env = new_env;
2082 ctx->curr_exp = e;
2083 } else { /* No match go back to sleep */
2084 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
2085 if (timeout) {
2086 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2,S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000),false0);
2087 } else {
2088 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,false0);
2089 }
2090 }
2091 }
2092 }
2093 return;
2094}
2095
2096static void eval_receive_timeout(eval_context_t *ctx) {
2097 if (is_atomic) {
2098 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2099 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2100 }
2101 lbm_value timeout_val = get_cadr(ctx->curr_exp);
2102 if (!lbm_is_number(timeout_val)) {
2103 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2104 }
2105 float timeout_time = lbm_dec_as_float(timeout_val);
2106 lbm_value pats = get_cdr(get_cdr(ctx->curr_exp));
2107 receive_base(ctx, pats, timeout_time, true1);
2108}
2109
2110// Receive
2111// (recv (pattern expr)
2112// (pattern expr))
2113static void eval_receive(eval_context_t *ctx) {
2114
2115 if (is_atomic) {
2116 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2117 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
2118 }
2119 lbm_value pats = get_cdr(ctx->curr_exp);
2120 receive_base(ctx, pats, 0, false0);
2121}
2122
2123/*********************************************************/
2124/* Continuation functions */
2125
2126/* cont_set_global_env
2127 sp-1 : Key-symbol
2128 */
2129static void cont_set_global_env(eval_context_t *ctx){
2130
2131 lbm_value key;
2132 lbm_value val = ctx->r;
2133
2134 lbm_pop(&ctx->K, &key);
2135 lbm_uint dec_key = lbm_dec_sym(key);
2136 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
2137 lbm_value *global_env = lbm_get_global_env();
2138 lbm_uint orig_env = global_env[ix_key];
2139 lbm_value new_env;
2140 // A key is a symbol and should not need to be remembered.
2141 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2142
2143 global_env[ix_key] = new_env;
2144 ctx->r = val;
2145
2146 ctx->app_cont = true1;
2147
2148 return;
2149}
2150
2151static void cont_resume(eval_context_t *ctx) {
2152 lbm_pop_2(&ctx->K, &ctx->curr_env, &ctx->curr_exp);
2153}
2154
2155static void cont_progn_rest(eval_context_t *ctx) {
2156 lbm_value *sptr = get_stack_ptr(ctx, 3);
2157
2158 lbm_value rest = sptr[2];
2159 lbm_value env = sptr[0];
2160
2161 lbm_value rest_car, rest_cdr;
2162 get_car_and_cdr(rest, &rest_car, &rest_cdr);
2163 ctx->curr_exp = rest_car;
2164 ctx->curr_env = env;
2165 if (lbm_is_symbol_nil(rest_cdr)) {
2166 // allow for tail recursion
2167 lbm_stack_drop(&ctx->K, 3);
2168 } else {
2169 sptr[2] = rest_cdr;
2170 stack_reserve(ctx, 1)[0] = PROGN_REST(((4) << 2) | 0xF8000001u);
2171 }
2172}
2173
2174static void cont_wait(eval_context_t *ctx) {
2175
2176 lbm_value cid_val;
2177 lbm_pop(&ctx->K, &cid_val);
2178 lbm_cid cid = (lbm_cid)lbm_dec_i(cid_val);
2179
2180 bool_Bool exists = false0;
2181
2182 lbm_blocked_iterator(context_exists, &cid, &exists);
2183 lbm_running_iterator(context_exists, &cid, &exists);
2184
2185 if (ctx_running->id == cid) {
2186 exists = true1;
2187 }
2188
2189 if (exists) {
2190 lbm_value *sptr = stack_reserve(ctx, 2);
2191 sptr[0] = lbm_enc_i(cid);
2192 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2193 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2194 ctx->app_cont = true1;
2195 yield_ctx(50000);
2196 } else {
2197 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2198 ctx->app_cont = true1;
2199 }
2200}
2201
2202static lbm_value perform_setvar(lbm_value key, lbm_value val, lbm_value env) {
2203
2204 lbm_uint s = lbm_dec_sym(key);
2205 if (s >= RUNTIME_SYMBOLS_START0x40000) {
2206 lbm_value new_env = lbm_env_modify_binding(env, key, val);
2207 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2208 lbm_uint ix_key = lbm_dec_sym(key) & GLOBAL_ENV_MASK0x1F;
2209 lbm_value *glob_env = lbm_get_global_env();
2210 new_env = lbm_env_modify_binding(glob_env[ix_key], key, val);
2211 glob_env[ix_key] = new_env;
2212 }
2213 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2214 lbm_set_error_reason((char*)lbm_error_str_variable_not_bound);
2215 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), key);
2216 }
2217 return val;
2218 }
2219 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2220 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // unreachable
2221}
2222
2223static void apply_setvar(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2224 if (nargs == 2 && lbm_is_symbol(args[0])) {
2225 lbm_value res;
2226 WITH_GC(res, perform_setvar(args[0], args[1], ctx->curr_env))(res) = (perform_setvar(args[0], args[1], ctx->curr_env));
if (lbm_is_symbol_merror((res))) { gc(); (res) = (perform_setvar
(args[0], args[1], ctx->curr_env)); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2227 ctx->r = args[1];
2228 lbm_stack_drop(&ctx->K, nargs+1);
2229 ctx->app_cont = true1;
2230 } else {
2231 if (nargs == 2) lbm_set_error_reason((char*)lbm_error_str_incorrect_arg);
2232 else lbm_set_error_reason((char*)lbm_error_str_num_args);
2233 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2234 }
2235}
2236
2237static void apply_read_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, bool_Bool program, bool_Bool incremental) {
2238 if (nargs == 1) {
2239 lbm_value chan = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2240 if (lbm_type_of_functional(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2241 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2242 gc();
2243 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2244 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2245 }
2246 }
2247 } else if (lbm_type_of(args[0]) == LBM_TYPE_CHANNEL0x90000000u) {
2248 chan = args[0];
2249 } else {
2250 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2251 }
2252 lbm_value *sptr = get_stack_ptr(ctx, 2);
2253
2254 // If we are inside a reader, its settings are stored.
2255 sptr[0] = lbm_enc_u(ctx->flags); // flags stored.
2256 sptr[1] = chan;
2257 lbm_value *rptr = stack_reserve(ctx,1);
2258 rptr[0] = READ_DONE(((20) << 2) | 0xF8000001u);
2259
2260 // Each reader starts in a fresh situation
2261 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
2262
2263 if (program) {
2264 if (incremental) {
2265 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2266 lbm_value *rptr1 = stack_reserve(ctx,3);
2267 rptr1[0] = chan;
2268 rptr1[1] = ctx->curr_env;
2269 rptr1[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
2270 } else {
2271 ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2272 lbm_value *rptr1 = stack_reserve(ctx,4);
2273 rptr1[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2274 rptr1[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2275 rptr1[2] = chan;
2276 rptr1[3] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
2277 }
2278 }
2279 rptr = stack_reserve(ctx,3); // reuse of variable rptr
2280 rptr[0] = chan;
2281 rptr[1] = lbm_enc_u(1);
2282 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
2283 ctx->app_cont = true1;
2284 } else {
2285 lbm_set_error_reason((char*)lbm_error_str_num_args);
2286 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2287 }
2288}
2289
2290static void apply_read_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2291 apply_read_base(args,nargs,ctx,true1,false0);
2292}
2293
2294static void apply_read_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2295 apply_read_base(args,nargs,ctx,true1,true1);
2296}
2297
2298static void apply_read(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2299 apply_read_base(args,nargs,ctx,false0,false0);
2300}
2301
2302static void apply_spawn_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, uint32_t context_flags) {
2303
2304 lbm_uint stack_size = EVAL_CPS_DEFAULT_STACK_SIZE256;
2305 lbm_uint closure_pos = 0;
2306 char *name = NULL((void*)0);
2307
2308 if (nargs >= 1 &&
2309 lbm_is_closure(args[0])) {
2310 closure_pos = 0;
2311 } else if (nargs >= 2 &&
2312 lbm_is_number(args[0]) &&
2313 lbm_is_closure(args[1])) {
2314 stack_size = lbm_dec_as_u32(args[0]);
2315 closure_pos = 1;
2316 } else if (nargs >= 2 &&
2317 lbm_is_array_r(args[0]) &&
2318 lbm_is_closure(args[1])) {
2319 name = lbm_dec_str(args[0]);
2320 closure_pos = 1;
2321 }else if (nargs >= 3 &&
2322 lbm_is_array_r(args[0]) &&
2323 lbm_is_number(args[1]) &&
2324 lbm_is_closure(args[2])) {
2325 stack_size = lbm_dec_as_u32(args[1]);
2326 closure_pos = 2;
2327 name = lbm_dec_str(args[0]);
2328 } else {
2329 if (context_flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01)
2330 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN_TRAP(((0x30005) << 4) | 0x00000000u));
2331 else
2332 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN(((0x30004) << 4) | 0x00000000u));
2333 }
2334
2335 lbm_value cl[3];
2336 extract_n(get_cdr(args[closure_pos]), cl, 3);
2337 lbm_value curr_param = cl[CLO_PARAMS0];
2338 lbm_value clo_env = cl[CLO_ENV2];
2339 lbm_uint i = closure_pos + 1;
2340 while (lbm_is_cons(curr_param) && i <= nargs) {
2341 lbm_value entry = cons_with_gc(get_car(curr_param), args[i], clo_env);
2342 lbm_value aug_env = cons_with_gc(entry, clo_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2343 clo_env = aug_env;
2344 curr_param = get_cdr(curr_param);
2345 i ++;
2346 }
2347
2348 lbm_stack_drop(&ctx->K, nargs+1);
2349
2350 lbm_value program = cons_with_gc(cl[CLO_BODY1], ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), clo_env);
2351
2352 lbm_cid cid = lbm_create_ctx_parent(program,
2353 clo_env,
2354 stack_size,
2355 lbm_get_current_cid(),
2356 context_flags,
2357 name);
2358 ctx->r = lbm_enc_i(cid);
2359 ctx->app_cont = true1;
2360}
2361
2362static void apply_spawn(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2363 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00);
2364}
2365
2366static void apply_spawn_trap(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2367 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01);
2368}
2369
2370static void apply_yield(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2371 if (is_atomic) {
2372 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2373 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2374 }
2375 if (nargs == 1 && lbm_is_number(args[0])) {
2376 lbm_uint ts = lbm_dec_as_u32(args[0]);
2377 lbm_stack_drop(&ctx->K, nargs+1);
2378 yield_ctx(ts);
2379 } else {
2380 lbm_set_error_reason((char*)lbm_error_str_no_number);
2381 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2382 }
2383}
2384
2385static void apply_sleep(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2386 if (is_atomic) {
2387 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2388 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2389 }
2390 if (nargs == 1 && lbm_is_number(args[0])) {
2391 lbm_uint ts = (lbm_uint)(1000000.0f * lbm_dec_as_float(args[0]));
2392 lbm_stack_drop(&ctx->K, nargs+1);
2393 yield_ctx(ts);
2394 } else {
2395 lbm_set_error_reason((char*)lbm_error_str_no_number);
2396 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2397 }
2398}
2399
2400static void apply_wait(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2401 if (nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2402 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2403 lbm_value *sptr = get_stack_ptr(ctx, 2);
2404 sptr[0] = lbm_enc_i(cid);
2405 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2406 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2407 ctx->app_cont = true1;
2408 yield_ctx(50000);
2409 } else {
2410 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_WAIT(((0x30007) << 4) | 0x00000000u));
2411 }
2412}
2413
2414/* (eval expr)
2415 (eval env expr) */
2416static void apply_eval(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2417 if ( nargs == 1) {
2418 ctx->curr_exp = args[0];
2419 } else if (nargs == 2) {
2420 ctx->curr_exp = args[1];
2421 ctx->curr_env = args[0];
2422 } else {
2423 lbm_set_error_reason((char*)lbm_error_str_num_args);
2424 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL(((0x30008) << 4) | 0x00000000u));
2425 }
2426 lbm_stack_drop(&ctx->K, nargs+1);
2427}
2428
2429static void apply_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2430 int prg_pos = 0;
2431 if (nargs == 2) {
2432 prg_pos = 1;
2433 ctx->curr_env = args[0];
2434 }
2435 if (nargs == 1 || nargs == 2) {
2436 lbm_value prg = args[prg_pos];
2437 lbm_value app_cont;
2438 lbm_value app_cont_prg;
2439 lbm_value new_prg;
2440 lbm_value prg_copy;
2441
2442 int len = -1;
2443 WITH_GC(prg_copy, lbm_list_copy(&len, prg))(prg_copy) = (lbm_list_copy(&len, prg)); if (lbm_is_symbol_merror
((prg_copy))) { gc(); (prg_copy) = (lbm_list_copy(&len, prg
)); if (lbm_is_symbol_merror((prg_copy))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2444 lbm_stack_drop(&ctx->K, nargs+1);
2445
2446 if (ctx->K.sp > nargs+2) { // if there is a continuation
2447 app_cont = cons_with_gc(ENC_SYM_APP_CONT(((0x111) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2448 app_cont_prg = cons_with_gc(app_cont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2449 new_prg = lbm_list_append(app_cont_prg, ctx->program);
2450 new_prg = lbm_list_append(prg_copy, new_prg);
2451 } else {
2452 new_prg = lbm_list_append(prg_copy, ctx->program);
2453 }
2454 if (!lbm_is_list(new_prg)) {
2455 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2456 }
2457 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);
2458 ctx->program = get_cdr(new_prg);
2459 ctx->curr_exp = get_car(new_prg);
2460 } else {
2461 lbm_set_error_reason((char*)lbm_error_str_num_args);
2462 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2463 }
2464}
2465
2466static void apply_send(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2467 if (nargs == 2) {
2468 if (lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2469 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2470 lbm_value msg = args[1];
2471 lbm_value status = lbm_find_receiver_and_send(cid, msg);
2472 /* return the status */
2473 lbm_stack_drop(&ctx->K, nargs+1);
2474 ctx->r = status;
2475 ctx->app_cont = true1;
2476 } else {
2477 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2478 }
2479 } else {
2480 lbm_set_error_reason((char*)lbm_error_str_num_args);
2481 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2482 }
2483}
2484
2485static void apply_ok(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2486 lbm_value ok_val = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2487 if (nargs >= 1) {
2488 ok_val = args[0];
2489 }
2490 ctx->r = ok_val;
2491 ok_ctx();
2492}
2493
2494static void apply_error(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2495 (void) ctx;
2496 lbm_value err_val = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
2497 if (nargs >= 1) {
2498 err_val = args[0];
2499 }
2500 error_at_ctx(err_val, ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
2501}
2502
2503// (map f arg-list)
2504static void apply_map(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2505 if (nargs == 2 && lbm_is_cons(args[1])) {
2506 lbm_value *sptr = get_stack_ptr(ctx, 3);
2507
2508 lbm_value f = args[0];
2509 lbm_value h = get_car(args[1]);
2510 lbm_value t = get_cdr(args[1]);
2511
2512 lbm_value appli_1;
2513 lbm_value appli;
2514 WITH_GC(appli_1, lbm_heap_allocate_list(2))(appli_1) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli_1))) { gc(); (appli_1) = (lbm_heap_allocate_list(2));
if (lbm_is_symbol_merror((appli_1))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2515 WITH_GC_RMBR_1(appli, lbm_heap_allocate_list(2), appli_1)(appli) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli))) { lbm_gc_mark_phase(appli_1); gc(); (appli) = (lbm_heap_allocate_list
(2)); if (lbm_is_symbol_merror((appli))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2516
2517 lbm_value appli_0 = get_cdr(appli_1);
2518
2519 lbm_set_car_and_cdr(appli_0, h, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2520 lbm_set_car(appli_1, ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u));
2521
2522 lbm_set_car_and_cdr(get_cdr(appli), appli_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2523 lbm_set_car(appli, f);
2524
2525 lbm_value elt = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), appli);
2526 sptr[0] = t; // reuse stack space
2527 sptr[1] = ctx->curr_env;
2528 sptr[2] = elt;
2529 lbm_value *rptr = stack_reserve(ctx,4);
2530 rptr[0] = elt;
2531 rptr[1] = appli;
2532 rptr[2] = appli_0;
2533 rptr[3] = MAP(((26) << 2) | 0xF8000001u);
2534 ctx->curr_exp = appli;
2535 } else if (nargs == 2 && lbm_is_symbol_nil(args[1])) {
2536 lbm_stack_drop(&ctx->K, 3);
2537 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2538 ctx->app_cont = true1;
2539 return;
2540 } else {
2541 lbm_set_error_reason((char*)lbm_error_str_num_args);
2542 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_MAP(((0x3000D) << 4) | 0x00000000u));
2543 }
2544}
2545
2546static void apply_reverse(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2547 if (nargs == 1 && lbm_is_list(args[0])) {
2548 lbm_value curr = args[0];
2549
2550 lbm_value new_list = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2551 while (lbm_is_cons(curr)) {
2552 lbm_value tmp = cons_with_gc(get_car(curr), new_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2553 new_list = tmp;
2554 curr = get_cdr(curr);
2555 }
2556 lbm_stack_drop(&ctx->K, 2);
2557 ctx->r = new_list;
2558 ctx->app_cont = true1;
2559 } else {
2560 lbm_set_error_reason("Reverse requires a list argument");
2561 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_REVERSE(((0x3000E) << 4) | 0x00000000u));
2562 }
2563}
2564
2565static void apply_flatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2566 if (nargs == 1) {
2567
2568 lbm_value v = flatten_value(args[0]);
2569 if ( v == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)) {
2570 gc();
2571 v = flatten_value(args[0]);
2572 }
2573
2574 if (lbm_is_symbol(v)) {
2575 error_at_ctx(v, ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2576 } else {
2577 lbm_stack_drop(&ctx->K, 2);
2578 ctx->r = v;
2579 ctx->app_cont = true1;
2580 }
2581 return;
2582 }
2583 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2584}
2585
2586static void apply_unflatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2587 if(nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2588 lbm_array_header_t *array;
2589 array = (lbm_array_header_t *)get_car(args[0]);
2590
2591 lbm_flat_value_t fv;
2592 fv.buf = (uint8_t*)array->data;
2593 fv.buf_size = array->size;
2594 fv.buf_pos = 0;
2595
2596 lbm_value res;
2597
2598 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2599 if (lbm_unflatten_value(&fv, &res)) {
2600 ctx->r = res;
2601 }
2602 lbm_stack_drop(&ctx->K, 2);
2603 ctx->app_cont = true1;
2604 return;
2605 }
2606 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_UNFLATTEN(((0x30010) << 4) | 0x00000000u));
2607}
2608
2609static void apply_kill(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2610 if (nargs == 2 && lbm_is_number(args[0])) {
2611 lbm_cid cid = lbm_dec_as_i32(args[0]);
2612
2613 if (ctx->id == cid) {
2614 ctx->r = args[1];
2615 finish_ctx();
2616 return;
2617 }
2618 mutex_lock(&qmutex);
2619 eval_context_t *found = NULL((void*)0);
2620 found = lookup_ctx_nm(&blocked, cid);
2621 if (found)
2622 drop_ctx_nm(&blocked, found);
2623 else
2624 found = lookup_ctx_nm(&queue, cid);
2625 if (found)
2626 drop_ctx_nm(&queue, found);
2627
2628 if (found) {
2629 found->K.data[found->K.sp - 1] = KILL(((40) << 2) | 0xF8000001u);
2630 found->r = args[1];
2631 found->app_cont = true1;
2632 enqueue_ctx_nm(&queue,found);
2633 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2634 } else {
2635 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2636 }
2637 lbm_stack_drop(&ctx->K, 3);
2638 ctx->app_cont = true1;
2639 mutex_unlock(&qmutex);
2640 return;
2641 }
2642 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_KILL(((0x30011) << 4) | 0x00000000u));
2643}
2644
2645// (merge comparator list1 list2)
2646static void apply_merge(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2647 if (nargs == 3 && lbm_is_list(args[1]) && lbm_is_list(args[2])) {
2648
2649 if (!lbm_is_closure(args[0])) {
2650 lbm_value closure;
2651 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2652 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2653 lbm_value cl1 = lbm_cdr(closure);
2654 lbm_value par;
2655 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2656 lbm_set_car(cl1, par);
2657 lbm_value cl2 = lbm_cdr(cl1);
2658 lbm_value body;
2659 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2660 lbm_set_car(cl2, body);
2661 lbm_value cl3 = lbm_cdr(cl2);
2662 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2663
2664 // Replace operator on stack with closure and rest of the code is
2665 // compatible.
2666 args[0] = closure;
2667 }
2668
2669 // Copy input lists for functional behaviour at top-level
2670 // merge itself is in-place in the copied lists.
2671 lbm_value a;
2672 lbm_value b;
2673 int len_a = -1;
2674 int len_b = -1;
2675 WITH_GC(a, lbm_list_copy(&len_a, args[1]))(a) = (lbm_list_copy(&len_a, args[1])); if (lbm_is_symbol_merror
((a))) { gc(); (a) = (lbm_list_copy(&len_a, args[1])); if
(lbm_is_symbol_merror((a))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } };
2676 WITH_GC_RMBR_1(b, lbm_list_copy(&len_b, args[2]), a)(b) = (lbm_list_copy(&len_b, args[2])); if (lbm_is_symbol_merror
((b))) { lbm_gc_mark_phase(a); gc(); (b) = (lbm_list_copy(&
len_b, args[2])); if (lbm_is_symbol_merror((b))) { error_ctx(
(((0x23) << 4) | 0x00000000u)); } };
2677
2678 if (len_a == 0) {
2679 ctx->r = b;
2680 lbm_stack_drop(&ctx->K, 4);
2681 ctx->app_cont = true1;
2682 return;
2683 }
2684 if (len_b == 0) {
2685 ctx->r = a;
2686 lbm_stack_drop(&ctx->K, 4);
2687 ctx->app_cont = true1;
2688 return;
2689 }
2690
2691 args[1] = a; // keep safe by replacing the original on stack.
2692 args[2] = b;
2693
2694 lbm_value a_1 = a;
2695 lbm_value a_rest = lbm_cdr(a);
2696 lbm_value b_1 = b;
2697 lbm_value b_rest = lbm_cdr(b);
2698
2699 lbm_value cl[3]; // Comparator closure
2700 extract_n(lbm_cdr(args[0]), cl, 3);
2701 lbm_value cmp_env = cl[CLO_ENV2];
2702 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2703 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2704 lbm_uint len = lbm_list_length(cl[CLO_PARAMS0]);
2705 if (len == 2) {
2706 par1 = get_car(cl[CLO_PARAMS0]);
2707 par2 = get_cadr(cl[CLO_PARAMS0]);
2708 lbm_value new_env0;
2709 lbm_value new_env;
2710 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a_1)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a_1))); if (
lbm_is_symbol_merror((new_env0))) { gc(); (new_env0) = (lbm_env_set
(cmp_env, par1, lbm_car(a_1))); if (lbm_is_symbol_merror((new_env0
))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2711 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b_1)),new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1))); if (
lbm_is_symbol_merror((new_env))) { lbm_gc_mark_phase(new_env0
); gc(); (new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1
))); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2712 cmp_env = new_env;
2713 } else {
2714 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2715 }
2716 lbm_set_cdr(a_1, b_1);
2717 lbm_set_cdr(b_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2718 lbm_value cmp = cl[CLO_BODY1];
2719
2720 lbm_stack_drop(&ctx->K, 4); // TODO: Optimize drop 4 alloc 10 into alloc 6
2721 lbm_uint *sptr = stack_reserve(ctx, 10);
2722 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged list
2723 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged list
2724 sptr[2] = a_1;
2725 sptr[3] = a_rest;
2726 sptr[4] = b_rest;
2727 sptr[5] = cmp;
2728 sptr[6] = cmp_env;
2729 sptr[7] = par1;
2730 sptr[8] = par2;
2731 sptr[9] = MERGE_REST(((43) << 2) | 0xF8000001u);
2732 ctx->curr_exp = cl[CLO_BODY1];
2733 ctx->curr_env = cmp_env;
2734 return;
2735 }
2736 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MERGE(((0x30013) << 4) | 0x00000000u));
2737}
2738
2739// (sort comparator list)
2740static void apply_sort(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2741 if (nargs == 2 && lbm_is_list(args[1])) {
2742
2743 if (!lbm_is_closure(args[0])) {
2744 lbm_value closure;
2745 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2746 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2747 lbm_value cl1 = lbm_cdr(closure);
2748 lbm_value par;
2749 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2750 lbm_set_car(cl1, par);
2751 lbm_value cl2 = lbm_cdr(cl1);
2752 lbm_value body;
2753 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2754 lbm_set_car(cl2, body);
2755 lbm_value cl3 = lbm_cdr(cl2);
2756 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2757
2758 // Replace operator on stack with closure and rest of the code is
2759 // compatible.
2760 args[0] = closure;
2761 }
2762
2763 int len = -1;
2764 lbm_value list_copy;
2765 WITH_GC(list_copy, lbm_list_copy(&len, args[1]))(list_copy) = (lbm_list_copy(&len, args[1])); if (lbm_is_symbol_merror
((list_copy))) { gc(); (list_copy) = (lbm_list_copy(&len,
args[1])); if (lbm_is_symbol_merror((list_copy))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2766 if (len <= 1) {
2767 lbm_stack_drop(&ctx->K, 3);
2768 ctx->r = list_copy;
2769 ctx->app_cont = true1;
2770 return;
2771 }
2772
2773 args[1] = list_copy; // Keep safe, original replaced on stack.
2774
2775 // Take the headmost 2, 1-element sublists.
2776 lbm_value a = list_copy;
2777 lbm_value b = lbm_cdr(a);
2778 lbm_value rest = lbm_cdr(b);
2779 // Do not terminate b. keep rest of list safe from GC in the following
2780 // closure extraction.
2781 //lbm_set_cdr(a, b); // This is void
2782
2783 lbm_value cl[3]; // Comparator closure
2784 extract_n(lbm_cdr(args[0]), cl, 3);
2785 lbm_value cmp_env = cl[CLO_ENV2];
2786 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2787 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2788 lbm_uint cl_len = lbm_list_length(cl[CLO_PARAMS0]);
2789 if (cl_len == 2) {
2790 par1 = get_car(cl[CLO_PARAMS0]);
2791 par2 = get_cadr(cl[CLO_PARAMS0]);
2792 lbm_value new_env0;
2793 lbm_value new_env;
2794 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a))); if (lbm_is_symbol_merror
((new_env0))) { gc(); (new_env0) = (lbm_env_set(cmp_env, par1
, lbm_car(a))); if (lbm_is_symbol_merror((new_env0))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2795 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b)), new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { lbm_gc_mark_phase(new_env0); gc(); (new_env) =
(lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { error_ctx((((0x23) << 4) | 0x00000000u))
; } };
2796 cmp_env = new_env;
2797 } else {
2798 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2799 }
2800 lbm_value cmp = cl[CLO_BODY1];
2801
2802 // Terminate the comparator argument list.
2803 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2804
2805 lbm_stack_drop(&ctx->K, 3); //TODO: optimize drop 3, alloc 20 into alloc 17
2806 lbm_uint *sptr = stack_reserve(ctx, 20);
2807 sptr[0] = cmp;
2808 sptr[1] = cmp_env;
2809 sptr[2] = par1;
2810 sptr[3] = par2;
2811 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged accumulation of sublists
2812 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged accumulation of sublists
2813 sptr[6] = rest;
2814 sptr[7] = lbm_enc_i(1);
2815 sptr[8] = lbm_enc_i(len); //TODO: 28 bit i vs 32 bit i
2816 sptr[9] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
2817 sptr[10] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged sublist
2818 sptr[11] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged sublist
2819 sptr[12] = a;
2820 sptr[13] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no a_rest, 1 element lists in layer 1.
2821 sptr[14] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no b_rest, 1 element lists in layer 1.
2822 sptr[15] = cmp;
2823 sptr[16] = cmp_env;
2824 sptr[17] = par1;
2825 sptr[18] = par2;
2826 sptr[19] = MERGE_REST(((43) << 2) | 0xF8000001u);
2827 ctx->curr_exp = cmp;
2828 ctx->curr_env = cmp_env;
2829 return;
2830 }
2831 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
2832}
2833
2834static void apply_rest_args(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2835 lbm_value res;
2836 if (lbm_env_lookup_b(&res, ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ctx->curr_env)) {
2837 if (nargs == 1 && lbm_is_number(args[0])) {
2838 int32_t ix = lbm_dec_as_i32(args[0]);
2839 res = lbm_index_list(res, ix);
2840 }
2841 ctx->r = res;
2842 } else {
2843 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2844 }
2845 lbm_stack_drop(&ctx->K, nargs+1);
2846 ctx->app_cont = true1;
2847}
2848
2849/* (rotate list-expr dist/dir-expr) */
2850static void apply_rotate(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2851 if (nargs == 2 && lbm_is_list(args[0]) && lbm_is_number(args[1])) {
2852 int len = -1;
2853 lbm_value ls = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2854 WITH_GC(ls, lbm_list_copy(&len, args[0]))(ls) = (lbm_list_copy(&len, args[0])); if (lbm_is_symbol_merror
((ls))) { gc(); (ls) = (lbm_list_copy(&len, args[0])); if
(lbm_is_symbol_merror((ls))) { error_ctx((((0x23) << 4
) | 0x00000000u)); } };
2855 int dist = lbm_dec_as_i32(args[1]);
2856 if (len > 0 && dist != 0) {
2857 int d = dist;
2858 if (dist > 0) {
2859 ls = lbm_list_destructive_reverse(ls);
2860 } else {
2861 d = -dist;
2862 }
2863
2864 lbm_value start = ls;
2865 lbm_value end = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2866 lbm_value curr = start;
2867 while (lbm_is_cons(curr)) {
2868 end = curr;
2869 curr = get_cdr(curr);
2870 }
2871
2872 for (int i = 0; i < d; i ++) {
2873 lbm_value a = start;
2874 start = lbm_cdr(start);
2875 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2876 lbm_set_cdr(end, a);
2877 end = a;
2878 }
2879 ls = start;
2880 if (dist > 0) {
2881 ls = lbm_list_destructive_reverse(ls);
2882 }
2883 }
2884 lbm_stack_drop(&ctx->K, nargs+1);
2885 ctx->app_cont = true1;
2886 ctx->r = ls;
2887 return;
2888 }
2889 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2890}
2891
2892/***************************************************/
2893/* Application lookup table */
2894
2895typedef void (*apply_fun)(lbm_value *, lbm_uint, eval_context_t *);
2896static const apply_fun fun_table[] =
2897 {
2898 apply_setvar,
2899 apply_read,
2900 apply_read_program,
2901 apply_read_eval_program,
2902 apply_spawn,
2903 apply_spawn_trap,
2904 apply_yield,
2905 apply_wait,
2906 apply_eval,
2907 apply_eval_program,
2908 apply_send,
2909 apply_ok,
2910 apply_error,
2911 apply_map,
2912 apply_reverse,
2913 apply_flatten,
2914 apply_unflatten,
2915 apply_kill,
2916 apply_sleep,
2917 apply_merge,
2918 apply_sort,
2919 apply_rest_args,
2920 apply_rotate,
2921 };
2922
2923/***************************************************/
2924/* Application of function that takes arguments */
2925/* passed over the stack. */
2926
2927static void application(eval_context_t *ctx, lbm_value *fun_args, lbm_uint arg_count) {
2928 /* If arriving here, we know that the fun is a symbol.
2929 * and can be a built in operation or an extension.
2930 */
2931 lbm_value fun = fun_args[0];
2932
2933 lbm_uint fun_val = lbm_dec_sym(fun);
2934 lbm_uint fun_kind = SYMBOL_KIND(fun_val)((fun_val) >> 16);
2935
2936 switch (fun_kind) {
2937 case SYMBOL_KIND_EXTENSION1: {
2938 extension_fptr f = extension_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)].fptr;
2939
2940 lbm_value ext_res;
2941 WITH_GC(ext_res, f(&fun_args[1], arg_count))(ext_res) = (f(&fun_args[1], arg_count)); if (lbm_is_symbol_merror
((ext_res))) { gc(); (ext_res) = (f(&fun_args[1], arg_count
)); if (lbm_is_symbol_merror((ext_res))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2942 if (lbm_is_error(ext_res)) { //Error other than merror
2943 error_at_ctx(ext_res, fun);
2944 }
2945 lbm_stack_drop(&ctx->K, arg_count + 1);
2946
2947 ctx->app_cont = true1;
2948 ctx->r = ext_res;
2949
2950 if (blocking_extension) {
2951 blocking_extension = false0;
2952 if (blocking_extension_timeout) {
2953 blocking_extension_timeout = false0;
2954 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, blocking_extension_timeout_us,true1);
2955 } else {
2956 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,true1);
2957 }
2958 mutex_unlock(&blocking_extension_mutex);
2959 }
2960 } break;
2961 case SYMBOL_KIND_FUNDAMENTAL2:
2962 call_fundamental(SYMBOL_IX(fun_val)((fun_val) & 0xFFFF), &fun_args[1], arg_count, ctx);
2963 break;
2964 case SYMBOL_KIND_APPFUN3:
2965 fun_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)](&fun_args[1], arg_count, ctx);
2966 break;
2967 default:
2968 // Symbols that are "special" but not in the way caught above
2969 // ends up here.
2970 lbm_set_error_reason("Symbol does not represent a function");
2971 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),fun_args[0]);
2972 break;
2973 }
2974}
2975
2976static void cont_closure_application_args(eval_context_t *ctx) {
2977 lbm_uint* sptr = get_stack_ptr(ctx, 5);
2978
2979 lbm_value arg_env = (lbm_value)sptr[0];
2980 lbm_value exp = (lbm_value)sptr[1];
2981 lbm_value clo_env = (lbm_value)sptr[2];
2982 lbm_value params = (lbm_value)sptr[3];
2983 lbm_value args = (lbm_value)sptr[4];
2984
2985 lbm_value car_params, cdr_params;
2986 get_car_and_cdr(params, &car_params, &cdr_params);
1
Calling 'get_car_and_cdr'
→
5
←
Returning from 'get_car_and_cdr'
→
2987
2988 bool_Bool a_nil = lbm_is_symbol_nil(args);
6
←
Calling 'lbm_is_symbol_nil'
→
9
←
Returning from 'lbm_is_symbol_nil'
→
2989 bool_Bool p_nil = lbm_is_symbol_nil(cdr_params);
10
←
Calling 'lbm_is_symbol_nil'
→
13
←
Returning from 'lbm_is_symbol_nil'
→
2990
2991 lbm_value binder = allocate_binding(car_params, ctx->r, clo_env);
2992
2993 if (!a_nil
13.1
'a_nil' is false
13.1
'a_nil' is false
 && !p_nil
13.2
'p_nil' is false
13.2
'p_nil' is false
) {
14
←
Taking true branch
→
2994 lbm_value car_args, cdr_args;
15
←
'car_args' declared without an initial value
→
2995 get_car_and_cdr(args, &car_args, &cdr_args);
16
←
Calling 'get_car_and_cdr'
→
21
←
Returning from 'get_car_and_cdr'
→
2996 sptr[2] = binder;
2997 sptr[3] = cdr_params;
2998 sptr[4] = cdr_args;
2999 stack_reserve(ctx,1)[0] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
3000 ctx->curr_exp = car_args;
22
←
Assigned value is garbage or undefined
3001 ctx->curr_env = arg_env;
3002 } else if (a_nil && p_nil) {
3003 // Arguments and parameters match up in number
3004 lbm_stack_drop(&ctx->K, 5);
3005 ctx->curr_env = binder;
3006 ctx->curr_exp = exp;
3007 } else if (p_nil) {
3008 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), binder);
3009 sptr[2] = rest_binder;
3010 sptr[3] = get_cdr(args);
3011 sptr[4] = get_car(rest_binder); // last element of rest_args so far
3012 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3013 ctx->curr_exp = get_car(args);
3014 ctx->curr_env = arg_env;
3015 } else {
3016 lbm_set_error_reason((char*)lbm_error_str_num_args);
3017 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
3018 }
3019}
3020
3021
3022static void cont_closure_args_rest(eval_context_t *ctx) {
3023 lbm_uint* sptr = get_stack_ptr(ctx, 5);
3024 lbm_value arg_env = (lbm_value)sptr[0];
3025 lbm_value exp = (lbm_value)sptr[1];
3026 lbm_value clo_env = (lbm_value)sptr[2];
3027 lbm_value args = (lbm_value)sptr[3];
3028 lbm_value last = (lbm_value)sptr[4];
3029 lbm_cons_t* heap = lbm_heap_state.heap;
3030
3031 lbm_value binding = lbm_heap_state.freelist;
3032 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3033 gc();
3034 binding = lbm_heap_state.freelist;
3035 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3036 }
3037 lbm_uint binding_ix = lbm_dec_ptr(binding);
3038 lbm_heap_state.freelist = heap[binding_ix].cdr;
3039 lbm_heap_state.num_alloc += 1;
3040 heap[binding_ix].car = ctx->r;
3041 heap[binding_ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3042
3043
3044 lbm_set_cdr(last, binding);
3045 sptr[4] = binding;
3046
3047 if (args == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3048 lbm_stack_drop(&ctx->K, 5);
3049 ctx->curr_env = clo_env;
3050 ctx->curr_exp = exp;
3051 } else {
3052 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3053 sptr[3] = get_cdr(args);
3054 ctx->curr_exp = get_car(args);
3055 ctx->curr_env = arg_env;
3056 }
3057}
3058
3059static void cont_application_args(eval_context_t *ctx) {
3060 lbm_uint *sptr = get_stack_ptr(ctx, 3);
3061
3062 lbm_value env = sptr[0];
3063 lbm_value rest = sptr[1];
3064 lbm_value count = sptr[2];
3065
3066 ctx->curr_env = env;
3067 sptr[0] = ctx->r; // Function 1st then Arguments
3068 if (lbm_is_cons(rest)) {
3069 lbm_cons_t *cell = lbm_ref_cell(rest);
3070 sptr[1] = env;
3071 sptr[2] = cell->cdr;
3072 lbm_value *rptr = stack_reserve(ctx,2);
3073 rptr[0] = count + (1 << LBM_VAL_SHIFT4);
3074 rptr[1] = APPLICATION_ARGS(((5) << 2) | 0xF8000001u);
3075 ctx->curr_exp = cell->car;
3076 } else {
3077 // No more arguments
3078 lbm_stack_drop(&ctx->K, 2);
3079 lbm_uint nargs = lbm_dec_u(count);
3080 lbm_value *args = get_stack_ptr(ctx, (uint32_t)(nargs + 1));
3081 application(ctx,args, nargs);
3082 }
3083}
3084
3085static void cont_and(eval_context_t *ctx) {
3086 lbm_value env;
3087 lbm_value rest;
3088 lbm_value arg = ctx->r;
3089 lbm_pop_2(&ctx->K, &rest, &env);
3090 if (lbm_is_symbol_nil(arg)) {
3091 ctx->app_cont = true1;
3092 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3093 } else if (lbm_is_symbol_nil(rest)) {
3094 ctx->app_cont = true1;
3095 } else {
3096 lbm_value *sptr = stack_reserve(ctx, 3);
3097 sptr[0] = env;
3098 sptr[1] = get_cdr(rest);
3099 sptr[2] = AND(((6) << 2) | 0xF8000001u);
3100 ctx->curr_env = env;
3101 ctx->curr_exp = get_car(rest);
3102 }
3103}
3104
3105static void cont_or(eval_context_t *ctx) {
3106 lbm_value env;
3107 lbm_value rest;
3108 lbm_value arg = ctx->r;
3109 lbm_pop_2(&ctx->K, &rest, &env);
3110 if (!lbm_is_symbol_nil(arg)) {
3111 ctx->app_cont = true1;
3112 } else if (lbm_is_symbol_nil(rest)) {
3113 ctx->app_cont = true1;
3114 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3115 } else {
3116 lbm_value *sptr = stack_reserve(ctx, 3);
3117 sptr[0] = env;
3118 sptr[1] = get_cdr(rest);
3119 sptr[2] = OR(((7) << 2) | 0xF8000001u);
3120 ctx->curr_exp = get_car(rest);
3121 ctx->curr_env = env;
3122 }
3123}
3124
3125static int fill_binding_location(lbm_value key, lbm_value value, lbm_value env) {
3126 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) {
3127 if (key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return FB_OK0;
3128 lbm_env_modify_binding(env,key,value);
3129 return FB_OK0;
3130 } else if (lbm_is_cons(key) &&
3131 lbm_is_cons(value)) {
3132 int r = fill_binding_location(get_car(key), get_car(value), env);
3133 if (r == FB_OK0) {
3134 r = fill_binding_location(get_cdr(key), get_cdr(value), env);
3135 }
3136 return r;
3137 }
3138 return FB_TYPE_ERROR-1;
3139}
3140
3141static void cont_bind_to_key_rest(eval_context_t *ctx) {
3142
3143 lbm_value *sptr = get_stack_ptr(ctx, 4);
3144
3145 lbm_value rest = sptr[1];
3146 lbm_value env = sptr[2];
3147 lbm_value key = sptr[3];
3148
3149 if (fill_binding_location(key, ctx->r, env) < 0) {
3150 lbm_set_error_reason("Incorrect type of name/key in let-binding");
3151 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
3152 }
3153
3154 if (lbm_is_cons(rest)) {
3155 lbm_value car_rest = get_car(rest);
3156 lbm_value key_val[2];
3157 extract_n(car_rest, key_val, 2);
3158
3159 sptr[1] = get_cdr(rest);
3160 sptr[3] = key_val[0];
3161 stack_reserve(ctx,1)[0] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
3162 ctx->curr_exp = key_val[1];
3163 ctx->curr_env = env;
3164 } else {
3165 // Otherwise evaluate the expression in the populated env
3166 ctx->curr_exp = sptr[0];
3167 ctx->curr_env = env;
3168 lbm_stack_drop(&ctx->K, 4);
3169 }
3170}
3171
3172static void cont_if(eval_context_t *ctx) {
3173
3174 lbm_value arg = ctx->r;
3175
3176 lbm_value *sptr = pop_stack_ptr(ctx, 2);
3177
3178 ctx->curr_env = sptr[1];
3179 if (lbm_is_symbol_nil(arg)) {
3180 ctx->curr_exp = get_cadr(sptr[0]); // else branch
3181 } else {
3182 ctx->curr_exp = get_car(sptr[0]); // then branch
3183 }
3184}
3185
3186static void cont_match(eval_context_t *ctx) {
3187 lbm_value e = ctx->r;
3188 bool_Bool do_gc = false0;
3189
3190 lbm_uint *sptr = get_stack_ptr(ctx, 2);
3191 lbm_value patterns = (lbm_value)sptr[0];
3192 lbm_value orig_env = (lbm_value)sptr[1]; // restore enclosing environment.
3193 lbm_value new_env = orig_env;
3194
3195 if (lbm_is_symbol_nil(patterns)) {
3196 // no more patterns
3197 lbm_stack_drop(&ctx->K, 2);
3198 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
3199 ctx->app_cont = true1;
3200 } else if (lbm_is_cons(patterns)) {
3201 lbm_value match_case = get_car(patterns);
3202 lbm_value pattern = get_car(match_case);
3203 lbm_value n1 = get_cadr(match_case);
3204 lbm_value n2 = get_cadr(get_cdr(match_case));
3205 lbm_value body;
3206 bool_Bool check_guard = false0;
3207 if (lbm_is_symbol_nil(n2)) { // TODO: Not a very robust check.
3208 body = n1;
3209 } else {
3210 body = n2;
3211 check_guard = true1;
3212 }
3213
3214 bool_Bool is_match = match(pattern, e, &new_env, &do_gc);
3215 if (do_gc) {
3216 gc();
3217 do_gc = false0;
3218 new_env = orig_env;
3219 is_match = match(pattern, e, &new_env, &do_gc);
3220 if (do_gc) {
3221 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3222 }
3223 }
3224 if (is_match) {
3225 if (check_guard) {
3226 lbm_value *rptr = stack_reserve(ctx,5);
3227 sptr[0] = get_cdr(patterns);
3228 sptr[1] = ctx->curr_env;
3229 rptr[0] = MATCH(((9) << 2) | 0xF8000001u);
3230 rptr[1] = new_env;
3231 rptr[2] = body;
3232 rptr[3] = e;
3233 rptr[4] = MATCH_GUARD(((27) << 2) | 0xF8000001u);
3234 ctx->curr_env = new_env;
3235 ctx->curr_exp = n1; // The guard
3236 } else {
3237 lbm_stack_drop(&ctx->K, 2);
3238 ctx->curr_env = new_env;
3239 ctx->curr_exp = body;
3240 }
3241 } else {
3242 // set up for checking of next pattern
3243 sptr[0] = get_cdr(patterns);
3244 sptr[1] = orig_env;
3245 stack_reserve(ctx,1)[0] = MATCH(((9) << 2) | 0xF8000001u);
3246 // leave r unaltered
3247 ctx->app_cont = true1;
3248 }
3249 } else {
3250 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MATCH(((0x108) << 4) | 0x00000000u));
3251 }
3252}
3253
3254static void cont_exit_atomic(eval_context_t *ctx) {
3255 is_atomic --;
3256 ctx->app_cont = true1;
3257}
3258
3259static void cont_map(eval_context_t *ctx) {
3260 lbm_value *sptr = get_stack_ptr(ctx, 6);
3261
3262 lbm_value ls = sptr[0];
3263 lbm_value env = sptr[1];
3264 lbm_value t = sptr[3];
3265 lbm_set_car(t, ctx->r); // update car field tailmost position.
3266 if (lbm_is_cons(ls)) {
3267 lbm_value next, rest;
3268 get_car_and_cdr(ls, &next, &rest);
3269 sptr[0] = rest;
3270 stack_reserve(ctx,1)[0] = MAP(((26) << 2) | 0xF8000001u);
3271 lbm_set_car(sptr[5], next); // new arguments
3272
3273 lbm_value elt = cons_with_gc(ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3274 lbm_set_cdr(t, elt);
3275 sptr[3] = elt; // (r1 ... rN . (nil . nil))
3276 ctx->curr_exp = sptr[4];
3277 ctx->curr_env = env;
3278 } else {
3279 ctx->r = sptr[2]; //head of result list
3280 ctx->curr_env = env;
3281 lbm_stack_drop(&ctx->K, 6);
3282 ctx->app_cont = true1;
3283 }
3284}
3285
3286static void cont_match_guard(eval_context_t *ctx) {
3287 if (lbm_is_symbol_nil(ctx->r)) {
3288 lbm_value e;
3289 lbm_pop(&ctx->K, &e);
3290 lbm_stack_drop(&ctx->K, 2);
3291 ctx->r = e;
3292 ctx->app_cont = true1;
3293 } else {
3294 lbm_value body;
3295 lbm_value env;
3296 lbm_stack_drop(&ctx->K, 1);
3297 lbm_pop_2(&ctx->K, &body, &env);
3298 lbm_stack_drop(&ctx->K, 3);
3299 ctx->curr_env = env;
3300 ctx->curr_exp = body;
3301 }
3302}
3303
3304static void cont_terminate(eval_context_t *ctx) {
3305 error_ctx(ctx->r);
3306}
3307
3308static void cont_loop(eval_context_t *ctx) {
3309 lbm_value *sptr = get_stack_ptr(ctx, 2);
3310 stack_reserve(ctx,1)[0] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
3311 ctx->curr_exp = sptr[1];
3312}
3313
3314static void cont_loop_condition(eval_context_t *ctx) {
3315 if (lbm_is_symbol_nil(ctx->r)) {
3316 lbm_stack_drop(&ctx->K, 2);
3317 ctx->app_cont = true1; // A loop returns nil? Makes sense to me... but in general?
3318 return;
3319 }
3320 lbm_value *sptr = get_stack_ptr(ctx, 2);
3321 stack_reserve(ctx,1)[0] = LOOP(((41) << 2) | 0xF8000001u);
3322 ctx->curr_exp = sptr[0];
3323}
3324
3325static void cont_merge_rest(eval_context_t *ctx) {
3326 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3327
3328 // If comparator returns true (result is in ctx->r):
3329 // "a" should be moved to the last element position in merged list.
3330 // A new element from "a_rest" should be moved into comparator argument 1 pos.
3331 // else
3332 // "b" should be moved to last element position in merged list.
3333 // A new element from "b_rest" should be moved into comparator argument 2 pos.
3334 //
3335 // If a_rest or b_rest is NIL:
3336 // we are done, the remaining elements of
3337 // non_nil list should be appended to merged list.
3338 // else
3339 // Set up for a new comparator evaluation and recurse.
3340 lbm_value a = sptr[2];
3341 lbm_value b = lbm_cdr(a);
3342 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate 1 element list
3343
3344 if (ctx->r == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) { // Comparison false
3345
3346 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3347 sptr[0] = b;
3348 sptr[1] = b;
3349 } else {
3350 lbm_set_cdr(sptr[1], b);
3351 sptr[1] = b;
3352 }
3353 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3354 lbm_set_cdr(a, sptr[3]);
3355 lbm_set_cdr(sptr[1], a);
3356 ctx->r = sptr[0];
3357 lbm_stack_drop(&ctx->K, 9);
3358 ctx->app_cont = true1;
3359 return;
3360 } else {
3361 b = sptr[4];
3362 sptr[4] = lbm_cdr(sptr[4]);
3363 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3364 }
3365 } else {
3366 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3367 sptr[0] = a;
3368 sptr[1] = a;
3369 } else {
3370 lbm_set_cdr(sptr[1], a);
3371 sptr[1] = a;
3372 }
3373
3374 if (sptr[3] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3375 lbm_set_cdr(b, sptr[4]);
3376 lbm_set_cdr(sptr[1], b);
3377 ctx->r = sptr[0];
3378 lbm_stack_drop(&ctx->K, 9);
3379 ctx->app_cont = true1;
3380 return;
3381 } else {
3382 a = sptr[3];
3383 sptr[3] = lbm_cdr(sptr[3]);
3384 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3385 }
3386 }
3387 lbm_set_cdr(a, b);
3388 sptr[2] = a;
3389
3390 lbm_value par1 = sptr[7];
3391 lbm_value par2 = sptr[8];
3392 lbm_value cmp_body = sptr[5];
3393 lbm_value cmp_env = sptr[6];
3394 // Environment should be preallocated already at this point
3395 // and the operations below should never need GC.
3396 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3397 lbm_value new_env = lbm_env_set(new_env0, par2, lbm_car(b));
3398 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3399 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3400 }
3401 cmp_env = new_env;
3402
3403 stack_reserve(ctx,1)[0] = MERGE_REST(((43) << 2) | 0xF8000001u);
3404 ctx->curr_exp = cmp_body;
3405 ctx->curr_env = cmp_env;
3406}
3407
3408// merge_layer stack contents
3409// s[sp-9] = cmp
3410// s[sp-8] = cmp_env
3411// s[sp-7] = par1
3412// s[sp-6] = par2
3413// s[sp-5] = acc - first cell
3414// s[sp-4] = acc - last cell
3415// s[sp-3] = rest;
3416// s[sp-2] = layer
3417// s[sp-1] = length or original list
3418//
3419// ctx->r merged sublist
3420static void cont_merge_layer(eval_context_t *ctx) {
3421 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3422 lbm_int layer = lbm_dec_i(sptr[7]);
3423 lbm_int len = lbm_dec_i(sptr[8]);
3424
3425 lbm_value r_curr = ctx->r;
3426 while (lbm_is_cons(r_curr)) {
3427 lbm_value next = lbm_cdr(r_curr);
3428 if (next == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3429 break;
3430 }
3431 r_curr = next;
3432 }
3433
3434 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3435 sptr[4] = ctx->r;
3436 sptr[5] = r_curr;
3437 } else {
3438 lbm_set_cdr(sptr[5], ctx->r); // accumulate merged sublists.
3439 sptr[5] = r_curr;
3440 }
3441
3442 lbm_value layer_rest = sptr[6];
3443 // switch layer or done ?
3444 if (layer_rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3445 if (layer * 2 >= len) {
3446 ctx->r = sptr[4];
3447 ctx->app_cont = true1;
3448 lbm_stack_drop(&ctx->K, 9);
3449 return;
3450 } else {
3451 // Setup for merges of the next layer
3452 layer = layer * 2;
3453 sptr[7] = lbm_enc_i(layer);
3454 layer_rest = sptr[4]; // continue on the accumulation of all sublists.
3455 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3456 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3457 }
3458 }
3459 // merge another sublist based on current layer.
3460 lbm_value a_list = layer_rest;
3461 // build sublist a
3462 lbm_value curr = layer_rest;
3463 for (int i = 0; i < layer-1; i ++) {
3464 if (lbm_is_cons(curr)) {
3465 curr = lbm_cdr(curr);
3466 } else {
3467 break;
3468 }
3469 }
3470 layer_rest = lbm_cdr(curr);
3471 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3472
3473 lbm_value b_list = layer_rest;
3474 // build sublist b
3475 curr = layer_rest;
3476 for (int i = 0; i < layer-1; i ++) {
3477 if (lbm_is_cons(curr)) {
3478 curr = lbm_cdr(curr);
3479 } else {
3480 break;
3481 }
3482 }
3483 layer_rest = lbm_cdr(curr);
3484 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3485
3486 sptr[6] = layer_rest;
3487
3488 if (b_list == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3489 stack_reserve(ctx,1)[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3490 ctx->r = a_list;
3491 ctx->app_cont = true1;
3492 return;
3493 }
3494 // Set up for a merge of sublists.
3495
3496 lbm_value a_rest = lbm_cdr(a_list);
3497 lbm_value b_rest = lbm_cdr(b_list);
3498 lbm_value a = a_list;
3499 lbm_value b = b_list;
3500 lbm_set_cdr(a, b);
3501 // Terminating the b list would be incorrect here
3502 // if there was any chance that the environment update below
3503 // performs GC.
3504 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3505
3506 lbm_value cmp_body = sptr[0];
3507 lbm_value cmp_env = sptr[1];
3508 lbm_value par1 = sptr[2];
3509 lbm_value par2 = sptr[3];
3510 // Environment should be preallocated already at this point
3511 // and the operations below should never need GC.
3512 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3513 lbm_value new_env = lbm_env_set(cmp_env, par2, lbm_car(b));
3514 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3515 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3516 }
3517 cmp_env = new_env;
3518
3519 lbm_uint *merge_cont = stack_reserve(ctx, 11);
3520 merge_cont[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3521 merge_cont[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3522 merge_cont[2] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3523 merge_cont[3] = a;
3524 merge_cont[4] = a_rest;
3525 merge_cont[5] = b_rest;
3526 merge_cont[6] = cmp_body;
3527 merge_cont[7] = cmp_env;
3528 merge_cont[8] = par1;
3529 merge_cont[9] = par2;
3530 merge_cont[10] = MERGE_REST(((43) << 2) | 0xF8000001u);
3531 ctx->curr_exp = cmp_body;
3532 ctx->curr_env = cmp_env;
3533 return;
3534}
3535
3536/****************************************************/
3537/* READER */
3538
3539static void read_finish(lbm_char_channel_t *str, eval_context_t *ctx) {
3540
3541 /* Tokenizer reached "end of file"
3542 The parser could be in a state where it needs
3543 more tokens to correctly finish an expression.
3544
3545 Three cases
3546 1. The program / expression is malformed and the context should die.
3547 2. We are finished reading a program and should close off the
3548 internal representation with a closing parenthesis. Then
3549 apply continuation.
3550 3. We are finished reading an expression and should
3551 apply the continuation.
3552
3553 In case 3, we should find the READ_DONE at sp - 1.
3554 In case 2, we should find the READ_DONE at sp - 5.
3555
3556 */
3557
3558 if (lbm_is_symbol(ctx->r)) {
3559 lbm_uint sym_val = lbm_dec_sym(ctx->r);
3560 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
3561 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
3562 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3563 }
3564 }
3565
3566 if (ctx->K.data[ctx->K.sp-1] == READ_DONE(((20) << 2) | 0xF8000001u) &&
3567 lbm_dec_u(ctx->K.data[ctx->K.sp-3]) == 0) {
3568 /* successfully finished reading an expression (CASE 3) */
3569 ctx->app_cont = true1;
3570 } else if (ctx->K.sp > 4 && ctx->K.data[ctx->K.sp - 4] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3571 lbm_value env;
3572 lbm_value s;
3573 lbm_value sym;
3574 lbm_pop_3(&ctx->K, &sym, &env, &s);
3575 ctx->curr_env = env;
3576 ctx->app_cont = true1; // Program evaluated and result is in ctx->r.
3577 } else if (ctx->K.sp > 5 && ctx->K.data[ctx->K.sp - 5] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3578 /* successfully finished reading a program (CASE 2) */
3579 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3580 ctx->app_cont = true1;
3581 } else {
3582 /* Parsing failed */
3583 if (lbm_channel_row(str) == 1 &&
3584 lbm_channel_column(str) == 1 ){
3585 // eof at empty stream.
3586 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3587 ctx->app_cont = true1;
3588 } else {
3589 lbm_set_error_reason((char*)lbm_error_str_parse_eof);
3590 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3591 }
3592 lbm_channel_reader_close(str);
3593 }
3594}
3595
3596/* cont_read_next_token
3597 sp-2 : Stream
3598 sp-1 : Grab row
3599*/
3600static void cont_read_next_token(eval_context_t *ctx) {
3601 lbm_value *sptr = get_stack_ptr(ctx, 2);
3602 lbm_value stream = sptr[0];
3603 lbm_value grab_row0 = sptr[1];
3604
3605 lbm_char_channel_t *chan = lbm_dec_channel(stream);
3606 if (chan == NULL((void*)0) || chan->state == NULL((void*)0)) {
3607 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3608 }
3609
3610 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3611 lbm_stack_drop(&ctx->K, 2);
3612 read_finish(chan, ctx);
3613 return;
3614 }
3615 /* Eat whitespace and comments */
3616 if (!tok_clean_whitespace(chan)) {
3617 sptr[0] = stream;
3618 sptr[1] = lbm_enc_u(0);
3619 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3620 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3621 return;
3622 }
3623 /* After eating whitespace we may be at end of file/stream */
3624 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3625 lbm_stack_drop(&ctx->K, 2);
3626 read_finish(chan, ctx);
3627 return;
3628 }
3629
3630 if (lbm_dec_u(grab_row0)) {
3631 ctx->row0 = (int32_t)lbm_channel_row(chan);
3632 }
3633
3634 /* Attempt to extract tokens from the character stream */
3635 int n = 0;
3636 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3637 unsigned int string_len = 0;
3638
3639 /*
3640 * SYNTAX
3641 */
3642 uint32_t match;
3643 n = tok_syntax(chan, &match);
3644 if (n > 0) {
3645 if (!lbm_channel_drop(chan, (unsigned int)n)) {
3646 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3647 }
3648 ctx->app_cont = true1;
3649 lbm_uint do_next = 0;
3650 switch(match) {
3651 case TOKOPENPAR1u: {
3652 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3653 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3654 lbm_value *rptr = stack_reserve(ctx,5);
3655 rptr[0] = stream;
3656 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3657 rptr[2] = stream;
3658 rptr[3] = lbm_enc_u(0);
3659 rptr[4] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3660 ctx->r = ENC_SYM_OPENPAR(((0x70) << 4) | 0x00000000u);
3661 } return;
3662 case TOKCLOSEPAR2u: {
3663 lbm_stack_drop(&ctx->K, 2);
3664 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3665 } return;
3666 case TOKOPENBRACK3u: {
3667 sptr[0] = stream;
3668 sptr[1] = READ_START_ARRAY(((24) << 2) | 0xF8000001u);
3669 lbm_value *rptr = stack_reserve(ctx, 3);
3670 rptr[0] = stream;
3671 rptr[1] = lbm_enc_u(0);
3672 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3673 ctx->r = ENC_SYM_OPENBRACK(((0x80) << 4) | 0x00000000u);
3674 } return;
3675 case TOKCLOSEBRACK4u:
3676 lbm_stack_drop(&ctx->K, 2);
3677 ctx->r = ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u);
3678 return;
3679 case TOKDOT5u:
3680 lbm_stack_drop(&ctx->K, 2);
3681 ctx->r = ENC_SYM_DOT(((0x76) << 4) | 0x00000000u);
3682 return;
3683 case TOKDONTCARE6u:
3684 lbm_stack_drop(&ctx->K, 2);
3685 ctx->r = ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u);
3686 return;
3687 case TOKQUOTE7u:
3688 do_next = READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u);
3689 break;
3690 case TOKBACKQUOTE8u: {
3691 sptr[0] = QQ_EXPAND_START(((35) << 2) | 0xF8000001u);
3692 sptr[1] = stream;
3693 lbm_value *rptr = stack_reserve(ctx, 2);
3694 rptr[0] = lbm_enc_u(0);
3695 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3696 ctx->app_cont = true1;
3697 } return;
3698 case TOKCOMMAAT9u:
3699 do_next = READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u);
3700 break;
3701 case TOKCOMMA10u:
3702 do_next = READ_COMMA_RESULT(((23) << 2) | 0xF8000001u);
3703 break;
3704 case TOKMATCHANY11u:
3705 lbm_stack_drop(&ctx->K, 2);
3706 ctx->r = ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u);
3707 return;
3708 case TOKOPENCURL12u: {
3709 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3710 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3711 lbm_value *rptr = stack_reserve(ctx,2);
3712 rptr[0] = stream;
3713 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3714 ctx->r = ENC_SYM_PROGN(((0x102) << 4) | 0x00000000u);
3715 } return;
3716 case TOKCLOSECURL13u:
3717 lbm_stack_drop(&ctx->K, 2);
3718 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3719 return;
3720 case TOKCONSTSTART14u: /* fall through */
3721 case TOKCONSTEND15u:
3722 case TOKCONSTSYMSTR16u: {
3723 if (match == TOKCONSTSTART14u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3724 if (match == TOKCONSTEND15u) ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3725 if (match == TOKCONSTSYMSTR16u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04;
3726 sptr[0] = stream;
3727 sptr[1] = lbm_enc_u(0);
3728 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3729 ctx->app_cont = true1;
3730 } return;
3731 default:
3732 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3733 }
3734 sptr[0] = do_next;
3735 sptr[1] = stream;
3736 lbm_value *rptr = stack_reserve(ctx, 2);
3737 rptr[0] = lbm_enc_u(0);
3738 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3739 ctx->app_cont = true1;
3740 return;
3741 } else if (n < 0) goto retry_token;
3742
3743 /*
3744 * STRING
3745 */
3746 n = tok_string(chan, &string_len);
3747 if (n >= 2) {
3748 lbm_channel_drop(chan, (unsigned int)n);
3749 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3750 gc();
3751 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3752 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3753 return; // dead return but static analysis does not know that.
3754 }
3755 }
3756 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(res);
3757 char *data = (char*)arr->data;
3758 memset(data,0, string_len + 1);
3759 memcpy(data, tokpar_sym_str, string_len);
3760 lbm_stack_drop(&ctx->K, 2);
3761 ctx->r = res;
3762 ctx->app_cont = true1;
3763 return;
3764 } else if (n < 0) goto retry_token;
3765
3766 /*
3767 * FLOAT
3768 */
3769 token_float f_val;
3770 n = tok_double(chan, &f_val);
3771 if (n > 0) {
3772 lbm_channel_drop(chan, (unsigned int) n);
3773 switch(f_val.type) {
3774 case TOKTYPEF32107u:
3775 WITH_GC(res, lbm_enc_float((float)f_val.value))(res) = (lbm_enc_float((float)f_val.value)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (lbm_enc_float((float)f_val.value));
if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
3776 break;
3777 case TOKTYPEF64108u:
3778 res = lbm_enc_double(f_val.value);
3779 break;
3780 default:
3781 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3782 }
3783 lbm_stack_drop(&ctx->K, 2);
3784 ctx->r = res;
3785 ctx->app_cont = true1;
3786 return;
3787 } else if (n < 0) goto retry_token;
3788
3789 /*
3790 * INTEGER
3791 */
3792 token_int int_result;
3793 n = tok_integer(chan, &int_result);
3794 if (n > 0) {
3795 lbm_channel_drop(chan, (unsigned int)n);
3796 switch(int_result.type) {
3797 case TOKTYPEBYTE100u:
3798 res = lbm_enc_char((uint8_t)(int_result.negative ? -int_result.value : int_result.value));
3799 break;
3800 case TOKTYPEI101u:
3801 res = lbm_enc_i((lbm_int)(int_result.negative ? -int_result.value : int_result.value));
3802 break;
3803 case TOKTYPEU102u:
3804 res = lbm_enc_u((lbm_uint)(int_result.negative ? -int_result.value : int_result.value));
3805 break;
3806 case TOKTYPEI32103u:
3807 WITH_GC(res, lbm_enc_i32((int32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i32((int32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i32((int32_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3808 break;
3809 case TOKTYPEU32104u:
3810 WITH_GC(res,lbm_enc_u32((uint32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u32((uint32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u32((uint32_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3811 break;
3812 case TOKTYPEI64105u:
3813 WITH_GC(res,lbm_enc_i64((int64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i64((int64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i64((int64_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3814 break;
3815 case TOKTYPEU64106u:
3816 WITH_GC(res,lbm_enc_u64((uint64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u64((uint64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u64((uint64_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3817 break;
3818 default:
3819 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3820 }
3821 lbm_stack_drop(&ctx->K, 2);
3822 ctx->r = res;
3823 ctx->app_cont = true1;
3824 return;
3825 } else if (n < 0) goto retry_token;
3826
3827 /*
3828 * SYMBOL
3829 */
3830 n = tok_symbol(chan);
3831 if (n > 0) {
3832 lbm_channel_drop(chan, (unsigned int) n);
3833 lbm_uint symbol_id;
3834 if (lbm_get_symbol_by_name(tokpar_sym_str, &symbol_id)) {
3835 res = lbm_enc_sym(symbol_id);
3836 } else {
3837 int r = 0;
3838 if (n > 4 &&
3839 tokpar_sym_str[0] == 'e' &&
3840 tokpar_sym_str[1] == 'x' &&
3841 tokpar_sym_str[2] == 't' &&
3842 tokpar_sym_str[3] == '-') {
3843 lbm_uint ext_id;
3844 lbm_uint ext_name_len = (lbm_uint)n + 1;
3845 char *ext_name = lbm_malloc(ext_name_len);
3846 if (!ext_name) {
3847 gc();
3848 ext_name = lbm_malloc(ext_name_len);
3849 }
3850 if (ext_name) {
3851 memcpy(ext_name, tokpar_sym_str, ext_name_len);
3852 r = lbm_add_extension(ext_name, lbm_extensions_default);
3853 if (!lbm_lookup_extension_id(ext_name, &ext_id)) {
3854 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3855 }
3856 symbol_id = ext_id;
3857 } else {
3858 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3859 }
3860 } else {
3861 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04 &&
3862 ctx->flags & EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08) {
3863 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id, true1); //flash
3864 if (!r) {
3865 lbm_set_error_reason((char*)lbm_error_str_flash_error);
3866 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3867 }
3868 } else {
3869 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3870 if (!r) {
3871 gc();
3872 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3873 }
3874 }
3875 }
3876 if (r) {
3877 res = lbm_enc_sym(symbol_id);
3878 } else {
3879 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3880 }
3881 }
3882 lbm_stack_drop(&ctx->K, 2);
3883 ctx->r = res;
3884 ctx->app_cont = true1;
3885 return;
3886 } else if (n == TOKENIZER_NEED_MORE-1) {
3887 goto retry_token;
3888 } else if (n <= TOKENIZER_STRING_ERROR-2) {
3889 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3890 }
3891
3892 /*
3893 * CHAR
3894 */
3895 char c_val;
3896 n = tok_char(chan, &c_val);
3897 if(n > 0) {
3898 lbm_channel_drop(chan,(unsigned int) n);
3899 lbm_stack_drop(&ctx->K, 2);
3900 ctx->r = lbm_enc_char((uint8_t)c_val);
3901 ctx->app_cont = true1;
3902 return;
3903 }else if (n < 0) goto retry_token;
3904
3905 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3906
3907 retry_token:
3908 if (n == TOKENIZER_NEED_MORE-1) {
3909 sptr[0] = stream;
3910 sptr[1] = lbm_enc_u(0);
3911 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3912 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3913 return;
3914 }
3915 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3916}
3917
3918static void cont_read_start_array(eval_context_t *ctx) {
3919 lbm_value *sptr = get_stack_ptr(ctx, 1);
3920 lbm_value stream = sptr[0];
3921
3922 lbm_char_channel_t *str = lbm_dec_channel(stream);
3923 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
3924 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3925 }
3926
3927 lbm_uint num_free = lbm_memory_longest_free();
3928 lbm_uint initial_size = (lbm_uint)((float)num_free * 0.9);
3929 if (initial_size == 0) {
3930 gc();
3931 num_free = lbm_memory_longest_free();
3932 initial_size = (lbm_uint)((float)num_free * 0.9);
3933 if (initial_size == 0) {
3934 lbm_channel_reader_close(str);
3935 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3936 }
3937 }
3938
3939 if (lbm_is_number(ctx->r)) {
3940 lbm_value array;
3941 initial_size = sizeof(lbm_uint) * initial_size;
3942
3943 if (!lbm_heap_allocate_array(&array, initial_size)) {
3944 lbm_set_error_reason("Out of memory while reading.");
3945 lbm_channel_reader_close(str);
3946 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3947 // NOTE: If array is not created evaluation ends here.
3948 // Static analysis seems unaware.
3949 }
3950
3951 sptr[0] = array;
3952 lbm_value *rptr = stack_reserve(ctx, 4);
3953 rptr[0] = lbm_enc_u(initial_size);
3954 rptr[1] = lbm_enc_u(0);
3955 rptr[2] = stream;
3956 rptr[3] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3957 ctx->app_cont = true1;
3958 } else {
3959 lbm_channel_reader_close(str);
3960 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3961 }
3962}
3963
3964static void cont_read_append_array(eval_context_t *ctx) {
3965 lbm_uint *sptr = get_stack_ptr(ctx, 4);
3966
3967 lbm_value array = sptr[0];
3968 lbm_value size = lbm_dec_as_u32(sptr[1]);
3969 lbm_value ix = lbm_dec_as_u32(sptr[2]);
3970 lbm_value stream = sptr[3];
3971
3972 if (ix >= (size - 1)) {
3973 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3974 }
3975
3976 // get_car can return nil. Whose value is 0!
3977 // So static Analysis is right about this being a potential NULL pointer.
3978 // However, if the array was created correcly to begin with, it should be fine.
3979 lbm_value arr_car = get_car(array);
3980 lbm_array_header_t *arr = (lbm_array_header_t*)arr_car;
3981
3982 if (lbm_is_number(ctx->r)) {
3983 ((uint8_t*)arr->data)[ix] = (uint8_t)lbm_dec_as_u32(ctx->r);
3984
3985 sptr[2] = lbm_enc_u(ix + 1);
3986 lbm_value *rptr = stack_reserve(ctx, 4);
3987 rptr[0] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3988 rptr[1] = stream;
3989 rptr[2] = lbm_enc_u(0);
3990 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3991 ctx->app_cont = true1;
3992 } else if (lbm_is_symbol(ctx->r) && ctx->r == ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u)) {
3993 lbm_uint array_size = ix / sizeof(lbm_uint);
3994
3995 if (ix % sizeof(lbm_uint) != 0) {
3996 array_size = array_size + 1;
3997 }
3998 lbm_memory_shrink((lbm_uint*)arr->data, array_size);
3999 arr->size = ix;
4000 lbm_stack_drop(&ctx->K, 4);
4001 ctx->r = array;
4002 ctx->app_cont = true1;
4003 } else {
4004 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
4005 }
4006}
4007
4008static void cont_read_append_continue(eval_context_t *ctx) {
4009 lbm_value *sptr = get_stack_ptr(ctx, 3);
4010
4011 lbm_value first_cell = sptr[0];
4012 lbm_value last_cell = sptr[1];
4013 lbm_value stream = sptr[2];
4014
4015 lbm_char_channel_t *str = lbm_dec_channel(stream);
4016 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4017 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4018 }
4019
4020 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4021
4022 switch(ctx->r) {
4023 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4024 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4025 lbm_set_cdr(last_cell, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate the list
4026 ctx->r = first_cell;
4027 } else {
4028 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4029 }
4030 lbm_stack_drop(&ctx->K, 3);
4031 /* Skip reading another token and apply the continuation */
4032 ctx->app_cont = true1;
4033 return;
4034 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4035 lbm_value *rptr = stack_reserve(ctx, 4);
4036 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4037 rptr[1] = stream;
4038 rptr[2] = lbm_enc_u(0);
4039 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4040 ctx->app_cont = true1;
4041 } return;
4042 }
4043 }
4044 lbm_value new_cell = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4045 if (lbm_is_symbol_merror(new_cell)) {
4046 lbm_channel_reader_close(str);
4047 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4048 return;
4049 }
4050 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4051 lbm_set_cdr(last_cell, new_cell);
4052 last_cell = new_cell;
4053 } else {
4054 first_cell = last_cell = new_cell;
4055 }
4056 sptr[0] = first_cell;
4057 sptr[1] = last_cell;
4058 sptr[2] = stream; // unchanged.
4059 lbm_value *rptr = stack_reserve(ctx, 4);
4060 rptr[0] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
4061 rptr[1] = stream;
4062 rptr[2] = lbm_enc_u(0);
4063 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4064 ctx->app_cont = true1;
4065}
4066
4067static void cont_read_eval_continue(eval_context_t *ctx) {
4068 lbm_value env;
4069 lbm_value stream;
4070 lbm_pop_2(&ctx->K, &env, &stream);
4071
4072 lbm_char_channel_t *str = lbm_dec_channel(stream);
4073 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4074 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4075 }
4076
4077 ctx->row1 = (lbm_int)str->row(str);
4078
4079 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4080
4081 switch(ctx->r) {
4082 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4083 ctx->app_cont = true1;
4084 return;
4085 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4086 // This case is a bit mysterious.
4087 // A dot, may in reality be an error in this location.
4088 lbm_value *rptr = stack_reserve(ctx, 4);
4089 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4090 rptr[1] = stream;
4091 rptr[2] = lbm_enc_u(0);
4092 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4093 ctx->app_cont = true1;
4094 } return;
4095 }
4096 }
4097
4098 lbm_value *rptr = stack_reserve(ctx, 6);
4099 rptr[0] = stream;
4100 rptr[1] = env;
4101 rptr[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
4102 rptr[3] = stream;
4103 rptr[4] = lbm_enc_u(1);
4104 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4105 rptr[6] = lbm_enc_u(ctx->flags);
4106 rptr[7] = POP_READER_FLAGS(((47) << 2) | 0xF8000001u);
4107 ctx->curr_env = env;
4108 ctx->curr_exp = ctx->r;
4109}
4110
4111static void cont_read_expect_closepar(eval_context_t *ctx) {
4112 lbm_value res;
4113 lbm_value stream;
4114
4115 lbm_pop_2(&ctx->K, &res, &stream);
4116
4117 lbm_char_channel_t *str = lbm_dec_channel(stream);
4118 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4119 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4120 }
4121
4122 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4123 ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u)) {
4124 ctx->r = res;
4125 ctx->app_cont = true1;
4126 } else {
4127 lbm_channel_reader_close(str);
4128 lbm_set_error_reason((char*)lbm_error_str_parse_close);
4129 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4130 }
4131}
4132
4133static void cont_read_dot_terminate(eval_context_t *ctx) {
4134 lbm_value *sptr = get_stack_ptr(ctx, 3);
4135
4136 lbm_value first_cell = sptr[0];
4137 lbm_value last_cell = sptr[1];
4138 lbm_value stream = sptr[2];
4139
4140 lbm_char_channel_t *str = lbm_dec_channel(stream);
4141 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4142 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4143 }
4144
4145 lbm_stack_drop(&ctx->K ,3);
4146
4147 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4148 (ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u) ||
4149 ctx->r == ENC_SYM_DOT(((0x76) << 4) | 0x00000000u))) {
4150 lbm_channel_reader_close(str);
4151 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4152 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4153 } else {
4154 if (lbm_is_cons(last_cell)) {
4155 lbm_set_cdr(last_cell, ctx->r);
4156 ctx->r = first_cell;
4157 lbm_value *rptr = stack_reserve(ctx, 6);
4158 rptr[0] = stream;
4159 rptr[1] = ctx->r;
4160 rptr[2] = READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u);
4161 rptr[3] = stream;
4162 rptr[4] = lbm_enc_u(0);
4163 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4164 ctx->app_cont = true1;
4165 } else {
4166 lbm_channel_reader_close(str);
4167 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4168 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4169 }
4170 }
4171}
4172
4173static void cont_read_done(eval_context_t *ctx) {
4174 lbm_value stream;
4175 lbm_value f_val;
4176 lbm_pop_2(&ctx->K, &stream ,&f_val);
4177
4178 uint32_t flags = lbm_dec_as_u32(f_val);
4179 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4180 ctx->flags |= (flags & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4181
4182 lbm_char_channel_t *str = lbm_dec_channel(stream);
4183 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4184 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4185 }
4186
4187 lbm_channel_reader_close(str);
4188 if (lbm_is_symbol(ctx->r)) {
4189 lbm_uint sym_val = lbm_dec_sym(ctx->r);
4190 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
4191 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
4192 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4193 }
4194 }
4195
4196 ctx->row0 = -1;
4197 ctx->row1 = -1;
4198 ctx->app_cont = true1;
4199}
4200
4201static void cont_read_quote_result(eval_context_t *ctx) {
4202 lbm_value cell;
4203 WITH_GC(cell, lbm_heap_allocate_list_init(2,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4204 ENC_SYM_QUOTE,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4205 ctx->r))(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
};
4206 ctx->r = cell;
4207 ctx->app_cont = true1;
4208}
4209
4210static void cont_read_commaat_result(eval_context_t *ctx) {
4211 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4212 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4213 ctx->r = cell1;
4214 ctx->app_cont = true1;
4215}
4216
4217static void cont_read_comma_result(eval_context_t *ctx) {
4218 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u),ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4219 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4220 ctx->r = cell1;
4221 ctx->app_cont = true1;
4222}
4223
4224static void cont_application_start(eval_context_t *ctx) {
4225
4226 /* sptr[0] = env
4227 * sptr[1] = args
4228 * ctx->r = function
4229 */
4230
4231 if (lbm_is_symbol(ctx->r)) {
4232 stack_reserve(ctx,1)[0] = lbm_enc_u(0);
4233 cont_application_args(ctx);
4234 } else if (lbm_is_cons(ctx->r)) {
4235 lbm_uint *sptr = get_stack_ptr(ctx, 2);
4236 lbm_value args = (lbm_value)sptr[1];
4237 switch (get_car(ctx->r)) {
4238 case ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u): {
4239 lbm_value cl[3];
4240 extract_n(get_cdr(ctx->r), cl, 3);
4241 lbm_value arg_env = (lbm_value)sptr[0];
4242 lbm_value arg0, arg_rest;
4243 get_car_and_cdr(args, &arg0, &arg_rest);
4244 sptr[1] = cl[CLO_BODY1];
4245 bool_Bool a_nil = lbm_is_symbol_nil(args);
4246 bool_Bool p_nil = lbm_is_symbol_nil(cl[CLO_PARAMS0]);
4247 lbm_value *reserved = stack_reserve(ctx, 4);
4248
4249 if (!a_nil && !p_nil) {
4250 reserved[0] = cl[CLO_ENV2];
4251 reserved[1] = cl[CLO_PARAMS0];
4252 reserved[2] = arg_rest;
4253 reserved[3] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
4254 ctx->curr_exp = arg0;
4255 ctx->curr_env = arg_env;
4256 } else if (a_nil && p_nil) {
4257 // No params, No args
4258 lbm_stack_drop(&ctx->K, 6);
4259 ctx->curr_exp = cl[CLO_BODY1];
4260 ctx->curr_env = cl[CLO_ENV2];
4261 } else if (p_nil) {
4262 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), cl[CLO_ENV2]);
4263 reserved[0] = rest_binder;
4264 reserved[1] = get_cdr(args);
4265 reserved[2] = get_car(rest_binder);
4266 reserved[3] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
4267 ctx->curr_exp = get_car(args);
4268 ctx->curr_env = arg_env;
4269 } else {
4270 lbm_set_error_reason((char*)lbm_error_str_num_args);
4271 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->r);
4272 }
4273 } break;
4274 case ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u):{
4275 /* Continuation created using call-cc.
4276 * ((SYM_CONT . cont-array) arg0 )
4277 */
4278 lbm_value c = get_cdr(ctx->r); /* should be the continuation array*/
4279
4280 if (!lbm_is_lisp_array_r(c)) {
4281 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4282 }
4283
4284 lbm_uint arg_count = lbm_list_length(args);
4285 lbm_value arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4286 switch (arg_count) {
4287 case 0:
4288 arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4289 break;
4290 case 1:
4291 arg = get_car(args);
4292 break;
4293 default:
4294 lbm_set_error_reason((char*)lbm_error_str_num_args);
4295 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4296 }
4297 lbm_stack_clear(&ctx->K);
4298
4299 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(c);
4300
4301 ctx->K.sp = arr->size / sizeof(lbm_uint);
4302 memcpy(ctx->K.data, arr->data, arr->size);
4303
4304 ctx->curr_exp = arg;
4305 break;
4306 }
4307 case ENC_SYM_MACRO(((0x10D) << 4) | 0x00000000u):{
4308 /*
4309 * Perform macro expansion.
4310 * Macro expansion is really just evaluation in an
4311 * environment augmented with the unevaluated expressions passed
4312 * as arguments.
4313 */
4314 lbm_value env = (lbm_value)sptr[0];
4315
4316 lbm_value curr_param = get_cadr(ctx->r);
4317 lbm_value curr_arg = args;
4318 lbm_value expand_env = env;
4319 while (lbm_is_cons(curr_param) &&
4320 lbm_is_cons(curr_arg)) {
4321 lbm_value car_curr_param, cdr_curr_param;
4322 lbm_value car_curr_arg, cdr_curr_arg;
4323 get_car_and_cdr(curr_param, &car_curr_param, &cdr_curr_param);
4324 get_car_and_cdr(curr_arg, &car_curr_arg, &cdr_curr_arg);
4325
4326 lbm_value entry = cons_with_gc(car_curr_param, car_curr_arg, expand_env);
4327 lbm_value aug_env = cons_with_gc(entry, expand_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4328 expand_env = aug_env;
4329
4330 curr_param = cdr_curr_param;
4331 curr_arg = cdr_curr_arg;
4332 }
4333 /* Two rounds of evaluation is performed.
4334 * First to instantiate the arguments into the macro body.
4335 * Second to evaluate the resulting program.
4336 */
4337 sptr[1] = EVAL_R(((11) << 2) | 0xF8000001u);
4338 lbm_value exp = get_cadr(get_cdr(ctx->r));
4339 ctx->curr_exp = exp;
4340 ctx->curr_env = expand_env;
4341 } break;
4342 default:
4343 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4344 }
4345 } else {
4346 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4347 }
4348}
4349
4350static void cont_eval_r(eval_context_t* ctx) {
4351 lbm_value env;
4352 lbm_pop(&ctx->K, &env);
4353 ctx->curr_exp = ctx->r;
4354 ctx->curr_env = env;
4355}
4356
4357static void cont_progn_var(eval_context_t* ctx) {
4358
4359 lbm_value key;
4360 lbm_value env;
4361
4362 lbm_pop_2(&ctx->K, &key, &env);
4363
4364 if (fill_binding_location(key, ctx->r, env) < 0) {
4365 lbm_set_error_reason("Incorrect type of name/key in let-binding");
4366 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
4367 }
4368
4369 ctx->app_cont = true1;
4370}
4371
4372static void cont_setq(eval_context_t *ctx) {
4373 lbm_value sym;
4374 lbm_value env;
4375 lbm_pop_2(&ctx->K, &sym, &env);
4376 lbm_value res;
4377 WITH_GC(res, perform_setvar(sym, ctx->r, env))(res) = (perform_setvar(sym, ctx->r, env)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (perform_setvar(sym, ctx->r, env)
); if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
4378 ctx->r = res;
4379 ctx->app_cont = true1;
4380}
4381
4382lbm_flash_status request_flash_storage_cell(lbm_value val, lbm_value *res) {
4383
4384 lbm_value flash_cell;
4385 lbm_flash_status s = lbm_allocate_const_cell(&flash_cell);
4386 if (s != LBM_FLASH_WRITE_OK)
4387 return s;
4388 lbm_value new_val = val;
4389 new_val &= ~LBM_PTR_VAL_MASK0x03FFFFFCu; // clear the value part of the ptr
4390 new_val |= (flash_cell & LBM_PTR_VAL_MASK0x03FFFFFCu);
4391 new_val |= LBM_PTR_TO_CONSTANT_BIT0x04000000u;
4392 *res = new_val;
4393 return s;
4394}
4395
4396static void cont_move_to_flash(eval_context_t *ctx) {
4397
4398 lbm_value args;
4399 lbm_pop(&ctx->K, &args);
4400
4401 if (lbm_is_symbol_nil(args)) {
4402 // Done looping over arguments. return true.
4403 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
4404 ctx->app_cont = true1;
4405 return;
4406 }
4407
4408 lbm_value first_arg, rest;
4409 get_car_and_cdr(args, &first_arg, &rest);
4410
4411 lbm_value val;
4412 if (lbm_is_symbol(first_arg) && lbm_global_env_lookup(&val, first_arg)) {
4413 // Prepare to copy the rest of the arguments when done with first.
4414 lbm_value *rptr = stack_reserve(ctx, 2);
4415 rptr[0] = rest;
4416 rptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
4417 if (lbm_is_ptr(val) &&
4418 (!(val & LBM_PTR_TO_CONSTANT_BIT0x04000000u))) {
4419 lbm_value * rptr1 = stack_reserve(ctx, 3);
4420 rptr1[0] = first_arg;
4421 rptr1[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
4422 rptr1[2] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4423 ctx->r = val;
4424 }
4425 ctx->app_cont = true1;
4426 return;
4427 }
4428 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4429}
4430
4431static void cont_move_val_to_flash_dispatch(eval_context_t *ctx) {
4432
4433 lbm_value val = ctx->r;
4434
4435 if (lbm_is_cons(val)) {
4436 lbm_value *rptr = stack_reserve(ctx, 5);
4437 rptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // fst cell of list
4438 rptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last cell of list
4439 rptr[2] = get_cdr(val);
4440 rptr[3] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4441 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4442 ctx->r = get_car(val);
4443 ctx->app_cont = true1;
4444 return;
4445 }
4446
4447 if (lbm_is_ptr(val) && (val & LBM_PTR_TO_CONSTANT_BIT0x04000000u)) {
4448 ctx->r = val;
4449 ctx->app_cont = true1;
4450 return;
4451 }
4452
4453 if (lbm_is_ptr(val)) {
4454 lbm_cons_t *ref = lbm_ref_cell(val);
4455 if (lbm_type_of(ref->cdr) == LBM_TYPE_SYMBOL0x00000000u) {
4456 switch (ref->cdr) {
4457 case ENC_SYM_RAW_I_TYPE(((0x31) << 4) | 0x00000000u): /* fall through */
4458 case ENC_SYM_RAW_U_TYPE(((0x32) << 4) | 0x00000000u):
4459 case ENC_SYM_RAW_F_TYPE(((0x33) << 4) | 0x00000000u): {
4460 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4461 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4462 handle_flash_status(write_const_car(flash_cell, ref->car));
4463 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4464 ctx->r = flash_cell;
4465 } break;
4466 case ENC_SYM_IND_I_TYPE(((0x34) << 4) | 0x00000000u): /* fall through */
4467 case ENC_SYM_IND_U_TYPE(((0x35) << 4) | 0x00000000u):
4468 case ENC_SYM_IND_F_TYPE(((0x36) << 4) | 0x00000000u): {
4469#ifndef LBM64
4470 /* 64 bit values are in lbm mem on 32bit platforms. */
4471 lbm_uint *lbm_mem_ptr = (lbm_uint*)ref->car;
4472 lbm_uint flash_ptr;
4473
4474 handle_flash_status(lbm_write_const_raw(lbm_mem_ptr, 2, &flash_ptr));
4475 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4476 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4477 handle_flash_status(write_const_car(flash_cell, flash_ptr));
4478 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4479 ctx->r = flash_cell;
4480#else
4481 // There are no indirect types in LBM64
4482 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4483#endif
4484 } break;
4485 case ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u): {
4486 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4487 lbm_uint size = arr->size / sizeof(lbm_uint);
4488 lbm_uint flash_addr;
4489 lbm_value *arrdata = (lbm_value *)arr->data;
4490 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4491 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4492 handle_flash_status(lbm_allocate_const_raw(size, &flash_addr));
4493 lift_array_flash(flash_cell,
4494 false0,
4495 (char *)flash_addr,
4496 arr->size);
4497 // Move array contents to flash recursively
4498 lbm_value *rptr = stack_reserve(ctx, 5);
4499 rptr[0] = flash_cell;
4500 rptr[1] = lbm_enc_u(0);
4501 rptr[2] = val;
4502 rptr[3] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4503 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4504 ctx->r = arrdata[0];
4505 ctx->app_cont = true1;
4506 return;
4507 }
4508 case ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u): {
4509 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4510 // arbitrary address: flash_arr.
4511 lbm_uint flash_arr;
4512 handle_flash_status(lbm_write_const_array_padded((uint8_t*)arr->data, arr->size, &flash_arr));
4513 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4514 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4515 lift_array_flash(flash_cell,
4516 true1,
4517 (char *)flash_arr,
4518 arr->size);
4519 ctx->r = flash_cell;
4520 } break;
4521 case ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u): /* fall through */
4522 case ENC_SYM_CUSTOM_TYPE(((0x38) << 4) | 0x00000000u):
4523 lbm_set_error_reason((char *)lbm_error_str_flash_not_possible);
4524 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4525 }
4526 } else {
4527 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4528 }
4529 ctx->app_cont = true1;
4530 return;
4531 }
4532 ctx->r = val;
4533 ctx->app_cont = true1;
4534}
4535
4536static void cont_move_list_to_flash(eval_context_t *ctx) {
4537
4538 // ctx->r holds the value that should go in car
4539
4540 lbm_value *sptr = get_stack_ptr(ctx, 3);
4541
4542 lbm_value fst = sptr[0];
4543 lbm_value lst = sptr[1];
4544 lbm_value val = sptr[2];
4545
4546
4547 lbm_value new_lst = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4548 // Allocate element ptr storage after storing the element to flash.
4549 handle_flash_status(request_flash_storage_cell(lbm_enc_cons_ptr(LBM_PTR_NULL(0x03FFFFFCu >> 2)), &new_lst));
4550
4551 if (lbm_is_symbol_nil(fst)) {
4552 lst = new_lst;
4553 fst = new_lst;
4554 handle_flash_status(write_const_car(lst, ctx->r));
4555 } else {
4556 handle_flash_status(write_const_cdr(lst, new_lst)); // low before high
4557 handle_flash_status(write_const_car(new_lst, ctx->r));
4558 lst = new_lst;
4559 }
4560
4561 if (lbm_is_cons(val)) {
4562 sptr[0] = fst;
4563 sptr[1] = lst;//rest_cell;
4564 sptr[2] = get_cdr(val);
4565 lbm_value *rptr = stack_reserve(ctx, 2);
4566 rptr[0] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4567 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4568 ctx->r = get_car(val);
4569 } else {
4570 sptr[0] = fst;
4571 sptr[1] = lst;
4572 sptr[2] = CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u);
4573 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4574 ctx->r = val;
4575 }
4576 ctx->app_cont = true1;
4577}
4578
4579static void cont_close_list_in_flash(eval_context_t *ctx) {
4580 lbm_value fst;
4581 lbm_value lst;
4582 lbm_pop_2(&ctx->K, &lst, &fst);
4583 lbm_value val = ctx->r;
4584 handle_flash_status(write_const_cdr(lst, val));
4585 ctx->r = fst;
4586 ctx->app_cont = true1;
4587}
4588
4589static void cont_move_array_elts_to_flash(eval_context_t *ctx) {
4590 lbm_value *sptr = get_stack_ptr(ctx, 3);
4591 // sptr[2] = source array in RAM
4592 // sptr[1] = current index
4593 // sptr[0] = target array in flash
4594 lbm_array_header_t *src_arr = (lbm_array_header_t*)get_car(sptr[2]);
4595 lbm_uint size = src_arr->size / sizeof(lbm_uint);
4596 lbm_value *srcdata = (lbm_value *)src_arr->data;
4597
4598 lbm_array_header_t *tgt_arr = (lbm_array_header_t*)get_car(sptr[0]);
4599 lbm_uint *tgtdata = (lbm_value *)tgt_arr->data;
4600 lbm_uint ix = lbm_dec_as_u32(sptr[1]);
4601 handle_flash_status(lbm_const_write(&tgtdata[ix], ctx->r));
4602 if (ix >= size-1) {
4603 ctx->r = sptr[0];
4604 lbm_stack_drop(&ctx->K, 3);
4605 ctx->app_cont = true1;
4606 return;
4607 }
4608 sptr[1] = lbm_enc_u(ix + 1);
4609 lbm_value *rptr = stack_reserve(ctx, 2);
4610 rptr[0] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4611 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4612 ctx->r = srcdata[ix+1];
4613 ctx->app_cont = true1;
4614 return;
4615}
4616
4617static void cont_qq_expand_start(eval_context_t *ctx) {
4618 lbm_value *rptr = stack_reserve(ctx, 2);
4619 rptr[0] = ctx->r;
4620 rptr[1] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4621 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4622 ctx->app_cont = true1;
4623}
4624
4625lbm_value quote_it(lbm_value qquoted) {
4626 if (lbm_is_symbol(qquoted) &&
4627 lbm_is_special(qquoted)) return qquoted;
4628
4629 lbm_value val = cons_with_gc(qquoted, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4630 return cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4631}
4632
4633bool_Bool is_append(lbm_value a) {
4634 return (lbm_is_cons(a) &&
4635 lbm_is_symbol(get_car(a)) &&
4636 (get_car(a) == ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u)));
4637}
4638
4639lbm_value append(lbm_value front, lbm_value back) {
4640 if (lbm_is_symbol_nil(front)) return back;
4641 if (lbm_is_symbol_nil(back)) return front;
4642
4643 if (lbm_is_quoted_list(front) &&
4644 lbm_is_quoted_list(back)) {
4645 lbm_value f = get_cadr(front);
4646 lbm_value b = get_cadr(back);
4647 return quote_it(lbm_list_append(f, b));
4648 }
4649
4650 if (is_append(back) &&
4651 lbm_is_quoted_list(get_cadr(back)) &&
4652 lbm_is_quoted_list(front)) {
4653 lbm_value ql = get_cadr(back);
4654 lbm_value f = get_cadr(front);
4655 lbm_value b = get_cadr(ql);
4656
4657 lbm_value v = lbm_list_append(f, b);
4658 lbm_set_car(get_cdr(ql), v);
4659 return back;
4660 }
4661
4662 if (is_append(back)) {
4663 back = get_cdr(back);
4664 lbm_value new = cons_with_gc(front, back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4665 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), new, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4666 }
4667
4668 lbm_value t0, t1;
4669
4670 t0 = cons_with_gc(back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), front);
4671 t1 = cons_with_gc(front, t0, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4672 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), t1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4673}
4674
4675/* Bawden's qq-expand implementation
4676(define (qq-expand x)
4677 (cond ((tag-comma? x)
4678 (tag-data x))
4679 ((tag-comma-atsign? x)
4680 (error "Illegal"))
4681 ((tag-backquote? x)
4682 (qq-expand
4683 (qq-expand (tag-data x))))
4684 ((pair? x)
4685 `(append
4686 ,(qq-expand-list (car x))
4687 ,(qq-expand (cdr x))))
4688 (else `',x)))
4689 */
4690static void cont_qq_expand(eval_context_t *ctx) {
4691 lbm_value qquoted;
4692 lbm_pop(&ctx->K, &qquoted);
4693
4694 switch(lbm_type_of(qquoted)) {
4695 case LBM_TYPE_CONS0x10000000u: {
4696 lbm_value car_val = get_car(qquoted);
4697 lbm_value cdr_val = get_cdr(qquoted);
4698 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4699 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4700 ctx->r = append(ctx->r, get_car(cdr_val));
4701 ctx->app_cont = true1;
4702 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4703 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4704 error_ctx(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u));
4705 } else {
4706 lbm_value *rptr = stack_reserve(ctx, 6);
4707 rptr[0] = ctx->r;
4708 rptr[1] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4709 rptr[2] = cdr_val;
4710 rptr[3] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4711 rptr[4] = car_val;
4712 rptr[5] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4713 ctx->app_cont = true1;
4714 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4715 }
4716
4717 } break;
4718 default: {
4719 lbm_value res = quote_it(qquoted);
4720 ctx->r = append(ctx->r, res);
4721 ctx->app_cont = true1;
4722 }
4723 }
4724}
4725
4726static void cont_qq_append(eval_context_t *ctx) {
4727 lbm_value head;
4728 lbm_pop(&ctx->K, &head);
4729 ctx->r = append(head, ctx->r);
4730 ctx->app_cont = true1;
4731}
4732
4733/* Bawden's qq-expand-list implementation
4734(define (qq-expand-list x)
4735 (cond ((tag-comma? x)
4736 `(list ,(tag-data x)))
4737 ((tag-comma-atsign? x)
4738 (tag-data x))
4739 ((tag-backquote? x)
4740 (qq-expand-list
4741 (qq-expand (tag-data x))))
4742 ((pair? x)
4743 `(list
4744 (append
4745 ,(qq-expand-list (car x))
4746 ,(qq-expand (cdr x)))))
4747 (else `'(,x))))
4748*/
4749
4750static void cont_qq_expand_list(eval_context_t* ctx) {
4751 lbm_value l;
4752 lbm_pop(&ctx->K, &l);
4753
4754 ctx->app_cont = true1;
4755 switch(lbm_type_of(l)) {
4756 case LBM_TYPE_CONS0x10000000u: {
4757 lbm_value car_val = get_car(l);
4758 lbm_value cdr_val = get_cdr(l);
4759 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4760 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4761 lbm_value tl = cons_with_gc(get_car(cdr_val), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4762 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4763 ctx->r = append(ctx->r, tmp);
4764 return;
4765 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4766 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4767 ctx->r = get_car(cdr_val);
4768 return;
4769 } else {
4770 lbm_value *rptr = stack_reserve(ctx, 7);
4771 rptr[0] = QQ_LIST(((39) << 2) | 0xF8000001u);
4772 rptr[1] = ctx->r;
4773 rptr[2] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4774 rptr[3] = cdr_val;
4775 rptr[4] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4776 rptr[5] = car_val;
4777 rptr[6] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4778 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4779 }
4780
4781 } break;
4782 default: {
4783 lbm_value a_list = cons_with_gc(l, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4784 lbm_value tl = cons_with_gc(a_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4785 lbm_value tmp = cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4786 ctx->r = append(ctx->r, tmp);
4787 }
4788 }
4789}
4790
4791static void cont_qq_list(eval_context_t *ctx) {
4792 lbm_value val = ctx->r;
4793 lbm_value apnd_app = cons_with_gc(val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4794 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), apnd_app, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4795 ctx->r = tmp;
4796 ctx->app_cont = true1;
4797}
4798
4799static void cont_kill(eval_context_t *ctx) {
4800 (void) ctx;
4801 finish_ctx();
4802}
4803
4804static void cont_pop_reader_flags(eval_context_t *ctx) {
4805 lbm_value flags;
4806 lbm_pop(&ctx->K, &flags);
4807 ctx->flags = ctx->flags & ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4808 ctx->flags |= (lbm_dec_as_u32(flags) & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4809 // r is unchanged.
4810 ctx->app_cont = true1;
4811}
4812
4813static void cont_exception_handler(eval_context_t *ctx) {
4814 lbm_value *sptr = pop_stack_ptr(ctx, 2);
4815 lbm_value retval = sptr[0];
4816 lbm_value flags = sptr[1];
4817 lbm_set_car(get_cdr(retval), ctx->r);
4818 ctx->flags = flags;
4819 ctx->r = retval;
4820 ctx->app_cont = true1;
4821}
4822
4823/*********************************************************/
4824/* Continuations table */
4825typedef void (*cont_fun)(eval_context_t *);
4826
4827static const cont_fun continuations[NUM_CONTINUATIONS49] =
4828 { advance_ctx, // CONT_DONE
4829 cont_set_global_env,
4830 cont_bind_to_key_rest,
4831 cont_if,
4832 cont_progn_rest,
4833 cont_application_args,
4834 cont_and,
4835 cont_or,
4836 cont_wait,
4837 cont_match,
4838 cont_application_start,
4839 cont_eval_r,
4840 cont_resume,
4841 cont_closure_application_args,
4842 cont_exit_atomic,
4843 cont_read_next_token,
4844 cont_read_append_continue,
4845 cont_read_eval_continue,
4846 cont_read_expect_closepar,
4847 cont_read_dot_terminate,
4848 cont_read_done,
4849 cont_read_quote_result,
4850 cont_read_commaat_result,
4851 cont_read_comma_result,
4852 cont_read_start_array,
4853 cont_read_append_array,
4854 cont_map,
4855 cont_match_guard,
4856 cont_terminate,
4857 cont_progn_var,
4858 cont_setq,
4859 cont_move_to_flash,
4860 cont_move_val_to_flash_dispatch,
4861 cont_move_list_to_flash,
4862 cont_close_list_in_flash,
4863 cont_qq_expand_start,
4864 cont_qq_expand,
4865 cont_qq_append,
4866 cont_qq_expand_list,
4867 cont_qq_list,
4868 cont_kill,
4869 cont_loop,
4870 cont_loop_condition,
4871 cont_merge_rest,
4872 cont_merge_layer,
4873 cont_closure_args_rest,
4874 cont_move_array_elts_to_flash,
4875 cont_pop_reader_flags,
4876 cont_exception_handler
4877 };
4878
4879/*********************************************************/
4880/* Evaluators lookup table (special forms) */
4881typedef void (*evaluator_fun)(eval_context_t *);
4882
4883static const evaluator_fun evaluators[] =
4884 {
4885 eval_quote,
4886 eval_define,
4887 eval_progn,
4888 eval_lambda,
4889 eval_if,
4890 eval_let,
4891 eval_and,
4892 eval_or,
4893 eval_match,
4894 eval_receive,
4895 eval_receive_timeout,
4896 eval_callcc,
4897 eval_atomic,
4898 eval_selfevaluating, // macro
4899 eval_selfevaluating, // cont
4900 eval_selfevaluating, // closure
4901 eval_cond,
4902 eval_app_cont,
4903 eval_var,
4904 eval_setq,
4905 eval_move_to_flash,
4906 eval_loop,
4907 eval_trap
4908 };
4909
4910
4911/*********************************************************/
4912/* Evaluator step function */
4913
4914static void evaluation_step(void){
4915 eval_context_t *ctx = ctx_running;
4916#ifdef VISUALIZE_HEAP
4917 heap_vis_gen_image();
4918#endif
4919
4920 if (ctx->app_cont) {
4921 lbm_value k;
4922 lbm_pop(&ctx->K, &k);
4923 ctx->app_cont = false0;
4924
4925 lbm_uint decoded_k = DEC_CONTINUATION(k)(((k) & ~0xF8000001u) >> 2);
4926
4927 if (decoded_k < NUM_CONTINUATIONS49) {
4928 continuations[decoded_k](ctx);
4929 } else {
4930 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4931 }
4932 return;
4933 }
4934
4935 if (lbm_is_symbol(ctx->curr_exp)) {
4936 eval_symbol(ctx);
4937 return;
4938 }
4939 if (lbm_is_cons(ctx->curr_exp)) {
4940 lbm_cons_t *cell = lbm_ref_cell(ctx->curr_exp);
4941 lbm_value h = cell->car;
4942 if (lbm_is_symbol(h) && ((h & ENC_SPECIAL_FORMS_MASK0xFFFFF000) == ENC_SPECIAL_FORMS_BIT0x00001000)) {
4943 lbm_uint eval_index = lbm_dec_sym(h) & SPECIAL_FORMS_INDEX_MASK0x000000FF;
4944 evaluators[eval_index](ctx);
4945 return;
4946 }
4947 /*
4948 * At this point head can be anything. It should evaluate
4949 * into a form that can be applied (closure, symbol, ...) though.
4950 */
4951 lbm_value *reserved = stack_reserve(ctx, 3);
4952 reserved[0] = ctx->curr_env;
4953 reserved[1] = cell->cdr;
4954 reserved[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
4955 ctx->curr_exp = h; // evaluate the function
4956 return;
4957 }
4958
4959 eval_selfevaluating(ctx);
4960 return;
4961}
4962
4963void lbm_pause_eval(void ) {
4964 eval_cps_next_state_arg = 0;
4965 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4966 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4967}
4968
4969void lbm_pause_eval_with_gc(uint32_t num_free) {
4970 eval_cps_next_state_arg = num_free;
4971 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4972 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4973}
4974
4975void lbm_continue_eval(void) {
4976 eval_cps_next_state = EVAL_CPS_STATE_RUNNING2;
4977 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4978}
4979
4980void lbm_kill_eval(void) {
4981 eval_cps_next_state = EVAL_CPS_STATE_KILL4;
4982 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4983}
4984
4985uint32_t lbm_get_eval_state(void) {
4986 return eval_cps_run_state;
4987}
4988
4989// Will wake up thread that is sleeping as well.
4990// Not sure this is good behavior.
4991static void handle_event_unblock_ctx(lbm_cid cid, lbm_value v) {
4992 eval_context_t *found = NULL((void*)0);
4993 mutex_lock(&qmutex);
4994
4995 found = lookup_ctx_nm(&blocked, cid);
4996 if (found) {
4997 drop_ctx_nm(&blocked,found);
4998 if (lbm_is_error(v)) {
4999 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
5000 found->app_cont = true1;
5001 }
5002 found->r = v;
5003 enqueue_ctx_nm(&queue,found);
5004 }
5005 mutex_unlock(&qmutex);
5006}
5007
5008static void handle_event_define(lbm_value key, lbm_value val) {
5009 lbm_uint dec_key = lbm_dec_sym(key);
5010 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
5011 lbm_value *global_env = lbm_get_global_env();
5012 lbm_uint orig_env = global_env[ix_key];
5013 lbm_value new_env;
5014 // A key is a symbol and should not need to be remembered.
5015 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
5016
5017 global_env[ix_key] = new_env;
5018}
5019
5020static lbm_value get_event_value(lbm_event_t *e) {
5021 lbm_value v;
5022 if (e->buf_len > 0) {
5023 lbm_flat_value_t fv;
5024 fv.buf = (uint8_t*)e->buf_ptr;
5025 fv.buf_size = e->buf_len;
5026 fv.buf_pos = 0;
5027 if (!lbm_unflatten_value(&fv, &v)) {
5028 lbm_set_flags(LBM_FLAG_HANDLER_EVENT_DELIVERY_FAILED(1 << 1));
5029 v = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
5030 }
5031 // Free the flat value buffer. GC is unaware of its existence.
5032 lbm_free(fv.buf);
5033 } else {
5034 v = (lbm_value)e->buf_ptr;
5035 }
5036 return v;
5037}
5038
5039static void process_events(void) {
5040
5041 if (!lbm_events) return;
5042 lbm_event_t e;
5043
5044 while (lbm_event_pop(&e)) {
5045
5046 lbm_value event_val = get_event_value(&e);
5047 switch(e.type) {
5048 case LBM_EVENT_UNBLOCK_CTX:
5049 handle_event_unblock_ctx((lbm_cid)e.parameter, event_val);
5050 break;
5051 case LBM_EVENT_DEFINE:
5052 handle_event_define((lbm_value)e.parameter, event_val);
5053 break;
5054 case LBM_EVENT_FOR_HANDLER:
5055 if (lbm_event_handler_pid >= 0) {
5056 lbm_find_receiver_and_send(lbm_event_handler_pid, event_val);
5057 }
5058 break;
5059 }
5060 }
5061}
5062
5063/* eval_cps_run can be paused
5064 I think it would be better use a mailbox for
5065 communication between other threads and the run_eval
5066 but for now a set of variables will be used. */
5067void lbm_run_eval(void){
5068
5069 if (setjmp(critical_error_jmp_buf)_setjmp (critical_error_jmp_buf) > 0) {
5070 printf_callback("GC stack overflow!\n");
5071 critical_error_callback();
5072 // terminate evaluation thread.
5073 return;
5074 }
5075
5076 setjmp(error_jmp_buf)_setjmp (error_jmp_buf);
5077
5078 while (eval_running) {
5079 if (eval_cps_state_changed || eval_cps_run_state == EVAL_CPS_STATE_PAUSED1) {
5080 eval_cps_state_changed = false0;
5081 switch (eval_cps_next_state) {
5082 case EVAL_CPS_STATE_PAUSED1:
5083 if (eval_cps_run_state != EVAL_CPS_STATE_PAUSED1) {
5084 if (lbm_heap_num_free() < eval_cps_next_state_arg) {
5085 gc();
5086 }
5087 eval_cps_next_state_arg = 0;
5088 }
5089 eval_cps_run_state = EVAL_CPS_STATE_PAUSED1;
5090 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5091 continue; /* jump back to start of eval_running loop */
5092 case EVAL_CPS_STATE_KILL4:
5093 eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
5094 eval_running = false0;
5095 continue;
5096 default: // running state
5097 eval_cps_run_state = eval_cps_next_state;
5098 break;
5099 }
5100 }
5101 while (true1) {
5102 if (eval_steps_quota && ctx_running) {
5103 eval_steps_quota--;
5104 evaluation_step();
5105 } else {
5106 if (eval_cps_state_changed) break;
5107 eval_steps_quota = eval_steps_refill;
5108 if (is_atomic) {
5109 if (!ctx_running) {
5110 lbm_set_flags(LBM_FLAG_ATOMIC_MALFUNCTION(1 << 0));
5111 is_atomic = 0;
5112 }
5113 } else {
5114 if (gc_requested) {
5115 gc();
5116 }
5117 process_events();
5118 mutex_lock(&qmutex);
5119 if (ctx_running) {
5120 enqueue_ctx_nm(&queue, ctx_running);
5121 ctx_running = NULL((void*)0);
5122 }
5123 wake_up_ctxs_nm();
5124 ctx_running = dequeue_ctx_nm(&queue);
5125 mutex_unlock(&qmutex);
5126 if (!ctx_running) {
5127 lbm_system_sleeping = true1;
5128 //Fixed sleep interval to poll events regularly.
5129 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5130 lbm_system_sleeping = false0;
5131 }
5132 }
5133 }
5134 }
5135 }
5136}
5137
5138lbm_cid lbm_eval_program(lbm_value lisp) {
5139 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), 256, NULL((void*)0));
5140}
5141
5142lbm_cid lbm_eval_program_ext(lbm_value lisp, unsigned int stack_size) {
5143 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), stack_size, NULL((void*)0));
5144}
5145
5146int lbm_eval_init() {
5147 if (!qmutex_initialized) {
5148 mutex_init(&qmutex);
5149 qmutex_initialized = true1;
5150 }
5151 if (!lbm_events_mutex_initialized) {
5152 mutex_init(&lbm_events_mutex);
5153 lbm_events_mutex_initialized = true1;
5154 }
5155 if (!blocking_extension_mutex_initialized) {
5156 mutex_init(&blocking_extension_mutex);
5157 blocking_extension_mutex_initialized = true1;
5158 }
5159
5160 mutex_lock(&qmutex);
5161 mutex_lock(&lbm_events_mutex);
5162
5163 blocked.first = NULL((void*)0);
5164 blocked.last = NULL((void*)0);
5165 queue.first = NULL((void*)0);
5166 queue.last = NULL((void*)0);
5167 ctx_running = NULL((void*)0);
5168
5169 eval_cps_run_state = EVAL_CPS_STATE_RUNNING2;
5170
5171 mutex_unlock(&lbm_events_mutex);
5172 mutex_unlock(&qmutex);
5173
5174 if (!lbm_init_env()) return 0;
5175 eval_running = true1;
5176 return 1;
5177}
5178
5179bool_Bool lbm_eval_init_events(unsigned int num_events) {
5180
5181 mutex_lock(&lbm_events_mutex);
5182 lbm_events = (lbm_event_t*)lbm_malloc(num_events * sizeof(lbm_event_t));
5183 bool_Bool r = false0;
5184 if (lbm_events) {
5185 lbm_events_max = num_events;
5186 lbm_events_head = 0;
5187 lbm_events_tail = 0;
5188 lbm_events_full = false0;
5189 lbm_event_handler_pid = -1;
5190 r = true1;
5191 }
5192 mutex_unlock(&lbm_events_mutex);
5193 return r;
5194}
+
+
←

./include/heap.h

+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1
2/*
3 Copyright 2018, 2024 Joel Svensson svenssonjoel@yahoo.se
4
5 This program is free software: you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation, either version 3 of the License, or
8 (at your option) any later version.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
14
15 You should have received a copy of the GNU General Public License
16 along with this program. If not, see <http://www.gnu.org/licenses/>.
17*/
18/** \file heap.h */
19
20#ifndef HEAP_H_
21#define HEAP_H_
22
23#include <string.h>
24#include <stdarg.h>
25
26#include "lbm_types.h"
27#include "symrepr.h"
28#include "stack.h"
29#include "lbm_memory.h"
30#include "lbm_defines.h"
31#include "lbm_channel.h"
32
33#ifdef __cplusplus
34extern "C" {
35#endif
36
37/*
38Planning for a more space efficient heap representation.
39TODO: Need to find a good reference to read up on this.
40 - List based heap
41 - Easy to implement and somewhat efficient
42
430000 0000 Size Free bits
44003F FFFF 4MB 10
45007F FFFF 8MB 9
4600FF FFFF 16MB 8
4701FF FFFF 32MB 7
4803FF FFFF 64MB 6 * Kind of heap size I am looking for
4907FF FFFF 128MB 5
500FFF FFFF 256MB 4
511FFF FFFF 512MB 3
52
53
54--- May 9 2021 ---
55Actually now I am much more interested in way smaller memories ;)
56
570000 0000 Size Free bits
580000 0FFF 4KB 20 |
590000 1FFF 8KB 19 |
600000 3FFF 16KB 18 |
610000 7FFF 32KB 17 |
620000 FFFF 64KB 16 |
630001 FFFF 128KB 15 |
640003 FFFF 256KB 14 | - This range is very interesting.
650007 FFFF 512KB 13
66000F FFFF 1MB 12
67001F FFFF 2MB 11
68003F FFFF 4MB 10
69007F FFFF 8MB 9
7000FF FFFF 16MB 8
7101FF FFFF 32MB 7
7203FF FFFF 64MB 6
7307FF FFFF 128MB 5
740FFF FFFF 256MB 4
751FFF FFFF 512MB 3
76
77Those are the kind of platforms that are fun... so a bunch of
78wasted bits in heap pointers if we run on small MCUs.
79
80-----------------
81
82it is also the case that not all addresses will be used if all "cells" are
83of the same size, 8 bytes...
84
85value 0: 0000 0000
86value 1: 0000 0008
87value 3: 0000 0010
88value 4: 0000 0018
89
90Means bits 0,1,2 will always be empty in a valid address.
91
92Cons cells also need to be have room for 2 pointers. So each ted cell from
93memory should be 8bytes.
94
95Things that needs to be represented within these bits:
96
97 - GC MARK one per cell
98 - TYPE: type of CAR and type of cons
99
100Types I would want:
101 - Full 32bit integer. Does not leave room for identification of type
102 - Float values. Same problem
103
104
105Free bits in pointers 64MB heap:
10631 30 29 28 27 26 2 1 0
1070 0 0 0 0 0 XX XXXX XXXX XXXX XXXX XXXX X 0 0 0
108
109
110Information needed for each cell:
111 Meaning | bits total | bits per car | bits per cdr
112 GC mark | 2 | 1 | 1 - only one of them will be used (the other is wasted)
113 Type | 2x | x | x
114 Ptr/!ptr | 2 | 1 | 1
115
116
117Types (unboxed):
118 - Symbols
119 - 28bit integer ( will need signed shift right functionality )
120 - 28bit unsigned integer
121 - Character
122
123If four types is all that should be possible (unboxed). then 2 bits are needed to differentiate.
1242 + 1 + 1 = 4 => 28bits for data.
125
126bit 0: ptr/!ptr
127bit 1: gc
128bit 2-3: type (if not ptr)
129bit 3 - 24 ptr (if ptr)
130bit 4 - 31 value (if value)
131
132An unboxed value can occupy a car or cdr field in a cons cell.
133
134types (boxed) extra information in pointer to cell can contain information
135 - 32 bit integer
136 - 32 bit unsigned integer
137 - 32 bit float
138
139boxed representation:
140 [ptr| cdr]
141 |
142 [Value | Aux + GC_MARK]
143
144Kinds of pointers:
145 - Pointer to cons cell.
146 - Pointer to unboxed value (fixnums not in a list, I hope this is so rare that it can be removed )
147 - integer
148 - unsigned integer
149 - symbol
150 - float
151 - Pointer to boxed value.
152 - 32 bit integer
153 - 32 bit unsigned integer
154 - 32 bit float
155 - (Maybe something else ? Vectors/strings allocated in memory not occupied by heap?)
156 - vector of int
157 - vector of uint
158 - vector of float
159 - vector of double
160 - String
161
16213 pointer"types" -> needs 4 bits
163for 64MB heap there are 6 free bits. So with this scheme going to 128MB or 256MB heap
164is also possible
165
166 a pointer to some off heap vector/string could be represented by
167
168 [ptr | cdr]
169 |
170 [full pointer | Aux + GC_MARK]
171 |
172 [VECTOR]
173
174Aux bits could be used for storing vector size. Up to 30bits should be available there
175>> This is problematic. Now the information that something is a vector is split up
176>> between 2 cons cells. This means GC needs both of these intact to be able to make
177>> proper decision.
178>> Will try to resolve this by adding some special symbols. But these must be symbols
179>> that cannot occur normally in programs. Then an array could be:
180
181 [Full pointer | ARRAY_SYM + GC_MARK]
182 |
183 [VECTOR]
184
185>> Boxed values same treatment as above.
186>> TODO: Could this be simpler?
187
188[ VALUE | TYPE_SYM + GC_MARK]
189
190
1910000 00XX XXXX XXXX XXXX XXXX XXXX X000 : 0x03FF FFF8
1921111 AA00 0000 0000 0000 0000 0000 0000 : 0xFC00 0000 (AA bits left unused for now, future heap growth?)
193 */
194
195typedef enum {
196 LBM_FLASH_WRITE_OK,
197 LBM_FLASH_FULL,
198 LBM_FLASH_WRITE_ERROR
199} lbm_flash_status;
200
201/** Struct representing a heap cons-cell.
202 *
203 */
204typedef struct {
205 lbm_value car;
206 lbm_value cdr;
207} lbm_cons_t;
208
209/**
210 * Heap state
211 */
212typedef struct {
213 lbm_cons_t *heap;
214 lbm_value freelist; // list of free cons cells.
215 lbm_stack_t gc_stack;
216
217 lbm_uint heap_size; // In number of cells.
218 lbm_uint heap_bytes; // In bytes.
219
220 lbm_uint num_alloc; // Number of cells allocated.
221 lbm_uint num_alloc_arrays; // Number of arrays allocated.
222
223 lbm_uint gc_num; // Number of times gc has been performed.
224 lbm_uint gc_marked; // Number of cells marked by mark phase.
225 lbm_uint gc_recovered; // Number of cells recovered by sweep phase.
226 lbm_uint gc_recovered_arrays;// Number of arrays recovered by sweep.
227 lbm_uint gc_least_free; // The smallest length of the freelist.
228 lbm_uint gc_last_free; // Number of elements on the freelist
229 // after most recent GC.
230} lbm_heap_state_t;
231
232extern lbm_heap_state_t lbm_heap_state;
233
234typedef bool_Bool (*const_heap_write_fun)(lbm_uint ix, lbm_uint w);
235
236typedef struct {
237 lbm_uint *heap;
238 lbm_uint next; // next free index.
239 lbm_uint size; // in lbm_uint words. (cons-cells = words / 2)
240} lbm_const_heap_t;
241
242/**
243 * The header portion of an array stored in array and symbol memory.
244 * An array is always a byte array. use the array-extensions for
245 * storing and reading larger values from arrays.
246 */
247typedef struct {
248 lbm_uint size; /// Number of elements
249 lbm_uint *data; /// pointer to lbm_memory array or C array.
250} lbm_array_header_t;
251
252typedef struct {
253 lbm_uint size;
254 lbm_uint *data;
255 uint32_t index; // Limits arrays to max 2^32-1 elements.
256} lbm_array_header_extended_t;
257
258/** Lock GC mutex
259 * Locks a mutex during GC marking when using the pointer reversal algorithm.
260 * Does nothing when using stack based GC mark.
261 */
262void lbm_gc_lock(void);
263/* Unlock GC mutex
264 */
265void lbm_gc_unlock(void);
266
267/** Initialize heap storage.
268 * \param addr Pointer to an array of lbm_cons_t elements. This array must at least be aligned 4.
269 * \param num_cells Number of lbm_cons_t elements in the array.
270 * \param gc_stack_size Size of the gc_stack in number of words.
271 * \return 1 on success or 0 for failure.
272 */
273int lbm_heap_init(lbm_cons_t *addr, lbm_uint num_cells,
274 lbm_uint gc_stack_size);
275
276/** Add GC time statistics to heap_stats
277 *
278 * \param dur Duration as reported by the timestamp callback.
279 */
280void lbm_heap_new_gc_time(lbm_uint dur);
281/** Add a new free_list length to the heap_stats.
282 * Calculates a new freelist length and updates
283 * the GC statistics.
284 */
285void lbm_heap_new_freelist_length(void);
286/** Check how many lbm_cons_t cells are on the free-list
287 *
288 * \return Number of free lbm_cons_t cells.
289 */
290lbm_uint lbm_heap_num_free(void);
291/** Check how many lbm_cons_t cells are allocated.
292 *
293 * \return Number of lbm_cons_t cells that are currently allocated.
294 */
295lbm_uint lbm_heap_num_allocated(void);
296/** Size of the heap in number of lbm_cons_t cells.
297 *
298 * \return Size of the heap in number of lbm_cons_t cells.
299 */
300lbm_uint lbm_heap_size(void);
301/** Size of the heap in bytes.
302 *
303 * \return Size of heap in bytes.
304 */
305lbm_uint lbm_heap_size_bytes(void);
306/** Allocate an lbm_cons_t cell from the heap.
307 *
308 * \param type A type that can be encoded onto the cell (most often LBM_PTR_TYPE_CONS).
309 * \param car Value to write into car position of allocated cell.
310 * \param cdr Value to write into cdr position of allocated cell.
311 * \return An lbm_value referring to a cons_cell or enc_sym(SYM_MERROR) in case the heap is full.
312 */
313lbm_value lbm_heap_allocate_cell(lbm_type type, lbm_value car, lbm_value cdr);
314/** Allocate a list of n heap-cells.
315 * \param n The number of heap-cells to allocate.
316 * \return A list of heap-cells of Memory error if unable to allocate.
317 */
318lbm_value lbm_heap_allocate_list(lbm_uint n);
319/** Allocate a list of n heap-cells and initialize the values.
320 * \pram ls The result list is passed through this ptr.
321 * \param n The length of list to allocate.
322 * \param valist The values in a va_list to initialize the list with.
323 * \return True of False depending on success of allocation.
324 */
325lbm_value lbm_heap_allocate_list_init_va(unsigned int n, va_list valist);
326/** Allocate a list of n heap-cells and initialize the values.
327 * \param n The length of list to allocate.
328 * \param ... The values to initialize the list with.
329 * \return allocated list or error symbol.
330 */
331lbm_value lbm_heap_allocate_list_init(unsigned int n, ...);
332/** Decode an lbm_value representing a string into a C string
333 *
334 * \param val Value
335 * \return allocated list or error symbol
336 */
337char *lbm_dec_str(lbm_value val);
338/** Decode an lbm_value representing a char channel into an lbm_char_channel_t pointer.
339 *
340 * \param val Value
341 * \return A pointer to an lbm_char_channel_t or NULL if the value does not encode a channel.
342 */
343lbm_char_channel_t *lbm_dec_channel(lbm_value val);
344/** Decode an lbm_value representing a custom type into a lbm_uint value.
345 *
346 * \param val Value.
347 * \return The custom type payload.
348 */
349lbm_uint lbm_dec_custom(lbm_value val);
350/** Decode a numerical value as if it is char
351 *
352 * \param val Value to decode
353 * \return The value encoded in val casted to a char. Returns 0 if val does not encode a number.
354 */
355uint8_t lbm_dec_as_char(lbm_value a);
356/** Decode a numerical value as if it is unsigned
357 *
358 * \param val Value to decode
359 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
360 */
361uint32_t lbm_dec_as_u32(lbm_value val);
362/** Decode a numerical value as a signed integer.
363 *
364 * \param val Value to decode
365 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
366 */
367int32_t lbm_dec_as_i32(lbm_value val);
368/** Decode a numerical value as a float.
369 *
370 * \param val Value to decode.
371 * \return The value encoded in val casted to a float. Returns 0 if val does not encode a number.
372 */
373float lbm_dec_as_float(lbm_value val);
374/** Decode a numerical value as if it is a 64bit unsigned
375 *
376 * \param val Value to decode
377 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
378 */
379uint64_t lbm_dec_as_u64(lbm_value val);
380/** Decode a numerical value as a 64bit signed integer.
381 *
382 * \param val Value to decode
383 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
384 */
385int64_t lbm_dec_as_i64(lbm_value val);
386/** Decode a numerical value as a float.
387 *
388 * \param val Value to decode.
389 * \return The value encoded in val casted to a float. Returns 0 if val does not encode a number.
390 */
391double lbm_dec_as_double(lbm_value val);
392
393/** Decode a numerical value into the architecture defined unsigned integer type.
394 *
395 * \param val Value to decode
396 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
397 */
398lbm_uint lbm_dec_as_uint(lbm_value val);
399
400/** Decode a numerical value into the architecture defined signed integer type.
401 *
402 * \param val Value to decode
403 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
404 */
405lbm_int lbm_dec_as_int(lbm_value val);
406
407lbm_uint lbm_dec_raw(lbm_value v);
408/** Allocates an lbm_cons_t cell from the heap and populates it.
409 *
410 * \param car The value to put in the car field of the allocated lbm_cons_t.
411 * \param cdr The value to put in the cdr field of the allocated lbm_cons_t.
412 * \return A value referencing the lbm_cons_t or enc_sym(SYM_MERROR) if heap is full.
413 */
414lbm_value lbm_cons(lbm_value car, lbm_value cdr);
415
416/** Accesses the car field of an lbm_cons_t.
417 *
418 * \param cons Value
419 * \return The car field of the lbm_cons_t if cons is a reference to a heap cell.
420 * If cons is nil, the return value is nil. If the value
421 * is not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
422 */
423lbm_value lbm_car(lbm_value cons);
424/** Accesses the car field the car field of an lbm_cons_t.
425 *
426 * \param cons Value
427 * \return The car of car field or nil.
428 */
429lbm_value lbm_caar(lbm_value c);
430/** Accesses the car of the cdr of an cons cell
431 *
432 * \param c Value
433 * \return the cdr field or type error.
434 */
435lbm_value lbm_cadr(lbm_value c);
436/** Accesses the cdr field of an lbm_cons_t.
437 *
438 * \param cons Value
439 * \return The cdr field of the lbm_cons_t if cons is a reference to a heap cell.
440 * If cons is nil, the return value is nil. If the value
441 * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
442 */
443lbm_value lbm_cdr(lbm_value cons);
444/** Accesses the cdr of an cdr field of an lbm_cons_t.
445 *
446 * \param cons Value
447 * \return The cdr of the cdr field of the lbm_cons_t if cons is a reference to a heap cell.
448 * If cons is nil, the return value is nil. If the value
449 * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
450 */
451lbm_value lbm_cddr(lbm_value c);
452/** Update the value stored in the car field of a heap cell.
453 *
454 * \param c Value referring to a heap cell.
455 * \param v Value to replace the car field with.
456 * \return 1 on success and 0 if the c value does not refer to a heap cell.
457 */
458int lbm_set_car(lbm_value c, lbm_value v);
459/** Update the value stored in the cdr field of a heap cell.
460 *
461 * \param c Value referring to a heap cell.
462 * \param v Value to replace the cdr field with.
463 * \return 1 on success and 0 if the c value does not refer to a heap cell.
464 */
465int lbm_set_cdr(lbm_value c, lbm_value v);
466/** Update the value stored in the car and cdr fields of a heap cell.
467 *
468 * \param c Value referring to a heap cell.
469 * \param car_val Value to replace the car field with.
470 * \param cdr_val Value to replace the cdr field with.
471 * \return 1 on success and 0 if the c value does not refer to a heap cell.
472 */
473int lbm_set_car_and_cdr(lbm_value c, lbm_value car_val, lbm_value cdr_val);
474// List functions
475/** Calculate the length of a proper list
476 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
477 * may lead to the function not terminating.
478 *
479 * \param c A list
480 * \return The length of the list. Unless the value is a cyclic structure on the heap, this function will terminate.
481 */
482lbm_uint lbm_list_length(lbm_value c);
483
484/** Calculate the length of a proper list and evaluate a predicate for each element.
485 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
486 * may lead to the function not terminating.
487 *
488 * \param c A list
489 * \param pres Boolean result of predicate, false if predicate is false for any of the elements in the list, otherwise true.
490 * \param pred Predicate to evaluate for each element of the list.
491 */
492unsigned int lbm_list_length_pred(lbm_value c, bool_Bool *pres, bool_Bool (*pred)(lbm_value));
493/** Reverse a proper list
494 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
495 * may lead to the function not terminating.
496 *
497 * \param list A list
498 * \return The list reversed or enc_sym(SYM_MERROR) if heap is full.
499 */
500lbm_value lbm_list_reverse(lbm_value list);
501/** Reverse a proper list destroying the original.
502 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
503 * may lead to the function not terminating.
504 *
505 * \param list A list
506 * \return The list reversed
507 */
508lbm_value lbm_list_destructive_reverse(lbm_value list);
509/** Copy a list
510 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
511 * may lead to the function not terminating.
512 *
513 * \param m Number of elements to copy or -1 for all. If 1, m will be updated with the length of the list
514 * \param list A list.
515 * \return Reversed list or enc_sym(SYM_MERROR) if heap is full.
516 */
517lbm_value lbm_list_copy(int *m, lbm_value list);
518
519/** A destructive append of two lists
520 *
521 * \param list1 A list
522 * \param list2 A list
523 * \return list1 with list2 appended at the end.
524 */
525lbm_value lbm_list_append(lbm_value list1, lbm_value list2);
526
527/** Drop values from the head of a list.
528 * \param n Number of values to drop.
529 * \param ls List to drop values from.
530 * \return The list with the n first elements removed.
531 */
532lbm_value lbm_list_drop(unsigned int n, lbm_value ls);
533/** Index into a list.
534 * \param l List to index into.
535 * \param n Position to read out of the list.
536 * \return Value at position n of l or nil if out of bounds.
537 */
538lbm_value lbm_index_list(lbm_value l, int32_t n);
539
540// State and statistics
541/** Get a copy of the heap statistics structure.
542 *
543 * \param A pointer to an lbm_heap_state_t to populate
544 * with the current statistics.
545 */
546void lbm_get_heap_state(lbm_heap_state_t *);
547/** Get the maximum stack level of the GC stack
548 * \return maximum value the gc stack sp reached so far.
549 */
550lbm_uint lbm_get_gc_stack_max(void);
551/** Get the size of the GC stack.
552 * \return the size of the gc stack.
553 */
554lbm_uint lbm_get_gc_stack_size(void);
555// Garbage collection
556/** Increment the counter that is counting the number of times GC ran
557 *
558 */
559void lbm_gc_state_inc(void);
560/** Set the freelist to NIL. Means that no memory will be available
561 * until after a garbage collection.
562 */
563void lbm_nil_freelist(void);
564/** Mark all heap cells reachable from an environment.
565 * \param environment.
566 */
567void lbm_gc_mark_env(lbm_value);
568/** Mark heap cells reachable from the lbm_value v.
569 * \param root
570 */
571void lbm_gc_mark_phase(lbm_value root);
572/** Performs lbm_gc_mark_phase on all the values of an array.
573 * This function is similar to lbm_gc_mark_roots but performs
574 * extra checks to not traverse into non-standard values.
575 * TODO: Check if this function is really needed.
576 * \param data Array of roots to traverse from.
577 * \param n Number of elements in roots-array.
578 */
579void lbm_gc_mark_aux(lbm_uint *data, lbm_uint n);
580/** Performs lbm_gc_mark_phase on all the values in the roots array.
581 * \param roots pointer to array of roots.
582 * \param num_roots size of array of roots.
583 */
584void lbm_gc_mark_roots(lbm_uint *roots, lbm_uint num_roots);
585/** Sweep up all non marked heap cells and place them on the free list.
586 *
587 * \return 1
588 */
589int lbm_gc_sweep_phase(void);
590
591// Array functionality
592/** Allocate an bytearray in symbols and arrays memory (lispbm_memory.h)
593 * and create a heap cell that refers to this bytearray.
594 * \param res The resulting lbm_value is returned through this argument.
595 * \param size Array size in number of 32 bit words.
596 * \return 1 for success of 0 for failure.
597 */
598int lbm_heap_allocate_array(lbm_value *res, lbm_uint size);
599/** Allocate an array in symbols and arrays memory (lispbm_memory.h)
600 * and create a heap cell that refers to this array.
601 * \param res The resulting lbm_value is returned through this argument.
602 * \param size Array size in number of 32 bit words.
603 * \return 1 for success of 0 for failure.
604 */
605int lbm_heap_allocate_lisp_array(lbm_value *res, lbm_uint size);
606/** Convert a C array into an lbm array. If the C array is allocated in LBM MEMORY
607 * the lifetime of the array will be managed by GC.
608 * \param res lbm_value result pointer for storage of the result array.
609 * \param data C array.
610 * \param type The type tag to assign to the resulting LBM array.
611 * \param num_elt Number of elements in the array.
612 * \return 1 for success and 0 for failure.
613 */
614int lbm_lift_array(lbm_value *value, char *data, lbm_uint num_elt);
615/** Get the size of an array value.
616 * \param arr lbm_value array to get size of.
617 * \return -1 for failure or length of array.
618 */
619lbm_int lbm_heap_array_get_size(lbm_value arr);
620/** Get a pointer to the data of an array for read only purposes.
621 * \param arr lbm_value array to get pointer from.
622 * \return NULL or valid pointer.
623 */
624const uint8_t *lbm_heap_array_get_data_ro(lbm_value arr);
625/** Get a pointer to the data of an array for read/write purposes.
626 * \param arr lbm_value array to get pointer from.
627 * \return NULL or valid pointer.
628 */
629uint8_t *lbm_heap_array_get_data_rw(lbm_value arr);
630/** Explicitly free an array.
631 * This function needs to be used with care and knowledge.
632 * \param arr Array value.
633 */
634int lbm_heap_explicit_free_array(lbm_value arr);
635/** Query the size in bytes of an lbm_type.
636 * \param t Type
637 * \return Size in bytes of type or 0 if the type represents a composite.
638 */
639lbm_uint lbm_size_of(lbm_type t);
640
641int lbm_const_heap_init(const_heap_write_fun w_fun,
642 lbm_const_heap_t *heap,
643 lbm_uint *addr,
644 lbm_uint num_words);
645
646lbm_flash_status lbm_allocate_const_cell(lbm_value *res);
647lbm_flash_status lbm_write_const_raw(lbm_uint *data, lbm_uint n, lbm_uint *res);
648lbm_flash_status lbm_allocate_const_raw(lbm_uint nwords, lbm_uint *res);
649lbm_flash_status write_const_cdr(lbm_value cell, lbm_value val);
650lbm_flash_status write_const_car(lbm_value cell, lbm_value val);
651lbm_flash_status lbm_const_write(lbm_uint *tgt, lbm_uint val);
652lbm_uint lbm_flash_memory_usage(void);
653
654/** Query the type information of a value.
655 *
656 * \param x Value to check the type of.
657 * \return The type information.
658 */
659static inline lbm_type lbm_type_of(lbm_value x) {
660 return (x & LBM_PTR_BIT0x00000001u) ? (x & LBM_PTR_TYPE_MASK0xFC000000u) : (x & LBM_VAL_TYPE_MASK0x0000000Cu);
661}
662
663// type-of check that is safe in functional code
664static inline lbm_type lbm_type_of_functional(lbm_value x) {
665 return (x & LBM_PTR_BIT0x00000001u) ?
666 (x & (LBM_PTR_TO_CONSTANT_MASK~0x04000000u & LBM_PTR_TYPE_MASK0xFC000000u)) :
667 (x & LBM_VAL_TYPE_MASK0x0000000Cu);
668}
669
670static inline lbm_value lbm_enc_cons_ptr(lbm_uint x) {
671 return ((x << LBM_ADDRESS_SHIFT2) | LBM_TYPE_CONS0x10000000u | LBM_PTR_BIT0x00000001u);
672}
673
674static inline lbm_uint lbm_dec_ptr(lbm_value p) {
675 return ((LBM_PTR_VAL_MASK0x03FFFFFCu & p) >> LBM_ADDRESS_SHIFT2);
676}
677
678extern lbm_cons_t *lbm_heaps[2];
679
680static inline lbm_uint lbm_dec_cons_cell_ptr(lbm_value p) {
681 lbm_uint h = (p & LBM_PTR_TO_CONSTANT_BIT0x04000000u) >> LBM_PTR_TO_CONSTANT_SHIFT26;
682 return lbm_dec_ptr(p) >> h;
683}
684
685static inline lbm_cons_t *lbm_dec_heap(lbm_value p) {
686 lbm_uint h = (p & LBM_PTR_TO_CONSTANT_BIT0x04000000u) >> LBM_PTR_TO_CONSTANT_SHIFT26;
687 return lbm_heaps[h];
688}
689
690static inline lbm_value lbm_set_ptr_type(lbm_value p, lbm_type t) {
691 return ((LBM_PTR_VAL_MASK0x03FFFFFCu & p) | t | LBM_PTR_BIT0x00000001u);
692}
693
694static inline lbm_value lbm_enc_sym(lbm_uint s) {
695 return (s << LBM_VAL_SHIFT4) | LBM_TYPE_SYMBOL0x00000000u;
696}
697
698static inline lbm_value lbm_enc_i(lbm_int x) {
699 return ((lbm_uint)x << LBM_VAL_SHIFT4) | LBM_TYPE_I0x00000008u;
700}
701
702static inline lbm_value lbm_enc_u(lbm_uint x) {
703 return (x << LBM_VAL_SHIFT4) | LBM_TYPE_U0x0000000Cu;
704}
705
706/** Encode 32 bit integer into an lbm_value.
707 * \param x Value to encode.
708 * \return result encoded value.
709 */
710extern lbm_value lbm_enc_i32(int32_t x);
711
712/** Encode 32 bit unsigned integer into an lbm_value.
713 * \param x Value to encode.
714 * \return result encoded value.
715 */
716extern lbm_value lbm_enc_u32(uint32_t x);
717
718/** Encode a float into an lbm_value.
719 * \param x float value to encode.
720 * \return result encoded value.
721 */
722extern lbm_value lbm_enc_float(float x);
723
724/** Encode a 64 bit integer into an lbm_value.
725 * \param x 64 bit integer to encode.
726 * \return result encoded value.
727 */
728extern lbm_value lbm_enc_i64(int64_t x);
729
730/** Encode a 64 bit unsigned integer into an lbm_value.
731 * \param x 64 bit unsigned integer to encode.
732 * \return result encoded value.
733 */
734extern lbm_value lbm_enc_u64(uint64_t x);
735
736/** Encode a double into an lbm_value.
737 * \param x double to encode.
738 * \return result encoded value.
739 */
740extern lbm_value lbm_enc_double(double x);
741
742static inline lbm_value lbm_enc_char(uint8_t x) {
743 return ((lbm_uint)x << LBM_VAL_SHIFT4) | LBM_TYPE_CHAR0x00000004u;
744}
745
746static inline lbm_int lbm_dec_i(lbm_value x) {
747 return (lbm_int)x >> LBM_VAL_SHIFT4;
748}
749
750static inline lbm_uint lbm_dec_u(lbm_value x) {
751 return x >> LBM_VAL_SHIFT4;
752}
753
754static inline uint8_t lbm_dec_char(lbm_value x) {
755 return (uint8_t)(x >> LBM_VAL_SHIFT4);
756}
757
758static inline lbm_uint lbm_dec_sym(lbm_value x) {
759 return x >> LBM_VAL_SHIFT4;
760}
761
762/** Decode an lbm_value representing a float.
763 * \param x Value to decode.
764 * \return decoded float.
765 */
766extern float lbm_dec_float(lbm_value x);
767
768/** Decode an lbm_value representing a double.
769 * \param x Value to decode.
770 * \return decoded float.
771 */
772extern double lbm_dec_double(lbm_value x);
773
774
775static inline uint32_t lbm_dec_u32(lbm_value x) {
776#ifndef LBM64
777 return (uint32_t)lbm_car(x);
778#else
779 return (uint32_t)(x >> LBM_VAL_SHIFT4);
780#endif
781}
782
783/** Decode an lbm_value representing a 64 bit unsigned integer.
784 * \param x Value to decode.
785 * \return decoded uint64_t.
786 */
787extern uint64_t lbm_dec_u64(lbm_value x);
788
789static inline int32_t lbm_dec_i32(lbm_value x) {
790#ifndef LBM64
791 return (int32_t)lbm_car(x);
792#else
793 return (int32_t)(x >> LBM_VAL_SHIFT4);
794#endif
795}
796
797/** Decode an lbm_value representing a 64 bit integer.
798 * \param x Value to decode.
799 * \return decoded int64_t.
800 */
801extern int64_t lbm_dec_i64(lbm_value x);
802
803/**
804 * Check if a value is a heap pointer
805 * \param x Value to check
806 * \return true if x is a pointer to a heap cell, false otherwise.
807 */
808static inline bool_Bool lbm_is_ptr(lbm_value x) {
809 return (x & LBM_PTR_BIT0x00000001u);
810}
811
812/**
813 * Check if a value is a Read/Writeable cons cell
814 * \param x Value to check
815 * \return true if x is a Read/Writeable cons cell, false otherwise.
816 */
817static inline bool_Bool lbm_is_cons_rw(lbm_value x) {
818 return (lbm_type_of(x) == LBM_TYPE_CONS0x10000000u);
819}
820
821/**
822 * Check if a value is a Readable cons cell
823 * \param x Value to check
824 * \return true if x is a readable cons cell, false otherwise.
825 */
826static inline bool_Bool lbm_is_cons(lbm_value x) {
827 return lbm_is_ptr(x) && ((x & LBM_CONS_TYPE_MASK0xF0000000u) == LBM_TYPE_CONS0x10000000u);
828}
829
830/** Check if a value represents a number
831 * \param x Value to check.
832 * \return true is x represents a number and false otherwise.
833 */
834static inline bool_Bool lbm_is_number(lbm_value x) {
835 return
836 (x & LBM_PTR_BIT0x00000001u) ?
837 ((x & LBM_NUMBER_MASK0x08000000u) == LBM_NUMBER_MASK0x08000000u) :
838 (x & LBM_VAL_TYPE_MASK0x0000000Cu);
839}
840
841/** Check if value is an array that can be READ
842 * \param x Value to check.
843 * \return true if x represents a readable array and false otherwise.
844 */
845static inline bool_Bool lbm_is_array_r(lbm_value x) {
846 lbm_type t = lbm_type_of(x);
847 return ((t & LBM_PTR_TO_CONSTANT_MASK~0x04000000u) == LBM_TYPE_ARRAY0x80000000u);
848}
849
850static inline bool_Bool lbm_is_array_rw(lbm_value x) {
851 return( (lbm_type_of(x) == LBM_TYPE_ARRAY0x80000000u) && !(x & LBM_PTR_TO_CONSTANT_BIT0x04000000u));
852}
853
854static inline bool_Bool lbm_is_lisp_array_r(lbm_value x) {
855 lbm_type t = lbm_type_of(x);
856 return ((t & LBM_PTR_TO_CONSTANT_MASK~0x04000000u) == LBM_TYPE_LISPARRAY0xB0000000u);
857}
858
859static inline bool_Bool lbm_is_lisp_array_rw(lbm_value x) {
860 return( (lbm_type_of(x) == LBM_TYPE_LISPARRAY0xB0000000u) && !(x & LBM_PTR_TO_CONSTANT_BIT0x04000000u));
861}
862
863
864static inline bool_Bool lbm_is_channel(lbm_value x) {
865 return (lbm_type_of(x) == LBM_TYPE_CHANNEL0x90000000u &&
866 lbm_type_of(lbm_cdr(x)) == LBM_TYPE_SYMBOL0x00000000u &&
867 lbm_cdr(x) == ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
868}
869static inline bool_Bool lbm_is_char(lbm_value x) {
870 return (lbm_type_of(x) == LBM_TYPE_CHAR0x00000004u);
871}
872
873static inline bool_Bool lbm_is_special(lbm_value symrep) {
874 return ((lbm_type_of(symrep) == LBM_TYPE_SYMBOL0x00000000u) &&
875 (lbm_dec_sym(symrep) < SPECIAL_SYMBOLS_END0xFFFF));
876}
877
878static inline bool_Bool lbm_is_closure(lbm_value exp) {
879 return ((lbm_is_cons(exp)) &&
880 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
881 (lbm_car(exp) == ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u)));
882}
883
884static inline bool_Bool lbm_is_continuation(lbm_value exp) {
885 return ((lbm_type_of(exp) == LBM_TYPE_CONS0x10000000u) &&
886 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
887 (lbm_car(exp) == ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u)));
888}
889
890static inline bool_Bool lbm_is_macro(lbm_value exp) {
891 return ((lbm_type_of(exp) == LBM_TYPE_CONS0x10000000u) &&
892 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
893 (lbm_car(exp) == ENC_SYM_MACRO(((0x10D) << 4) | 0x00000000u)));
894}
895
896static inline bool_Bool lbm_is_match_binder(lbm_value exp) {
897 return (lbm_is_cons(exp) &&
898 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
899 (lbm_car(exp) == ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u)));
900}
901
902static inline bool_Bool lbm_is_comma_qualified_symbol(lbm_value exp) {
903 return (lbm_is_cons(exp) &&
904 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
905 (lbm_car(exp) == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) &&
906 (lbm_type_of(lbm_cadr(exp)) == LBM_TYPE_SYMBOL0x00000000u));
907}
908
909static inline bool_Bool lbm_is_symbol(lbm_value exp) {
910 return !(exp & LBM_LOW_RESERVED_BITS0x0000000Fu);
911}
912
913static inline bool_Bool lbm_is_symbol_nil(lbm_value exp) {
914 return !exp;
7
←
Assuming 'exp' is not equal to 0, which participates in a condition later
→
8
←
Returning zero, which participates in a condition later
→
11
←
Assuming 'exp' is not equal to 0, which participates in a condition later
→
12
←
Returning zero, which participates in a condition later
→
915}
916
917static inline bool_Bool lbm_is_symbol_true(lbm_value exp) {
918 return (lbm_is_symbol(exp) && exp == ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u));
919}
920
921static inline bool_Bool lbm_is_symbol_eval(lbm_value exp) {
922 return (lbm_is_symbol(exp) && exp == ENC_SYM_EVAL(((0x30008) << 4) | 0x00000000u));
923}
924
925static inline bool_Bool lbm_is_symbol_merror(lbm_value exp) {
926 return lbm_is_symbol(exp) && (exp == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
927}
928
929static inline bool_Bool lbm_is_list(lbm_value x) {
930 return (lbm_is_cons(x) || lbm_is_symbol_nil(x));
931}
932
933static inline bool_Bool lbm_is_list_rw(lbm_value x) {
934 return (lbm_is_cons_rw(x) || lbm_is_symbol_nil(x));
935}
936
937static inline bool_Bool lbm_is_quoted_list(lbm_value x) {
938 return (lbm_is_cons(x) &&
939 lbm_is_symbol(lbm_car(x)) &&
940 (lbm_car(x) == ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u)) &&
941 lbm_is_cons(lbm_cdr(x)) &&
942 lbm_is_cons(lbm_cadr(x)));
943}
944
945#ifndef LBM64
946#define ERROR_SYMBOL_MASK0xFFFFFFF0 0xFFFFFFF0
947#else
948#define ERROR_SYMBOL_MASK0xFFFFFFF0 0xFFFFFFFFFFFFFFF0
949#endif
950
951/* all error signaling symbols are in the range 0x20 - 0x2F */
952static inline bool_Bool lbm_is_error(lbm_value v){
953 return (lbm_is_symbol(v) &&
954 ((lbm_dec_sym(v) & ERROR_SYMBOL_MASK0xFFFFFFF0) == 0x20));
955}
956
957// ref_cell: returns a reference to the cell addressed by bits 3 - 26
958// Assumes user has checked that is_ptr was set
959static inline lbm_cons_t* lbm_ref_cell(lbm_value addr) {
960 return &lbm_dec_heap(addr)[lbm_dec_cons_cell_ptr(addr)];
961 //return &lbm_heap_state.heap[lbm_dec_ptr(addr)];
962}
963
964
965// lbm_uint a = lbm_heaps[0];
966// lbm_uint b = lbm_heaps[1];
967// lbm_uint i = (addr & LBM_PTR_TO_CONSTANT_BIT) >> LBM_PTR_TO_CONSTANT_SHIFT) - 1;
968// lbm_uint h = (a & i) | (b & ~i);
969
970#ifdef __cplusplus
971}
972#endif
973#endif
diff --git a/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-79ea5f.html b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-79ea5f.html new file mode 100644 index 00000000..a06604c8 --- /dev/null +++ b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-79ea5f.html @@ -0,0 +1,6537 @@ + + + +src/eval_cps.c + + + + + + + + + + + + + + + + + + + + + + + + + + +

Bug Summary

+ + + + +
File:eval_cps.c
Warning:line 1664, column 10
Access to field 'data' results in a dereference of a null pointer (loaded from variable 'arr')
+ +

Annotated Source Code

+

Press '?' + to see keyboard shortcuts

+ + +
clang -cc1 -triple i386-pc-linux-gnu -analyze -disable-free -disable-llvm-verifier -discard-value-names -main-file-name eval_cps.c -analyzer-store=region -analyzer-opt-analyze-nested-blocks -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -mrelocation-model static -mthread-model posix -mframe-pointer=none -fmath-errno -fno-rounding-math -masm-verbose -mconstructor-aliases -target-cpu i686 -dwarf-column-info -fno-split-dwarf-inlining -debugger-tuning=gdb -resource-dir /usr/lib/llvm-10/lib/clang/10.0.0 -I ./include -I ./include/extensions -I platform/linux/include -D _PRELUDE -internal-isystem /usr/local/include -internal-isystem /usr/lib/llvm-10/lib/clang/10.0.0/include -internal-externc-isystem /usr/include/i386-linux-gnu -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -std=c99 -fdebug-compilation-dir /home/joels/Current/lispbm -ferror-limit 19 -fmessage-length 0 -fgnuc-version=4.2.1 -fobjc-runtime=gcc -fdiagnostics-show-option -vectorize-loops -vectorize-slp -analyzer-output=html -faddrsig -o /home/joels/Current/lispbm/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1 -x c src/eval_cps.c +
+ + + +
+ + +
+ + + + +
+

src/eval_cps.c

+
→
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1/*
2 Copyright 2018, 2020 - 2024 Joel Svensson svenssonjoel@yahoo.se
3
4 This program is free software: you can redistribute it and/or modify
5 it under the terms of the GNU General Public License as published by
6 the Free Software Foundation, either version 3 of the License, or
7 (at your option) any later version.
8
9 This program is distributed in the hope that it will be useful,
10 but WITHOUT ANY WARRANTY; without even the implied warranty of
11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 GNU General Public License for more details.
13
14 You should have received a copy of the GNU General Public License
15 along with this program. If not, see <http://www.gnu.org/licenses/>.
16*/
17
18#include <lbm_memory.h>
19#include <lbm_types.h>
20#include "symrepr.h"
21#include "heap.h"
22#include "env.h"
23#include "eval_cps.h"
24#include "stack.h"
25#include "fundamental.h"
26#include "extensions.h"
27#include "tokpar.h"
28#include "lbm_channel.h"
29#include "print.h"
30#include "platform_mutex.h"
31#include "lbm_flat_value.h"
32#include "lbm_flags.h"
33
34#ifdef VISUALIZE_HEAP
35#include "heap_vis.h"
36#endif
37
38#include <setjmp.h>
39#include <stdarg.h>
40
41static jmp_buf error_jmp_buf;
42static jmp_buf critical_error_jmp_buf;
43
44#define S_TO_US(X)(lbm_uint)((X) * 1000000) (lbm_uint)((X) * 1000000)
45
46#define DEC_CONTINUATION(x)(((x) & ~0xF8000001u) >> 2) (((x) & ~LBM_CONTINUATION_INTERNAL0xF8000001u) >> LBM_ADDRESS_SHIFT2)
47#define IS_CONTINUATION(x)(((x) & 0xF8000001u) == 0xF8000001u) (((x) & LBM_CONTINUATION_INTERNAL0xF8000001u) == LBM_CONTINUATION_INTERNAL0xF8000001u)
48#define CONTINUATION(x)(((x) << 2) | 0xF8000001u) (((x) << LBM_ADDRESS_SHIFT2) | LBM_CONTINUATION_INTERNAL0xF8000001u)
49
50#define DONE(((0) << 2) | 0xF8000001u) CONTINUATION(0)(((0) << 2) | 0xF8000001u)
51#define SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u) CONTINUATION(1)(((1) << 2) | 0xF8000001u)
52#define BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u) CONTINUATION(2)(((2) << 2) | 0xF8000001u)
53#define IF(((3) << 2) | 0xF8000001u) CONTINUATION(3)(((3) << 2) | 0xF8000001u)
54#define PROGN_REST(((4) << 2) | 0xF8000001u) CONTINUATION(4)(((4) << 2) | 0xF8000001u)
55#define APPLICATION_ARGS(((5) << 2) | 0xF8000001u) CONTINUATION(5)(((5) << 2) | 0xF8000001u)
56#define AND(((6) << 2) | 0xF8000001u) CONTINUATION(6)(((6) << 2) | 0xF8000001u)
57#define OR(((7) << 2) | 0xF8000001u) CONTINUATION(7)(((7) << 2) | 0xF8000001u)
58#define WAIT(((8) << 2) | 0xF8000001u) CONTINUATION(8)(((8) << 2) | 0xF8000001u)
59#define MATCH(((9) << 2) | 0xF8000001u) CONTINUATION(9)(((9) << 2) | 0xF8000001u)
60#define APPLICATION_START(((10) << 2) | 0xF8000001u) CONTINUATION(10)(((10) << 2) | 0xF8000001u)
61#define EVAL_R(((11) << 2) | 0xF8000001u) CONTINUATION(11)(((11) << 2) | 0xF8000001u)
62#define RESUME(((12) << 2) | 0xF8000001u) CONTINUATION(12)(((12) << 2) | 0xF8000001u)
63#define CLOSURE_ARGS(((13) << 2) | 0xF8000001u) CONTINUATION(13)(((13) << 2) | 0xF8000001u)
64#define EXIT_ATOMIC(((14) << 2) | 0xF8000001u) CONTINUATION(14)(((14) << 2) | 0xF8000001u)
65#define READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u) CONTINUATION(15)(((15) << 2) | 0xF8000001u)
66#define READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u) CONTINUATION(16)(((16) << 2) | 0xF8000001u)
67#define READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u) CONTINUATION(17)(((17) << 2) | 0xF8000001u)
68#define READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u) CONTINUATION(18)(((18) << 2) | 0xF8000001u)
69#define READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u) CONTINUATION(19)(((19) << 2) | 0xF8000001u)
70#define READ_DONE(((20) << 2) | 0xF8000001u) CONTINUATION(20)(((20) << 2) | 0xF8000001u)
71#define READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u) CONTINUATION(21)(((21) << 2) | 0xF8000001u)
72#define READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u) CONTINUATION(22)(((22) << 2) | 0xF8000001u)
73#define READ_COMMA_RESULT(((23) << 2) | 0xF8000001u) CONTINUATION(23)(((23) << 2) | 0xF8000001u)
74#define READ_START_ARRAY(((24) << 2) | 0xF8000001u) CONTINUATION(24)(((24) << 2) | 0xF8000001u)
75#define READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u) CONTINUATION(25)(((25) << 2) | 0xF8000001u)
76#define MAP(((26) << 2) | 0xF8000001u) CONTINUATION(26)(((26) << 2) | 0xF8000001u)
77#define MATCH_GUARD(((27) << 2) | 0xF8000001u) CONTINUATION(27)(((27) << 2) | 0xF8000001u)
78#define TERMINATE(((28) << 2) | 0xF8000001u) CONTINUATION(28)(((28) << 2) | 0xF8000001u)
79#define PROGN_VAR(((29) << 2) | 0xF8000001u) CONTINUATION(29)(((29) << 2) | 0xF8000001u)
80#define SETQ(((30) << 2) | 0xF8000001u) CONTINUATION(30)(((30) << 2) | 0xF8000001u)
81#define MOVE_TO_FLASH(((31) << 2) | 0xF8000001u) CONTINUATION(31)(((31) << 2) | 0xF8000001u)
82#define MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u) CONTINUATION(32)(((32) << 2) | 0xF8000001u)
83#define MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u) CONTINUATION(33)(((33) << 2) | 0xF8000001u)
84#define CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u) CONTINUATION(34)(((34) << 2) | 0xF8000001u)
85#define QQ_EXPAND_START(((35) << 2) | 0xF8000001u) CONTINUATION(35)(((35) << 2) | 0xF8000001u)
86#define QQ_EXPAND(((36) << 2) | 0xF8000001u) CONTINUATION(36)(((36) << 2) | 0xF8000001u)
87#define QQ_APPEND(((37) << 2) | 0xF8000001u) CONTINUATION(37)(((37) << 2) | 0xF8000001u)
88#define QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u) CONTINUATION(38)(((38) << 2) | 0xF8000001u)
89#define QQ_LIST(((39) << 2) | 0xF8000001u) CONTINUATION(39)(((39) << 2) | 0xF8000001u)
90#define KILL(((40) << 2) | 0xF8000001u) CONTINUATION(40)(((40) << 2) | 0xF8000001u)
91#define LOOP(((41) << 2) | 0xF8000001u) CONTINUATION(41)(((41) << 2) | 0xF8000001u)
92#define LOOP_CONDITION(((42) << 2) | 0xF8000001u) CONTINUATION(42)(((42) << 2) | 0xF8000001u)
93#define MERGE_REST(((43) << 2) | 0xF8000001u) CONTINUATION(43)(((43) << 2) | 0xF8000001u)
94#define MERGE_LAYER(((44) << 2) | 0xF8000001u) CONTINUATION(44)(((44) << 2) | 0xF8000001u)
95#define CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u) CONTINUATION(45)(((45) << 2) | 0xF8000001u)
96#define MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u) CONTINUATION(46)(((46) << 2) | 0xF8000001u)
97#define POP_READER_FLAGS(((47) << 2) | 0xF8000001u) CONTINUATION(47)(((47) << 2) | 0xF8000001u)
98#define EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u) CONTINUATION(48)(((48) << 2) | 0xF8000001u)
99#define NUM_CONTINUATIONS49 49
100
101#define FM_NEED_GC-1 -1
102#define FM_NO_MATCH-2 -2
103#define FM_PATTERN_ERROR-3 -3
104
105typedef enum {
106 BL_OK = 0,
107 BL_NO_MEMORY,
108 BL_INCORRECT_KEY
109} binding_location_status;
110
111#define FB_OK0 0
112#define FB_TYPE_ERROR-1 -1
113
114const char* lbm_error_str_parse_eof = "End of parse stream.";
115const char* lbm_error_str_parse_dot = "Incorrect usage of '.'.";
116const char* lbm_error_str_parse_close = "Expected closing parenthesis.";
117const char* lbm_error_str_num_args = "Incorrect number of arguments.";
118const char* lbm_error_str_forbidden_in_atomic = "Operation is forbidden in an atomic block.";
119const char* lbm_error_str_no_number = "Argument(s) must be a number.";
120const char* lbm_error_str_not_a_boolean = "Argument must be t or nil (true or false).";
121const char* lbm_error_str_incorrect_arg = "Incorrect argument.";
122const char* lbm_error_str_var_outside_progn = "Usage of var outside of progn.";
123const char* lbm_error_str_flash_not_possible = "Value cannot be written to flash.";
124const char* lbm_error_str_flash_error = "Error writing to flash.";
125const char* lbm_error_str_flash_full = "Flash memory is full.";
126const char* lbm_error_str_variable_not_bound = "Variable not bound.";
127
128static lbm_value lbm_error_suspect;
129static bool_Bool lbm_error_has_suspect = false0;
130#ifdef LBM_ALWAYS_GC
131
132#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
133 gc(); \
134 (y) = (x); \
135 if (lbm_is_symbol_merror((y))) { \
136 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
137 }
138
139#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
140 lbm_gc_mark_phase(r); \
141 gc(); \
142 (y) = (x); \
143 if (lbm_is_symbol_merror((y))) { \
144 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
145 }
146
147#else
148
149#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
150 (y) = (x); \
151 if (lbm_is_symbol_merror((y))) { \
152 gc(); \
153 (y) = (x); \
154 if (lbm_is_symbol_merror((y))) { \
155 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
156 } \
157 /* continue executing statements below */ \
158 }
159#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
160 (y) = (x); \
161 if (lbm_is_symbol_merror((y))) { \
162 lbm_gc_mark_phase(r); \
163 gc(); \
164 (y) = (x); \
165 if (lbm_is_symbol_merror((y))) { \
166 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
167 } \
168 /* continue executing statements below */ \
169 }
170
171#endif
172
173typedef struct {
174 eval_context_t *first;
175 eval_context_t *last;
176} eval_context_queue_t;
177
178#ifdef CLEAN_UP_CLOSURES
179static lbm_value clean_cl_env_symbol = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
180#endif
181
182static int gc(void);
183static void error_ctx(lbm_value);
184static void error_at_ctx(lbm_value err_val, lbm_value at);
185static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx);
186static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail);
187
188// The currently executing context.
189eval_context_t *ctx_running = NULL((void*)0);
190volatile bool_Bool lbm_system_sleeping = false0;
191
192static volatile bool_Bool gc_requested = false0;
193void lbm_request_gc(void) {
194 gc_requested = true1;
195}
196
197/*
198 On ChibiOs the CH_CFG_ST_FREQUENCY setting in chconf.h sets the
199 resolution of the timer used for sleep operations. If this is set
200 to 10KHz the resolution is 100us.
201
202 The CH_CFG_ST_TIMEDELTA specifies the minimum number of ticks that
203 can be safely specified in a timeout directive (wonder if that
204 means sleep-period). The timedelta is set to 2.
205
206 If I have understood these correctly it means that the minimum
207 sleep duration possible is 2 * 100us = 200us.
208*/
209
210#define EVAL_CPS_DEFAULT_STACK_SIZE256 256
211#define EVAL_CPS_MIN_SLEEP200 200
212#define EVAL_STEPS_QUOTA10 10
213
214static volatile uint32_t eval_steps_refill = EVAL_STEPS_QUOTA10;
215static uint32_t eval_steps_quota = EVAL_STEPS_QUOTA10;
216
217void lbm_set_eval_step_quota(uint32_t quota) {
218 eval_steps_refill = quota;
219}
220
221static uint32_t eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
222static volatile uint32_t eval_cps_next_state = EVAL_CPS_STATE_NONE0;
223static volatile uint32_t eval_cps_next_state_arg = 0;
224static volatile bool_Bool eval_cps_state_changed = false0;
225
226static void usleep_nonsense(uint32_t us) {
227 (void) us;
228}
229
230static bool_Bool dynamic_load_nonsense(const char *sym, const char **code) {
231 (void) sym;
232 (void) code;
233 return false0;
234}
235
236static uint32_t timestamp_nonsense(void) {
237 return 0;
238}
239
240static int printf_nonsense(const char *fmt, ...) {
241 (void) fmt;
242 return 0;
243}
244
245static void ctx_done_nonsense(eval_context_t *ctx) {
246 (void) ctx;
247}
248
249static void critical_nonsense(void) {
250 return;
251}
252
253static void (*critical_error_callback)(void) = critical_nonsense;
254static void (*usleep_callback)(uint32_t) = usleep_nonsense;
255static uint32_t (*timestamp_us_callback)(void) = timestamp_nonsense;
256static void (*ctx_done_callback)(eval_context_t *) = ctx_done_nonsense;
257static int (*printf_callback)(const char *, ...) = printf_nonsense;
258static bool_Bool (*dynamic_load_callback)(const char *, const char **) = dynamic_load_nonsense;
259
260void lbm_set_critical_error_callback(void (*fptr)(void)) {
261 if (fptr == NULL((void*)0)) critical_error_callback = critical_nonsense;
262 else critical_error_callback = fptr;
263}
264
265void lbm_set_usleep_callback(void (*fptr)(uint32_t)) {
266 if (fptr == NULL((void*)0)) usleep_callback = usleep_nonsense;
267 else usleep_callback = fptr;
268}
269
270void lbm_set_timestamp_us_callback(uint32_t (*fptr)(void)) {
271 if (fptr == NULL((void*)0)) timestamp_us_callback = timestamp_nonsense;
272 else timestamp_us_callback = fptr;
273}
274
275void lbm_set_ctx_done_callback(void (*fptr)(eval_context_t *)) {
276 if (fptr == NULL((void*)0)) ctx_done_callback = ctx_done_nonsense;
277 else ctx_done_callback = fptr;
278}
279
280void lbm_set_printf_callback(int (*fptr)(const char*, ...)){
281 if (fptr == NULL((void*)0)) printf_callback = printf_nonsense;
282 else printf_callback = fptr;
283}
284
285void lbm_set_dynamic_load_callback(bool_Bool (*fptr)(const char *, const char **)) {
286 if (fptr == NULL((void*)0)) dynamic_load_callback = dynamic_load_nonsense;
287 else dynamic_load_callback = fptr;
288}
289
290static volatile lbm_event_t *lbm_events = NULL((void*)0);
291static unsigned int lbm_events_head = 0;
292static unsigned int lbm_events_tail = 0;
293static unsigned int lbm_events_max = 0;
294static bool_Bool lbm_events_full = false0;
295static mutex_t lbm_events_mutex;
296static bool_Bool lbm_events_mutex_initialized = false0;
297static volatile lbm_cid lbm_event_handler_pid = -1;
298
299lbm_cid lbm_get_event_handler_pid(void) {
300 return lbm_event_handler_pid;
301}
302
303void lbm_set_event_handler_pid(lbm_cid pid) {
304 lbm_event_handler_pid = pid;
305}
306
307bool_Bool lbm_event_handler_exists(void) {
308 return(lbm_event_handler_pid > 0);
309}
310
311
312static bool_Bool event_internal(lbm_event_type_t event_type, lbm_uint parameter, lbm_uint buf_ptr, lbm_uint buf_len) {
313 bool_Bool r = false0;
314 if (lbm_events) {
315 mutex_lock(&lbm_events_mutex);
316 if (!lbm_events_full) {
317 lbm_event_t event;
318 event.type = event_type;
319 event.parameter = parameter;
320 event.buf_ptr = buf_ptr;
321 event.buf_len = buf_len;
322 lbm_events[lbm_events_head] = event;
323 lbm_events_head = (lbm_events_head + 1) % lbm_events_max;
324 lbm_events_full = lbm_events_head == lbm_events_tail;
325 r = true1;
326 }
327 mutex_unlock(&lbm_events_mutex);
328 }
329 return r;
330}
331
332bool_Bool lbm_event_define(lbm_value key, lbm_flat_value_t *fv) {
333 return event_internal(LBM_EVENT_DEFINE, key, (lbm_uint)fv->buf, fv->buf_size);
334}
335
336bool_Bool lbm_event_unboxed(lbm_value unboxed) {
337 lbm_uint t = lbm_type_of(unboxed);
338 if (t == LBM_TYPE_SYMBOL0x00000000u ||
339 t == LBM_TYPE_I0x00000008u ||
340 t == LBM_TYPE_U0x0000000Cu ||
341 t == LBM_TYPE_CHAR0x00000004u) {
342 if (lbm_event_handler_pid > 0) {
343 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)unboxed, 0);
344 }
345 }
346 return false0;
347}
348
349bool_Bool lbm_event(lbm_flat_value_t *fv) {
350 if (lbm_event_handler_pid > 0) {
351 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)fv->buf, fv->buf_size);
352 }
353 return false0;
354}
355
356static bool_Bool lbm_event_pop(lbm_event_t *event) {
357 mutex_lock(&lbm_events_mutex);
358 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
359 mutex_unlock(&lbm_events_mutex);
360 return false0;
361 }
362 *event = lbm_events[lbm_events_tail];
363 lbm_events_tail = (lbm_events_tail + 1) % lbm_events_max;
364 lbm_events_full = false0;
365 mutex_unlock(&lbm_events_mutex);
366 return true1;
367}
368
369bool_Bool lbm_event_queue_is_empty(void) {
370 mutex_lock(&lbm_events_mutex);
371 bool_Bool empty = false0;
372 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
373 empty = true1;
374 }
375 mutex_unlock(&lbm_events_mutex);
376 return empty;
377}
378
379static bool_Bool eval_running = false0;
380static volatile bool_Bool blocking_extension = false0;
381static mutex_t blocking_extension_mutex;
382static bool_Bool blocking_extension_mutex_initialized = false0;
383static lbm_uint blocking_extension_timeout_us = 0;
384static bool_Bool blocking_extension_timeout = false0;
385
386static uint32_t is_atomic = 0;
387
388/* Process queues */
389static eval_context_queue_t blocked = {NULL((void*)0), NULL((void*)0)};
390static eval_context_queue_t queue = {NULL((void*)0), NULL((void*)0)};
391
392/* one mutex for all queue operations */
393mutex_t qmutex;
394bool_Bool qmutex_initialized = false0;
395
396
397// MODES
398static volatile bool_Bool lbm_verbose = false0;
399
400void lbm_toggle_verbose(void) {
401 lbm_verbose = !lbm_verbose;
402}
403
404void lbm_set_verbose(bool_Bool verbose) {
405 lbm_verbose = verbose;
406}
407
408lbm_cid lbm_get_current_cid(void) {
409 if (ctx_running)
410 return ctx_running->id;
411 else
412 return -1;
413}
414
415eval_context_t *lbm_get_current_context(void) {
416 return ctx_running;
417}
418
419/****************************************************/
420/* Utilities used locally in this file */
421
422static lbm_value cons_with_gc(lbm_value head, lbm_value tail, lbm_value remember) {
423#ifdef LBM_ALWAYS_GC
424 lbm_value roots[3] = {head, tail, remember};
425 lbm_gc_mark_roots(roots, 3);
426 gc();
427 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
428 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
429 if (lbm_is_symbol_merror(res)) {
430 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
431 }
432 return res;
433#else
434 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
435 if (lbm_is_symbol_merror(res)) {
436 lbm_value roots[3] = {head, tail, remember};
437 lbm_gc_mark_roots(roots,3);
438 gc();
439 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
440 if (lbm_is_symbol_merror(res)) {
441 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
442 }
443 }
444 return res;
445#endif
446}
447
448static lbm_uint *get_stack_ptr(eval_context_t *ctx, unsigned int n) {
449 if (n <= ctx->K.sp) {
450 lbm_uint index = ctx->K.sp - n;
451 return &ctx->K.data[index];
452 }
453 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
454 return 0; // dead code cannot be reached, but C compiler doesn't realise.
455}
456
457// pop_stack_ptr is safe when no GC is performed and
458// the values of the stack will be dropped.
459static lbm_uint *pop_stack_ptr(eval_context_t *ctx, unsigned int n) {
460 if (n <= ctx->K.sp) {
461 ctx->K.sp -= n;
462 return &ctx->K.data[ctx->K.sp];
463 }
464 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
465 return 0; // dead code cannot be reached, but C compiler doesn't realise.
466}
467
468static inline lbm_uint *stack_reserve(eval_context_t *ctx, unsigned int n) {
469 if (ctx->K.sp + n < ctx->K.size) {
470 lbm_uint *ptr = &ctx->K.data[ctx->K.sp];
471 ctx->K.sp += n;
472 return ptr;
473 }
474 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
475 return 0; // dead code cannot be reached, but C compiler doesn't realise.
476}
477
478static void handle_flash_status(lbm_flash_status s) {
479 if ( s == LBM_FLASH_FULL) {
480 lbm_set_error_reason((char*)lbm_error_str_flash_full);
481 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
482 }
483 if (s == LBM_FLASH_WRITE_ERROR) {
484 lbm_set_error_reason((char*)lbm_error_str_flash_error);
485 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
486 }
487}
488
489static void lift_array_flash(lbm_value flash_cell, bool_Bool bytearray, char *data, lbm_uint num_elt) {
490
491 lbm_array_header_t flash_array_header;
492 flash_array_header.size = num_elt;
493 flash_array_header.data = (lbm_uint*)data;
494 lbm_uint flash_array_header_ptr;
495 handle_flash_status(lbm_write_const_raw((lbm_uint*)&flash_array_header,
496 sizeof(lbm_array_header_t) / sizeof(lbm_uint),
497 &flash_array_header_ptr));
498 handle_flash_status(write_const_car(flash_cell, flash_array_header_ptr));
499 lbm_uint t = bytearray ? ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u) : ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u);
500 handle_flash_status(write_const_cdr(flash_cell, t));
501}
502
503static void get_car_and_cdr(lbm_value a, lbm_value *a_car, lbm_value *a_cdr) {
504 if (lbm_is_ptr(a)) {
505 lbm_cons_t *cell = lbm_ref_cell(a);
506 *a_car = cell->car;
507 *a_cdr = cell->cdr;
508 } else if (lbm_is_symbol_nil(a)) {
509 *a_car = *a_cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
510 } else {
511 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
512 }
513}
514
515/* car cdr caar cadr replacements that are evaluator safe. */
516static lbm_value get_car(lbm_value a) {
517 if (lbm_is_ptr(a)) {
6
←
Assuming the condition is false
→
7
←
Taking false branch
→
518 lbm_cons_t *cell = lbm_ref_cell(a);
519 return cell->car;
520 } else if (lbm_is_symbol_nil(a)) {
8
←
Calling 'lbm_is_symbol_nil'
→
11
←
Returning from 'lbm_is_symbol_nil'
→
12
←
Taking true branch
→
521 return a;
13
←
Returning zero (loaded from 'a')
→
522 }
523 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
524 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
525}
526
527static lbm_value get_cdr(lbm_value a) {
528 if (lbm_is_ptr(a)) {
529 lbm_cons_t *cell = lbm_ref_cell(a);
530 return cell->cdr;
531 } else if (lbm_is_symbol_nil(a)) {
532 return a;
533 }
534 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
535 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
536}
537
538static lbm_value get_cadr(lbm_value a) {
539 if (lbm_is_ptr(a)) {
540 lbm_cons_t *cell = lbm_ref_cell(a);
541 lbm_value tmp = cell->cdr;
542 if (lbm_is_ptr(tmp)) {
543 return lbm_ref_cell(tmp)->car;
544 } else if (lbm_is_symbol_nil(tmp)) {
545 return tmp;
546 }
547 } else if (lbm_is_symbol_nil(a)) {
548 return a;
549 }
550 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
551 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
552}
553
554static lbm_value allocate_closure(lbm_value params, lbm_value body, lbm_value env) {
555
556#ifdef LBM_ALWAYS_GC
557 gc();
558 if (lbm_heap_num_free() < 4) {
559 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
560 }
561#else
562 if (lbm_heap_num_free() < 4) {
563 gc();
564 if (lbm_heap_num_free() < 4) {
565 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
566 }
567 }
568#endif
569 // The freelist will always contain just plain heap-cells.
570 // So dec_ptr is sufficient.
571 lbm_value res = lbm_heap_state.freelist;
572 if (lbm_type_of(res) == LBM_TYPE_CONS0x10000000u) {
573 lbm_cons_t *heap = lbm_heap_state.heap;
574 lbm_uint ix = lbm_dec_ptr(res);
575 heap[ix].car = ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u);
576 ix = lbm_dec_ptr(heap[ix].cdr);
577 heap[ix].car = params;
578 ix = lbm_dec_ptr(heap[ix].cdr);
579 heap[ix].car = body;
580 ix = lbm_dec_ptr(heap[ix].cdr);
581 heap[ix].car = env;
582 lbm_heap_state.freelist = heap[ix].cdr;
583 heap[ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
584 lbm_heap_state.num_alloc+=4;
585 } else {
586 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
587 }
588 return res;
589}
590
591// Allocate a binding and attach it to a list (if so desired)
592static lbm_value allocate_binding(lbm_value key, lbm_value val, lbm_value the_cdr) {
593 if (lbm_heap_num_free() < 2) {
594 gc();
595 if (lbm_heap_num_free() < 2) {
596 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
597 }
598 }
599 lbm_cons_t* heap = lbm_heap_state.heap;
600 lbm_value binding_cell = lbm_heap_state.freelist;
601 lbm_uint binding_cell_ix = lbm_dec_ptr(binding_cell);
602 lbm_value list_cell = heap[binding_cell_ix].cdr;
603 lbm_uint list_cell_ix = lbm_dec_ptr(list_cell);
604 lbm_heap_state.freelist = heap[list_cell_ix].cdr;
605 lbm_heap_state.num_alloc += 2;
606 heap[binding_cell_ix].car = key;
607 heap[binding_cell_ix].cdr = val;
608 heap[list_cell_ix].car = binding_cell;
609 heap[list_cell_ix].cdr = the_cdr;
610 return list_cell;
611}
612
613#define CLO_PARAMS0 0
614#define CLO_BODY1 1
615#define CLO_ENV2 2
616#define LOOP_BINDS0 0
617#define LOOP_COND1 1
618#define LOOP_BODY2 2
619
620// (a b c) -> [a b c]
621static lbm_value extract_n(lbm_value curr, lbm_value *res, unsigned int n) {
622 for (unsigned int i = 0; i < n; i ++) {
623 if (lbm_is_ptr(curr)) {
624 lbm_cons_t *cell = lbm_ref_cell(curr);
625 res[i] = cell->car;
626 curr = cell->cdr;
627 } else {
628 res[i] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
629 }
630 }
631 return curr; // Rest of list is returned here.
632}
633
634static void call_fundamental(lbm_uint fundamental, lbm_value *args, lbm_uint arg_count, eval_context_t *ctx) {
635 lbm_value res;
636 res = fundamental_table[fundamental](args, arg_count, ctx);
637 if (lbm_is_error(res)) {
638 if (lbm_is_symbol_merror(res)) {
639 gc();
640 res = fundamental_table[fundamental](args, arg_count, ctx);
641 }
642 if (lbm_is_error(res)) {
643 error_at_ctx(res, lbm_enc_sym(FUNDAMENTAL_SYMBOLS_START0x20000 | fundamental));
644 }
645 }
646 lbm_stack_drop(&ctx->K, arg_count+1);
647 ctx->app_cont = true1;
648 ctx->r = res;
649}
650
651// block_current_ctx blocks a context until it is
652// woken up externally or a timeout period of time passes.
653static void block_current_ctx(uint32_t state, lbm_uint sleep_us, bool_Bool do_cont) {
654 ctx_running->timestamp = timestamp_us_callback();
655 ctx_running->sleep_us = sleep_us;
656 ctx_running->state = state;
657 ctx_running->app_cont = do_cont;
658 enqueue_ctx(&blocked, ctx_running);
659 ctx_running = NULL((void*)0);
660}
661
662lbm_flash_status lbm_write_const_array_padded(uint8_t *data, lbm_uint n, lbm_uint *res) {
663 lbm_uint full_words = n / sizeof(lbm_uint);
664 lbm_uint n_mod = n % sizeof(lbm_uint);
665
666 if (n_mod == 0) { // perfect fit.
667 return lbm_write_const_raw((lbm_uint*)data, full_words, res);
668 } else {
669 lbm_uint last_word = 0;
670 memcpy(&last_word, &data[full_words * sizeof(lbm_uint)], n_mod);
671 if (full_words >= 1) {
672 lbm_flash_status s = lbm_write_const_raw((lbm_uint*)data, full_words, res);
673 if ( s == LBM_FLASH_WRITE_OK) {
674 lbm_uint dummy;
675 s = lbm_write_const_raw(&last_word, 1, &dummy);
676 }
677 return s;
678 } else {
679 return lbm_write_const_raw(&last_word, 1, res);
680 }
681 }
682}
683
684/****************************************************/
685/* Error message creation */
686
687#define ERROR_MESSAGE_BUFFER_SIZE_BYTES256 256
688
689void print_environments(char *buf, unsigned int size) {
690
691 lbm_value curr_l = ctx_running->curr_env;
692 printf_callback("\tCurrent local environment:\n");
693 while (lbm_type_of(curr_l) == LBM_TYPE_CONS0x10000000u) {
694 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_l));
695 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_l)));
696 printf_callback("\t%s = %s\n", buf, buf+(size/2));
697 curr_l = lbm_cdr(curr_l);
698 }
699 printf_callback("\n\n");
700 printf_callback("\tCurrent global environment:\n");
701 lbm_value *glob_env = lbm_get_global_env();
702
703 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
704 lbm_value curr_g = glob_env[i];;
705 while (lbm_type_of(curr_g) == LBM_TYPE_CONS0x10000000u) {
706
707 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_g));
708 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_g)));
709 printf_callback("\t%s = %s\n", buf, buf+(size/2));
710 curr_g = lbm_cdr(curr_g);
711 }
712 }
713}
714
715void print_error_message(lbm_value error, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int col, lbm_int row0, lbm_int row1) {
716 if (!printf_callback) return;
717
718 /* try to allocate a lbm_print_value buffer on the lbm_memory */
719 char *buf = lbm_malloc_reserve(ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
720 if (!buf) {
721 printf_callback("Error: Not enough free memory to create a human readable error message\n");
722 return;
723 }
724
725 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, error);
726 printf_callback( "*** Error: %s\n", buf);
727 if (has_at) {
728 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, at);
729 printf_callback("*** In: %s\n",buf);
730 if (lbm_error_has_suspect) {
731 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, lbm_error_suspect);
732 lbm_error_has_suspect = false0;
733 printf_callback("*** At: %s\n", buf);
734 } else {
735 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
736 printf_callback("*** After: %s\n",buf);
737 }
738 } else {
739 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
740 printf_callback("*** Near: %s\n",buf);
741 }
742
743 printf_callback("\n");
744
745 if (lbm_is_symbol(error) &&
746 error == ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u)) {
747 printf_callback("*** Line: %u\n", row);
748 printf_callback("*** Column: %u\n", col);
749 } else if (row0 != -1 || row1 != -1 ) {
750 printf_callback("*** Between rows: (-1 unknown) \n");
751 printf_callback("*** Start: %d\n", (int32_t)row0);
752 printf_callback("*** End: %d\n", (int32_t)row1);
753 }
754
755 printf_callback("\n");
756
757 if (ctx_running->error_reason) {
758 printf_callback("Reason:\n %s\n\n", ctx_running->error_reason);
759 }
760 if (lbm_verbose) {
761 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
762 printf_callback(" In context: %d\n", ctx_running->id);
763 printf_callback(" Current intermediate result: %s\n\n", buf);
764
765 print_environments(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
766 printf_callback("\n\n");
767
768 printf_callback(" Stack:\n");
769 for (unsigned int i = 0; i < ctx_running->K.sp; i ++) {
770 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->K.data[i]);
771 printf_callback(" %s\n", buf);
772 }
773 }
774 lbm_free(buf);
775}
776
777/****************************************************/
778/* Tokenizing and parsing */
779
780bool_Bool create_string_channel(char *str, lbm_value *res) {
781
782 lbm_char_channel_t *chan = NULL((void*)0);
783 lbm_string_channel_state_t *st = NULL((void*)0);
784
785 st = (lbm_string_channel_state_t*)lbm_memory_allocate(sizeof(lbm_string_channel_state_t) / sizeof(lbm_uint) +1);
786 if (st == NULL((void*)0)) {
787 return false0;
788 }
789 chan = (lbm_char_channel_t*)lbm_memory_allocate(sizeof(lbm_char_channel_t) / sizeof(lbm_uint) + 1);
790 if (chan == NULL((void*)0)) {
791 lbm_memory_free((lbm_uint*)st);
792 return false0;
793 }
794
795 lbm_create_string_char_channel(st, chan, str);
796 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
797 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
798 lbm_memory_free((lbm_uint*)st);
799 lbm_memory_free((lbm_uint*)chan);
800 return false0;
801 }
802
803 *res = cell;
804 return true1;
805}
806
807bool_Bool lift_char_channel(lbm_char_channel_t *chan , lbm_value *res) {
808 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
809 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
810 return false0;
811 }
812 *res = cell;
813 return true1;
814}
815
816
817/****************************************************/
818/* Queue functions */
819
820static void queue_iterator_nm(eval_context_queue_t *q, ctx_fun f, void *arg1, void *arg2) {
821 eval_context_t *curr;
822 curr = q->first;
823
824 while (curr != NULL((void*)0)) {
825 f(curr, arg1, arg2);
826 curr = curr->next;
827 }
828}
829
830void lbm_running_iterator(ctx_fun f, void *arg1, void *arg2){
831 mutex_lock(&qmutex);
832 queue_iterator_nm(&queue, f, arg1, arg2);
833 mutex_unlock(&qmutex);
834}
835
836void lbm_blocked_iterator(ctx_fun f, void *arg1, void *arg2){
837 mutex_lock(&qmutex);
838 queue_iterator_nm(&blocked, f, arg1, arg2);
839 mutex_unlock(&qmutex);
840}
841
842static void enqueue_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
843 if (q->last == NULL((void*)0)) {
844 ctx->prev = NULL((void*)0);
845 ctx->next = NULL((void*)0);
846 q->first = ctx;
847 q->last = ctx;
848 } else {
849 ctx->prev = q->last;
850 ctx->next = NULL((void*)0);
851 q->last->next = ctx;
852 q->last = ctx;
853 }
854}
855
856static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx) {
857 mutex_lock(&qmutex);
858 enqueue_ctx_nm(q,ctx);
859 mutex_unlock(&qmutex);
860}
861
862static eval_context_t *lookup_ctx_nm(eval_context_queue_t *q, lbm_cid cid) {
863 eval_context_t *curr;
864 curr = q->first;
865 while (curr != NULL((void*)0)) {
866 if (curr->id == cid) {
867 return curr;
868 }
869 curr = curr->next;
870 }
871 return NULL((void*)0);
872}
873
874static bool_Bool drop_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
875
876 bool_Bool res = false0;
877 if (q->first == NULL((void*)0) || q->last == NULL((void*)0)) {
878 if (!(q->last == NULL((void*)0) && q->first == NULL((void*)0))) {
879 /* error state that should not happen */
880 return res;
881 }
882 /* Queue is empty */
883 return res;
884 }
885
886 eval_context_t *curr = q->first;
887 while (curr) {
888 if (curr->id == ctx->id) {
889 res = true1;
890 eval_context_t *tmp = curr->next;
891 if (curr->prev == NULL((void*)0)) {
892 if (curr->next == NULL((void*)0)) {
893 q->last = NULL((void*)0);
894 q->first = NULL((void*)0);
895 } else {
896 q->first = tmp;
897 tmp->prev = NULL((void*)0);
898 }
899 } else { /* curr->prev != NULL */
900 if (curr->next == NULL((void*)0)) {
901 q->last = curr->prev;
902 q->last->next = NULL((void*)0);
903 } else {
904 curr->prev->next = tmp;
905 tmp->prev = curr->prev;
906 }
907 }
908 break;
909 }
910 curr = curr->next;
911 }
912 return res;
913}
914
915/* End execution of the running context. */
916static void finish_ctx(void) {
917
918 if (!ctx_running) {
919 return;
920 }
921 /* Drop the continuation stack immediately to free up lbm_memory */
922 lbm_stack_free(&ctx_running->K);
923 ctx_done_callback(ctx_running);
924 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->name)) {
925 lbm_free(ctx_running->name);
926 }
927 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->error_reason)) {
928 lbm_memory_free((lbm_uint*)ctx_running->error_reason);
929 }
930 lbm_memory_free((lbm_uint*)ctx_running->mailbox);
931 lbm_memory_free((lbm_uint*)ctx_running);
932 ctx_running = NULL((void*)0);
933}
934
935static void context_exists(eval_context_t *ctx, void *cid, void *b) {
936 if (ctx->id == *(lbm_cid*)cid) {
937 *(bool_Bool*)b = true1;
938 }
939}
940
941bool_Bool lbm_wait_ctx(lbm_cid cid, lbm_uint timeout_ms) {
942
943 bool_Bool exists;
944 uint32_t i = 0;
945
946 do {
947 exists = false0;
948 lbm_blocked_iterator(context_exists, &cid, &exists);
949 lbm_running_iterator(context_exists, &cid, &exists);
950
951 if (ctx_running &&
952 ctx_running->id == cid) {
953 exists = true1;
954 }
955
956 if (exists) {
957 if (usleep_callback) {
958 usleep_callback(1000);
959 }
960 if (timeout_ms > 0) i ++;
961 }
962 } while (exists && i < timeout_ms);
963
964 if (exists) return false0;
965 return true1;
966}
967
968void lbm_set_error_suspect(lbm_value suspect) {
969 lbm_error_suspect = suspect;
970 lbm_error_has_suspect = true1;
971}
972
973void lbm_set_error_reason(char *error_str) {
974 if (ctx_running != NULL((void*)0)) {
975 ctx_running->error_reason = error_str;
976 }
977}
978
979// Not possible to CONS_WITH_GC in error_ctx_base (potential loop)
980static void error_ctx_base(lbm_value err_val, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int column) {
981
982 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
983 if (lbm_heap_num_free() < 3) {
984 gc();
985 }
986
987 if (lbm_heap_num_free() >= 3) {
988 lbm_value msg = lbm_cons(err_val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
989 msg = lbm_cons(lbm_enc_i(ctx_running->id), msg);
990 msg = lbm_cons(ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u), msg);
991 if (!lbm_is_symbol_merror(msg)) {
992 lbm_find_receiver_and_send(ctx_running->parent, msg);
993 goto error_ctx_base_done;
994 }
995 }
996 }
997 if ((ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10) &&
998 (err_val != ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u))) {
999 lbm_uint v;
1000 while (ctx_running->K.sp > 0) {
1001 lbm_pop(&ctx_running->K, &v);
1002 if (v == EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u)) {
1003 lbm_value *sptr = get_stack_ptr(ctx_running, 2);
1004 lbm_set_car(sptr[0], ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
1005 stack_reserve(ctx_running, 1)[0] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1006 ctx_running->app_cont = true1;
1007 ctx_running->r = err_val;
1008 longjmp(error_jmp_buf, 1);
1009 }
1010 }
1011 err_val = ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u);
1012 }
1013 print_error_message(err_val,
1014 has_at,
1015 at,
1016 row,
1017 column,
1018 ctx_running->row0,
1019 ctx_running->row1);
1020 error_ctx_base_done:
1021 ctx_running->r = err_val;
1022 finish_ctx();
1023 longjmp(error_jmp_buf, 1);
1024}
1025
1026static void error_at_ctx(lbm_value err_val, lbm_value at) {
1027 error_ctx_base(err_val, true1, at, 0, 0);
1028}
1029
1030static void error_ctx(lbm_value err_val) {
1031 error_ctx_base(err_val, false0, 0, 0, 0);
1032}
1033
1034static void read_error_ctx(unsigned int row, unsigned int column) {
1035 error_ctx_base(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u), false0, 0, row, column);
1036}
1037
1038void lbm_critical_error(void) {
1039 longjmp(critical_error_jmp_buf, 1);
1040}
1041
1042// successfully finish a context
1043static void ok_ctx(void) {
1044 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
1045 lbm_value msg;
1046 WITH_GC(msg, lbm_heap_allocate_list_init(3,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1047 ENC_SYM_EXIT_OK,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1048 lbm_enc_i(ctx_running->id),(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1049 ctx_running->r))(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
1050 lbm_find_receiver_and_send(ctx_running->parent, msg);
1051 }
1052 finish_ctx();
1053}
1054
1055static eval_context_t *dequeue_ctx_nm(eval_context_queue_t *q) {
1056 if (q->last == NULL((void*)0)) {
1057 return NULL((void*)0);
1058 }
1059 // q->first should only be NULL if q->last is.
1060 eval_context_t *res = q->first;
1061
1062 if (q->first == q->last) { // One thing in queue
1063 q->first = NULL((void*)0);
1064 q->last = NULL((void*)0);
1065 } else {
1066 q->first = q->first->next;
1067 q->first->prev = NULL((void*)0);
1068 }
1069 res->prev = NULL((void*)0);
1070 res->next = NULL((void*)0);
1071 return res;
1072}
1073
1074static void wake_up_ctxs_nm(void) {
1075 lbm_uint t_now;
1076
1077 if (timestamp_us_callback) {
1078 t_now = timestamp_us_callback();
1079 } else {
1080 t_now = 0;
1081 }
1082
1083 eval_context_queue_t *q = &blocked;
1084 eval_context_t *curr = q->first;
1085
1086 while (curr != NULL((void*)0)) {
1087 lbm_uint t_diff;
1088 eval_context_t *next = curr->next;
1089 if (curr->state != LBM_THREAD_STATE_BLOCKED(uint32_t)1) {
1090 if ( curr->timestamp > t_now) {
1091 /* There was an overflow on the counter */
1092#ifndef LBM64
1093 t_diff = (0xFFFFFFFF - curr->timestamp) + t_now;
1094#else
1095 t_diff = (0xFFFFFFFFFFFFFFFF - curr->timestamp) + t_now;
1096#endif
1097 } else {
1098 t_diff = t_now - curr->timestamp;
1099 }
1100
1101 if (t_diff >= curr->sleep_us) {
1102 eval_context_t *wake_ctx = curr;
1103 if (curr == q->last) {
1104 if (curr->prev) {
1105 q->last = curr->prev;
1106 q->last->next = NULL((void*)0);
1107 } else {
1108 q->first = NULL((void*)0);
1109 q->last = NULL((void*)0);
1110 }
1111 } else if (curr->prev == NULL((void*)0)) {
1112 q->first = curr->next;
1113 q->first->prev = NULL((void*)0);
1114 } else {
1115 curr->prev->next = curr->next;
1116 if (curr->next) {
1117 curr->next->prev = curr->prev;
1118 }
1119 }
1120 wake_ctx->next = NULL((void*)0);
1121 wake_ctx->prev = NULL((void*)0);
1122 if (curr->state == LBM_THREAD_STATE_TIMEOUT(uint32_t)2) {
1123 mailbox_add_mail(wake_ctx, ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u));
1124 wake_ctx->r = ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u);
1125 }
1126 wake_ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1127 enqueue_ctx_nm(&queue, wake_ctx);
1128 }
1129 }
1130 curr = next;
1131 }
1132}
1133
1134static void yield_ctx(lbm_uint sleep_us) {
1135 if (timestamp_us_callback) {
1136 ctx_running->timestamp = timestamp_us_callback();
1137 ctx_running->sleep_us = sleep_us;
1138 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1139 } else {
1140 ctx_running->timestamp = 0;
1141 ctx_running->sleep_us = 0;
1142 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1143 }
1144 ctx_running->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1145 ctx_running->app_cont = true1;
1146 enqueue_ctx(&blocked,ctx_running);
1147 ctx_running = NULL((void*)0);
1148}
1149
1150static lbm_cid lbm_create_ctx_parent(lbm_value program, lbm_value env, lbm_uint stack_size, lbm_cid parent, uint32_t context_flags, char *name) {
1151
1152 if (!lbm_is_cons(program)) return -1;
1153
1154 eval_context_t *ctx = NULL((void*)0);
1155
1156 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1157 if (ctx == NULL((void*)0)) {
1158 lbm_uint roots[2] = {program, env};
1159 lbm_gc_mark_roots(roots, 2);
1160 gc();
1161 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1162 }
1163 if (ctx == NULL((void*)0)) return -1;
1164
1165 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1166 lbm_uint roots[2] = {program, env};
1167 lbm_gc_mark_roots(roots, 2);
1168 gc();
1169 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1170 lbm_memory_free((lbm_uint*)ctx);
1171 return -1;
1172 }
1173 }
1174
1175 lbm_value *mailbox = NULL((void*)0);
1176 mailbox = (lbm_value*)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1177 if (mailbox == NULL((void*)0)) {
1178 lbm_value roots[2] = {program, env};
1179 lbm_gc_mark_roots(roots,2);
1180 gc();
1181 mailbox = (lbm_value *)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1182 }
1183 if (mailbox == NULL((void*)0)) {
1184 lbm_stack_free(&ctx->K);
1185 lbm_memory_free((lbm_uint*)ctx);
1186 return -1;
1187 }
1188
1189 // TODO: Limit names to 19 chars + 1 char for 0? (or something similar).
1190 if (name) {
1191 lbm_uint name_len = strlen(name) + 1;
1192 ctx->name = lbm_malloc(strlen(name) + 1);
1193 if (ctx->name == NULL((void*)0)) {
1194 lbm_value roots[2] = {program, env};
1195 lbm_gc_mark_roots(roots, 2);
1196 gc();
1197 ctx->name = lbm_malloc(strlen(name) + 1);
1198 }
1199 if (ctx->name == NULL((void*)0)) {
1200 lbm_stack_free(&ctx->K);
1201 lbm_memory_free((lbm_uint*)mailbox);
1202 lbm_memory_free((lbm_uint*)ctx);
1203 return -1;
1204 }
1205 memcpy(ctx->name, name, name_len+1);
1206 } else {
1207 ctx->name = NULL((void*)0);
1208 }
1209
1210 lbm_int cid = lbm_memory_address_to_ix((lbm_uint*)ctx);
1211
1212 ctx->program = lbm_cdr(program);
1213 ctx->curr_exp = lbm_car(program);
1214 ctx->curr_env = env;
1215 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1216 ctx->error_reason = NULL((void*)0);
1217 ctx->mailbox = mailbox;
1218 ctx->mailbox_size = EVAL_CPS_DEFAULT_MAILBOX_SIZE10;
1219 ctx->flags = context_flags;
1220 ctx->num_mail = 0;
1221 ctx->app_cont = false0;
1222 ctx->timestamp = 0;
1223 ctx->sleep_us = 0;
1224 ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1225 ctx->prev = NULL((void*)0);
1226 ctx->next = NULL((void*)0);
1227
1228 ctx->row0 = -1;
1229 ctx->row1 = -1;
1230
1231 ctx->id = cid;
1232 ctx->parent = parent;
1233
1234 if (!lbm_push(&ctx->K, DONE(((0) << 2) | 0xF8000001u))) {
1235 lbm_memory_free((lbm_uint*)ctx->mailbox);
1236 lbm_stack_free(&ctx->K);
1237 lbm_memory_free((lbm_uint*)ctx);
1238 return -1;
1239 }
1240
1241 enqueue_ctx(&queue,ctx);
1242
1243 return ctx->id;
1244}
1245
1246lbm_cid lbm_create_ctx(lbm_value program, lbm_value env, lbm_uint stack_size, char *name) {
1247 // Creates a parentless context.
1248 return lbm_create_ctx_parent(program,
1249 env,
1250 stack_size,
1251 -1,
1252 EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00,
1253 name);
1254}
1255
1256bool_Bool lbm_mailbox_change_size(eval_context_t *ctx, lbm_uint new_size) {
1257
1258 lbm_value *mailbox = NULL((void*)0);
1259 mailbox = (lbm_value*)lbm_memory_allocate(new_size);
1260 if (mailbox == NULL((void*)0)) {
1261 gc();
1262 mailbox = (lbm_value *)lbm_memory_allocate(new_size);
1263 }
1264 if (mailbox == NULL((void*)0)) {
1265 return false0;
1266 }
1267
1268 for (lbm_uint i = 0; i < ctx->num_mail; i ++ ) {
1269 mailbox[i] = ctx->mailbox[i];
1270 }
1271 lbm_memory_free(ctx->mailbox);
1272 ctx->mailbox = mailbox;
1273 ctx->mailbox_size = (uint32_t)new_size;
1274 return true1;
1275}
1276
1277static void mailbox_remove_mail(eval_context_t *ctx, lbm_uint ix) {
1278
1279 for (lbm_uint i = ix; i < ctx->num_mail-1; i ++) {
1280 ctx->mailbox[i] = ctx->mailbox[i+1];
1281 }
1282 ctx->num_mail --;
1283}
1284
1285static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail) {
1286
1287 if (ctx->num_mail >= ctx->mailbox_size) {
1288 mailbox_remove_mail(ctx, 0);
1289 }
1290
1291 ctx->mailbox[ctx->num_mail] = mail;
1292 ctx->num_mail ++;
1293 return true1;
1294}
1295
1296/* Advance execution to the next expression in the program */
1297static void advance_ctx(eval_context_t *ctx) {
1298 if (lbm_is_cons(ctx->program)) {
1299 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);;
1300 get_car_and_cdr(ctx->program, &ctx->curr_exp, &ctx->program);
1301 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1302 } else {
1303 if (ctx_running == ctx) { // This should always be the case because of odd historical reasons.
1304 ok_ctx();
1305 }
1306 }
1307}
1308
1309bool_Bool lbm_unblock_ctx(lbm_cid cid, lbm_flat_value_t *fv) {
1310 return event_internal(LBM_EVENT_UNBLOCK_CTX, (lbm_uint)cid, (lbm_uint)fv->buf, fv->buf_size);
1311}
1312
1313bool_Bool lbm_unblock_ctx_r(lbm_cid cid) {
1314 mutex_lock(&blocking_extension_mutex);
1315 bool_Bool r = false0;
1316 eval_context_t *found = NULL((void*)0);
1317 mutex_lock(&qmutex);
1318 found = lookup_ctx_nm(&blocked, cid);
1319 if (found) {
1320 drop_ctx_nm(&blocked,found);
1321 enqueue_ctx_nm(&queue,found);
1322 r = true1;
1323 }
1324 mutex_unlock(&qmutex);
1325 mutex_unlock(&blocking_extension_mutex);
1326 return r;
1327}
1328
1329// unblock unboxed is also safe for rmbr:ed things.
1330bool_Bool lbm_unblock_ctx_unboxed(lbm_cid cid, lbm_value unboxed) {
1331 mutex_lock(&blocking_extension_mutex);
1332 bool_Bool r = false0;
1333 eval_context_t *found = NULL((void*)0);
1334 mutex_lock(&qmutex);
1335 found = lookup_ctx_nm(&blocked, cid);
1336 if (found) {
1337 drop_ctx_nm(&blocked,found);
1338 found->r = unboxed;
1339 if (lbm_is_error(unboxed)) {
1340 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
1341 found->app_cont = true1;
1342 }
1343 enqueue_ctx_nm(&queue,found);
1344 r = true1;
1345 }
1346 mutex_unlock(&qmutex);
1347 mutex_unlock(&blocking_extension_mutex);
1348 return r;
1349}
1350
1351static bool_Bool lbm_block_ctx_base(bool_Bool timeout, float t_s) {
1352 mutex_lock(&blocking_extension_mutex);
1353 blocking_extension = true1;
1354 if (timeout) {
1355 blocking_extension_timeout_us = S_TO_US(t_s)(lbm_uint)((t_s) * 1000000);
1356 blocking_extension_timeout = true1;
1357 } else {
1358 blocking_extension_timeout = false0;
1359 }
1360 return true1;
1361}
1362
1363void lbm_block_ctx_from_extension_timeout(float s) {
1364 lbm_block_ctx_base(true1, s);
1365}
1366
1367void lbm_block_ctx_from_extension(void) {
1368 lbm_block_ctx_base(false0, 0);
1369}
1370
1371// todo: May need to pop rmbrs from stack, if present.
1372// Suspect that the letting the discard cont run is really not a problem.
1373// Either way will be quite confusing what happens to allocated things when undoing block.
1374void lbm_undo_block_ctx_from_extension(void) {
1375 blocking_extension = false0;
1376 blocking_extension_timeout_us = 0;
1377 blocking_extension_timeout = false0;
1378 mutex_unlock(&blocking_extension_mutex);
1379}
1380
1381lbm_value lbm_find_receiver_and_send(lbm_cid cid, lbm_value msg) {
1382 mutex_lock(&qmutex);
1383 eval_context_t *found = NULL((void*)0);
1384 bool_Bool found_blocked = false0;
1385
1386 found = lookup_ctx_nm(&blocked, cid);
1387 if (found) found_blocked = true1;
1388
1389 if (found == NULL((void*)0)) {
1390 found = lookup_ctx_nm(&queue, cid);
1391 }
1392
1393 if (found) {
1394 if (!mailbox_add_mail(found, msg)) {
1395 mutex_unlock(&qmutex);
1396 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1397 }
1398
1399 if (found_blocked){
1400 drop_ctx_nm(&blocked,found);
1401 enqueue_ctx_nm(&queue,found);
1402 }
1403 mutex_unlock(&qmutex);
1404 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1405 }
1406
1407 /* check the current context */
1408 if (ctx_running && ctx_running->id == cid) {
1409 if (!mailbox_add_mail(ctx_running, msg)) {
1410 mutex_unlock(&qmutex);
1411 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1412 }
1413 mutex_unlock(&qmutex);
1414 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1415 }
1416 mutex_unlock(&qmutex);
1417 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1418}
1419
1420/* Pattern matching is currently implemented as a recursive
1421 function and make use of stack relative to the size of
1422 expressions that are being matched. */
1423static bool_Bool match(lbm_value p, lbm_value e, lbm_value *env, bool_Bool *gc) {
1424
1425 lbm_value binding;
1426
1427 if (lbm_is_match_binder(p)) {
1428 lbm_value var = get_cadr(p);
1429 lbm_value bindertype = get_car(p);
1430
1431 if (!lbm_is_symbol(var)) return false0;
1432
1433 switch (bindertype) {
1434 case ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u):
1435 if ( var == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) {
1436 return true1;
1437 }
1438 break;
1439 default: /* this should be an error case */
1440 return false0;
1441 }
1442 binding = lbm_cons(var, e);
1443 if ( lbm_type_of(binding) == LBM_TYPE_SYMBOL0x00000000u ) {
1444 *gc = true1;
1445 return false0;
1446 }
1447 *env = lbm_cons(binding, *env);
1448 if ( lbm_type_of(*env) == LBM_TYPE_SYMBOL0x00000000u ) {
1449 *gc = true1;
1450 return false0;
1451 }
1452 return true1;
1453 }
1454
1455 if (lbm_is_symbol(p)) {
1456 if (p == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return true1;
1457 return (p == e);
1458 }
1459 if (lbm_is_cons(p) &&
1460 lbm_is_cons(e) ) {
1461
1462 lbm_value headp, tailp;
1463 lbm_value heade, taile;
1464 get_car_and_cdr(p, &headp, &tailp);
1465 get_car_and_cdr(e, &heade, &taile); // Static analysis warns, but execution does not
1466 // past this point unless head and tail get initialized.
1467 if (!match(headp, heade, env, gc)) {
1468 return false0;
1469 }
1470 return match (tailp, taile, env, gc);
1471 }
1472 return struct_eq(p, e);
1473}
1474
1475// Find match is not very picky about syntax.
1476// A completely malformed recv form is most likely to
1477// just return no_match.
1478static int find_match(lbm_value plist, lbm_value *earr, lbm_uint num, lbm_value *e, lbm_value *env) {
1479
1480 // A pattern list is a list of pattern, expression lists.
1481 // ( (p1 e1) (p2 e2) ... (pn en))
1482 lbm_value curr_p = plist;
1483 int n = 0;
1484 bool_Bool gc = false0;
1485 for (int i = 0; i < (int)num; i ++ ) {
1486 lbm_value curr_e = earr[i];
1487 while (!lbm_is_symbol_nil(curr_p)) {
1488 lbm_value me = get_car(curr_p);
1489 if (match(get_car(me), curr_e, env, &gc)) {
1490 if (gc) return FM_NEED_GC-1;
1491 *e = get_cadr(me);
1492
1493 if (!lbm_is_symbol_nil(get_cadr(get_cdr(me)))) {
1494 return FM_PATTERN_ERROR-3;
1495 }
1496 return n;
1497 }
1498 curr_p = get_cdr(curr_p);
1499 }
1500 curr_p = plist; /* search all patterns against next exp */
1501 n ++;
1502 }
1503
1504 return FM_NO_MATCH-2;
1505}
1506
1507/****************************************************/
1508/* Garbage collection */
1509
1510static void mark_context(eval_context_t *ctx, void *arg1, void *arg2) {
1511 (void) arg1;
1512 (void) arg2;
1513 lbm_value roots[3] = {ctx->curr_exp, ctx->program, ctx->r };
1514 lbm_gc_mark_env(ctx->curr_env);
1515 lbm_gc_mark_roots(roots, 3);
1516 lbm_gc_mark_roots(ctx->mailbox, ctx->num_mail);
1517 lbm_gc_mark_aux(ctx->K.data, ctx->K.sp);
1518}
1519
1520static int gc(void) {
1521 if (ctx_running) {
1522 ctx_running->state = ctx_running->state | LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1523 }
1524
1525 gc_requested = false0;
1526 lbm_gc_state_inc();
1527
1528 // The freelist should generally be NIL when GC runs.
1529 lbm_nil_freelist();
1530 lbm_value *env = lbm_get_global_env();
1531 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
1532 lbm_gc_mark_env(env[i]);
1533 }
1534
1535 mutex_lock(&qmutex); // Lock the queues.
1536 // Any concurrent messing with the queues
1537 // while doing GC cannot possibly be good.
1538 queue_iterator_nm(&queue, mark_context, NULL((void*)0), NULL((void*)0));
1539 queue_iterator_nm(&blocked, mark_context, NULL((void*)0), NULL((void*)0));
1540
1541 if (ctx_running) {
1542 mark_context(ctx_running, NULL((void*)0), NULL((void*)0));
1543 }
1544 mutex_unlock(&qmutex);
1545
1546#ifdef VISUALIZE_HEAP
1547 heap_vis_gen_image();
1548#endif
1549
1550 int r = lbm_gc_sweep_phase();
1551 lbm_heap_new_freelist_length();
1552
1553 if (ctx_running) {
1554 ctx_running->state = ctx_running->state & ~LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1555 }
1556 return r;
1557}
1558
1559int lbm_perform_gc(void) {
1560 return gc();
1561}
1562
1563/****************************************************/
1564/* Evaluation functions */
1565
1566
1567static void eval_symbol(eval_context_t *ctx) {
1568 lbm_uint s = lbm_dec_sym(ctx->curr_exp);
1569 if (s >= RUNTIME_SYMBOLS_START0x40000) {
1570 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1571 if (lbm_env_lookup_b(&res, ctx->curr_exp, ctx->curr_env) ||
1572 lbm_global_env_lookup(&res, ctx->curr_exp)) {
1573 ctx->r = res;
1574 ctx->app_cont = true1;
1575 return;
1576 }
1577 // Dynamic load attempt
1578 // Only symbols of kind RUNTIME can be dynamically loaded.
1579 const char *sym_str = lbm_get_name_by_symbol(s);
1580 const char *code_str = NULL((void*)0);
1581 if (!dynamic_load_callback(sym_str, &code_str)) {
1582 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), ctx->curr_exp);
1583 }
1584 lbm_value *sptr = stack_reserve(ctx, 3);
1585 sptr[0] = ctx->curr_exp;
1586 sptr[1] = ctx->curr_env;
1587 sptr[2] = RESUME(((12) << 2) | 0xF8000001u);
1588
1589 lbm_value chan;
1590 if (!create_string_channel((char *)code_str, &chan)) {
1591 gc();
1592 if (!create_string_channel((char *)code_str, &chan)) {
1593 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1594 }
1595 }
1596
1597 lbm_value loader;
1598 WITH_GC_RMBR_1(loader, lbm_heap_allocate_list_init(2,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1599 ENC_SYM_READ,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1600 chan), chan)(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} };
1601 lbm_value evaluator;
1602 WITH_GC_RMBR_1(evaluator, lbm_heap_allocate_list_init(2,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1603 ENC_SYM_EVAL,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1604 loader), loader)(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } };
1605 ctx->curr_exp = evaluator;
1606 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // dynamics should be evaluable in empty local env
1607 } else {
1608 //special symbols and extensions can be handled the same way.
1609 ctx->r = ctx->curr_exp;
1610 ctx->app_cont = true1;
1611 }
1612}
1613
1614static void eval_quote(eval_context_t *ctx) {
1615 ctx->r = get_cadr(ctx->curr_exp);
1616 ctx->app_cont = true1;
1617}
1618
1619static void eval_selfevaluating(eval_context_t *ctx) {
1620 ctx->r = ctx->curr_exp;
1621 ctx->app_cont = true1;
1622}
1623
1624static void eval_progn(eval_context_t *ctx) {
1625 lbm_value exps = get_cdr(ctx->curr_exp);
1626
1627 if (lbm_is_cons(exps)) {
1628 lbm_uint *sptr = stack_reserve(ctx, 4);
1629 sptr[0] = ctx->curr_env; // env to restore between expressions in progn
1630 sptr[1] = lbm_enc_u(0); // Has env been copied (needed for progn local bindings)
1631 sptr[3] = PROGN_REST(((4) << 2) | 0xF8000001u);
1632 get_car_and_cdr(exps, &ctx->curr_exp, &sptr[2]);
1633 if (lbm_is_symbol(sptr[2])) /* The only symbol it can be is nil */
1634 lbm_stack_drop(&ctx->K, 4);
1635 } else if (lbm_is_symbol_nil(exps)) {
1636 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1637 ctx->app_cont = true1;
1638 } else {
1639 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1640 }
1641}
1642
1643static void eval_atomic(eval_context_t *ctx) {
1644 if (is_atomic) {
1645 lbm_set_error_reason("Atomic blocks cannot be nested!");
1646 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1647 }
1648 stack_reserve(ctx, 1)[0] = EXIT_ATOMIC(((14) << 2) | 0xF8000001u);
1649 is_atomic ++;
1650 eval_progn(ctx);
1651}
1652
1653/* (call-cc (lambda (k) .... )) */
1654static void eval_callcc(eval_context_t *ctx) {
1655 lbm_value cont_array;
1656 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1
Value assigned to 'cont_array'
→
2
←
Assuming the condition is false
→
3
←
Taking false branch
→
1657 gc();
1658 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1659 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1660 return; // dead return but static analysis doesn't know :)
1661 }
1662 }
1663 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(cont_array);
4
←
Passing value via 1st parameter 'a'
→
5
←
Calling 'get_car'
→
14
←
Returning from 'get_car'
→
15
←
'arr' initialized to a null pointer value
→
1664 memcpy(arr->data, ctx->K.data, ctx->K.sp * sizeof(lbm_uint));
16
←
Access to field 'data' results in a dereference of a null pointer (loaded from variable 'arr')
1665
1666 lbm_value acont = cons_with_gc(ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u), cont_array, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1667 lbm_value arg_list = cons_with_gc(acont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1668 // Go directly into application evaluation without passing go
1669 lbm_uint *sptr = stack_reserve(ctx, 3);
1670 sptr[0] = ctx->curr_env;
1671 sptr[1] = arg_list;
1672 sptr[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
1673 ctx->curr_exp = get_cadr(ctx->curr_exp);
1674}
1675
1676// (define sym exp)
1677#define KEY1 1
1678#define VAL2 2
1679static void eval_define(eval_context_t *ctx) {
1680 lbm_value parts[3];
1681 lbm_value rest = extract_n(ctx->curr_exp, parts, 3);
1682 lbm_uint *sptr = stack_reserve(ctx, 2);
1683 if (lbm_is_symbol(parts[KEY1]) && lbm_is_symbol_nil(rest)) {
1684 lbm_uint sym_val = lbm_dec_sym(parts[KEY1]);
1685 sptr[0] = parts[KEY1];
1686 if (sym_val >= RUNTIME_SYMBOLS_START0x40000) {
1687 sptr[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
1688 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02) {
1689 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
1690 }
1691 ctx->curr_exp = parts[VAL2];
1692 return;
1693 }
1694 }
1695 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
1696}
1697
1698
1699/* Eval lambda is cheating, a lot! It does this
1700 for performance reasons. The cheats are that
1701 1. When closure is created, a reference to the local env
1702 in which the lambda was evaluated is added to the closure.
1703 Ideally it should have created a list of free variables in the function
1704 and then looked up the values of these creating a new environment.
1705 2. The global env is considered global constant. As there is no copying
1706 of environment bindings into the closure, undefine may break closures.
1707
1708 Correct closure creation is a lot more expensive than what happens here.
1709 However, one can try to write programs in such a way that closures are created
1710 seldomly. If one does that the space-usage benefits of "correct" closures
1711 may outweigh the performance gain of "incorrect" ones.
1712
1713 some obscure programs such as test_setq_local_closure.lisp does not
1714 work properly due to this cheating.
1715 */
1716// (lambda param-list body-exp) -> (closure param-list body-exp env)
1717static void eval_lambda(eval_context_t *ctx) {
1718 lbm_value vals[3];
1719 extract_n(ctx->curr_exp, vals, 3);
1720 ctx->r = allocate_closure(vals[1],vals[2], ctx->curr_env);
1721#ifdef CLEAN_UP_CLOSURES
1722 lbm_uint sym_id = 0;
1723 if (clean_cl_env_symbol) {
1724 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1725 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1726 ctx->curr_exp = app;
1727 } else if (lbm_get_symbol_by_name("clean-cl-env", &sym_id)) {
1728 clean_cl_env_symbol = lbm_enc_sym(sym_id);
1729 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1730 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1731 ctx->curr_exp = app;
1732 } else {
1733 ctx->app_cont = true1;
1734 }
1735#else
1736 ctx->app_cont = true1;
1737#endif
1738}
1739
1740// (if cond-expr then-expr else-expr)
1741static void eval_if(eval_context_t *ctx) {
1742 lbm_value cdr = get_cdr(ctx->curr_exp);
1743 lbm_value *sptr = stack_reserve(ctx, 3);
1744 sptr[0] = get_cdr(cdr);
1745 sptr[1] = ctx->curr_env;
1746 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1747 ctx->curr_exp = get_car(cdr);
1748}
1749
1750// (cond (cond-expr-1 expr-1)
1751// ...
1752// (cond-expr-N expr-N))
1753static void eval_cond(eval_context_t *ctx) {
1754 lbm_value cond1[2];
1755 lbm_value rest_conds = extract_n(ctx->curr_exp, cond1, 2);
1756
1757 // end recursion at (cond )
1758 if (lbm_is_symbol_nil(cond1[1])) {
1759 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1760 ctx->app_cont = true1;
1761 } else {
1762 // Cond is one of the few places where a bit of syntax checking takes place at runtime..
1763 // Maybe dont bother?
1764 lbm_uint len = lbm_list_length(cond1[1]);
1765 if (len != 2) {
1766 lbm_set_error_reason("Incorrect syntax in cond");
1767 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1768 }
1769 lbm_value cond_expr[2];
1770 extract_n(cond1[1], cond_expr, 2);
1771 lbm_value rest;
1772 WITH_GC(rest, lbm_heap_allocate_list_init(2,(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1773 cond_expr[1], // Then branch(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1774 cons_with_gc(ENC_SYM_COND, rest_conds , ENC_SYM_NIL)))(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
1775 lbm_value *sptr = stack_reserve(ctx, 3);
1776 sptr[0] = rest;
1777 sptr[1] = ctx->curr_env;
1778 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1779 ctx->curr_exp = cond_expr[0]; //condition;
1780 }
1781}
1782
1783static void eval_app_cont(eval_context_t *ctx) {
1784 lbm_stack_drop(&ctx->K, 1);
1785 ctx->app_cont = true1;
1786}
1787
1788// Create a named location in an environment to later receive a value.
1789static binding_location_status create_binding_location_internal(lbm_value key, lbm_value *env) {
1790
1791 if (lbm_is_symbol(key) &&
1792 (key == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u) ||
1793 key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)))
1794 return BL_OK;
1795
1796 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) { // default case
1797 lbm_value binding;
1798 lbm_value new_env_tmp;
1799 binding = lbm_cons(key, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1800 new_env_tmp = lbm_cons(binding, *env);
1801 if (lbm_is_symbol(binding) || lbm_is_symbol(new_env_tmp)) {
1802 return BL_NO_MEMORY;
1803 }
1804 *env = new_env_tmp;
1805 } else if (lbm_is_cons(key)) { // deconstruct case
1806 int r = create_binding_location_internal(get_car(key), env);
1807 if (r == BL_OK) {
1808 r = create_binding_location_internal(get_cdr(key), env);
1809 }
1810 return r;
1811 }
1812 return BL_OK;
1813}
1814
1815static void create_binding_location(lbm_value key, lbm_value *env) {
1816
1817 lbm_value env_tmp = *env;
1818 binding_location_status r = create_binding_location_internal(key, &env_tmp);
1819 if (r != BL_OK) {
1820 if (r == BL_NO_MEMORY) {
1821 env_tmp = *env;
1822 lbm_gc_mark_phase(env_tmp);
1823 gc();
1824 r = create_binding_location_internal(key, &env_tmp);
1825 }
1826 switch(r) {
1827 case BL_OK:
1828 break;
1829 case BL_NO_MEMORY:
1830 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1831 break;
1832 case BL_INCORRECT_KEY:
1833 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
1834 break;
1835 }
1836 }
1837 *env = env_tmp;
1838}
1839
1840static void let_bind_values_eval(lbm_value binds, lbm_value exp, lbm_value env, eval_context_t *ctx) {
1841
1842 if (!lbm_is_cons(binds)) {
1843 // binds better be nil or there is a programmer error.
1844 ctx->curr_exp = exp;
1845 return;
1846 }
1847
1848 // Preallocate binding locations.
1849 lbm_value curr = binds;
1850 while (lbm_is_cons(curr)) {
1851 lbm_value new_env_tmp = env;
1852 lbm_value car_curr, cdr_curr;
1853 get_car_and_cdr(curr, &car_curr, &cdr_curr);
1854 lbm_value key = get_car(car_curr);
1855 create_binding_location(key, &new_env_tmp);
1856 env = new_env_tmp;
1857 curr = cdr_curr;
1858 }
1859
1860 lbm_value car_binds;
1861 lbm_value cdr_binds;
1862 get_car_and_cdr(binds, &car_binds, &cdr_binds);
1863 lbm_value key_val[2];
1864 extract_n(car_binds, key_val, 2);
1865
1866 lbm_uint *sptr = stack_reserve(ctx, 5);
1867 sptr[0] = exp;
1868 sptr[1] = cdr_binds;
1869 sptr[2] = env;
1870 sptr[3] = key_val[0];
1871 sptr[4] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
1872 ctx->curr_exp = key_val[1];
1873 ctx->curr_env = env;
1874}
1875
1876// (var x (...)) - local binding inside of an progn
1877// var has to take, place root-level nesting within progn.
1878// (progn ... (var a 10) ...) OK!
1879// (progn ... (something (var a 10)) ... ) NOT OK!
1880/* progn stack
1881 sp-4 : env
1882 sp-3 : 0
1883 sp-2 : rest
1884 sp-1 : PROGN_REST
1885*/
1886static void eval_var(eval_context_t *ctx) {
1887
1888 if (ctx->K.sp >= 4) { // Possibly in progn
1889 lbm_value sv = ctx->K.data[ctx->K.sp - 1];
1890 if (IS_CONTINUATION(sv)(((sv) & 0xF8000001u) == 0xF8000001u) && (sv == PROGN_REST(((4) << 2) | 0xF8000001u))) {
1891 lbm_uint sp = ctx->K.sp;
1892 uint32_t is_copied = lbm_dec_as_u32(ctx->K.data[sp-3]);
1893 if (is_copied == 0) {
1894 lbm_value env;
1895 WITH_GC(env, lbm_env_copy_spine(ctx->K.data[sp-4]))(env) = (lbm_env_copy_spine(ctx->K.data[sp-4])); if (lbm_is_symbol_merror
((env))) { gc(); (env) = (lbm_env_copy_spine(ctx->K.data[sp
-4])); if (lbm_is_symbol_merror((env))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1896 ctx->K.data[sp-3] = lbm_enc_u(1);
1897 ctx->K.data[sp-4] = env;
1898 }
1899 lbm_value new_env = ctx->K.data[sp-4];
1900 lbm_value args = get_cdr(ctx->curr_exp);
1901 lbm_value key = get_car(args);
1902 create_binding_location(key, &new_env);
1903 ctx->K.data[sp-4] = new_env;
1904
1905 lbm_value v_exp = get_cadr(args);
1906 lbm_value *sptr = stack_reserve(ctx, 3);
1907 sptr[0] = new_env;
1908 sptr[1] = key;
1909 sptr[2] = PROGN_VAR(((29) << 2) | 0xF8000001u);
1910 // Activating the new environment before the evaluation of the value to be bound,
1911 // means that other variables with same name will be shadowed already in the value
1912 // body.
1913 // The way closures work, the var-variable needs to be in scope during val evaluation
1914 // for a recursive closure to be possible.
1915 ctx->curr_env = new_env;
1916 ctx->curr_exp = v_exp;
1917 return;
1918 }
1919 }
1920 lbm_set_error_reason((char*)lbm_error_str_var_outside_progn);
1921 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1922}
1923
1924// (setq x (...)) - same as (set 'x (...)) or (setvar 'x (...))
1925static void eval_setq(eval_context_t *ctx) {
1926 lbm_value parts[3];
1927 extract_n(ctx->curr_exp, parts, 3);
1928 lbm_value *sptr = stack_reserve(ctx, 3);
1929 sptr[0] = ctx->curr_env;
1930 sptr[1] = parts[1];
1931 sptr[2] = SETQ(((30) << 2) | 0xF8000001u);
1932 ctx->curr_exp = parts[2];
1933}
1934
1935static void eval_move_to_flash(eval_context_t *ctx) {
1936 lbm_value args = get_cdr(ctx->curr_exp);
1937 lbm_value *sptr = stack_reserve(ctx,2);
1938 sptr[0] = args;
1939 sptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
1940 ctx->app_cont = true1;
1941}
1942
1943// (loop list-of-local-bindings
1944// condition-exp
1945// body-exp)
1946static void eval_loop(eval_context_t *ctx) {
1947 lbm_value env = ctx->curr_env;
1948 lbm_value parts[3];
1949 extract_n(get_cdr(ctx->curr_exp), parts, 3);
1950 lbm_value *sptr = stack_reserve(ctx, 3);
1951 sptr[0] = parts[LOOP_BODY2];
1952 sptr[1] = parts[LOOP_COND1];
1953 sptr[2] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
1954 let_bind_values_eval(parts[LOOP_BINDS0], parts[LOOP_COND1], env, ctx);
1955}
1956
1957/* (trap expression)
1958 *
1959 * suggested use:
1960 * (match (trap expression)
1961 * ((exit-error (? err)) (error-handler err))
1962 * ((exit-ok (? v)) (value-handler v)))
1963 */
1964static void eval_trap(eval_context_t *ctx) {
1965
1966 lbm_value expr = get_cadr(ctx->curr_exp);
1967 lbm_value retval;
1968 WITH_GC(retval, lbm_heap_allocate_list(2))(retval) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((retval))) { gc(); (retval) = (lbm_heap_allocate_list(2)); if
(lbm_is_symbol_merror((retval))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1969 lbm_set_car(retval, ENC_SYM_EXIT_OK(((0x3000B) << 4) | 0x00000000u)); // Assume things will go well.
1970 lbm_uint *sptr = stack_reserve(ctx,3);
1971 sptr[0] = retval;
1972 sptr[1] = ctx->flags;
1973 sptr[2] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1974 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10;
1975 ctx->curr_exp = expr;
1976}
1977
1978// (let list-of-binding s
1979// body-exp)
1980static void eval_let(eval_context_t *ctx) {
1981 lbm_value env = ctx->curr_env;
1982 lbm_value parts[3];
1983 extract_n(ctx->curr_exp, parts, 3);
1984 let_bind_values_eval(parts[1], parts[2], env, ctx);
1985}
1986
1987// (and exp0 ... expN)
1988static void eval_and(eval_context_t *ctx) {
1989 lbm_value rest = get_cdr(ctx->curr_exp);
1990 if (lbm_is_symbol_nil(rest)) {
1991 ctx->app_cont = true1;
1992 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1993 } else {
1994 lbm_value *sptr = stack_reserve(ctx, 3);
1995 sptr[0] = ctx->curr_env;
1996 sptr[1] = get_cdr(rest);
1997 sptr[2] = AND(((6) << 2) | 0xF8000001u);
1998 ctx->curr_exp = get_car(rest);
1999 }
2000}
2001
2002// (or exp0 ... expN)
2003static void eval_or(eval_context_t *ctx) {
2004 lbm_value rest = get_cdr(ctx->curr_exp);
2005 if (lbm_is_symbol_nil(rest)) {
2006 ctx->app_cont = true1;
2007 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2008 } else {
2009 lbm_value *sptr = stack_reserve(ctx, 3);
2010 sptr[0] = ctx->curr_env;
2011 sptr[1] = get_cdr(rest);
2012 sptr[2] = OR(((7) << 2) | 0xF8000001u);
2013 ctx->curr_exp = get_car(rest);
2014 }
2015}
2016
2017// Pattern matching
2018// format:
2019// (match e (pattern body)
2020// (pattern body)
2021// ... )
2022//
2023// There can be an optional pattern guard:
2024// (match e (pattern guard body)
2025// ... )
2026// a guard is a boolean expression.
2027// Guards make match, pattern matching more complicated
2028// than the recv pattern matching and requires staged execution
2029// via the continuation system rather than a while loop over a list.
2030static void eval_match(eval_context_t *ctx) {
2031
2032 lbm_value rest = get_cdr(ctx->curr_exp);
2033 if (lbm_type_of(rest) == LBM_TYPE_SYMBOL0x00000000u &&
2034 rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
2035 // Someone wrote the program (match)
2036 ctx->app_cont = true1;
2037 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2038 } else {
2039 lbm_value cdr_rest;
2040 get_car_and_cdr(rest, &ctx->curr_exp, &cdr_rest);
2041 lbm_value *sptr = stack_reserve(ctx, 3);
2042 sptr[0] = cdr_rest;
2043 sptr[1] = ctx->curr_env;
2044 sptr[2] = MATCH(((9) << 2) | 0xF8000001u);
2045 }
2046}
2047
2048static void receive_base(eval_context_t *ctx, lbm_value pats, float timeout_time, bool_Bool timeout) {
2049 if (ctx->num_mail == 0) {
2050 if (timeout) {
2051 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000), false0);
2052 } else {
2053 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1,0,false0);
2054 }
2055 } else {
2056 lbm_value *msgs = ctx->mailbox;
2057 lbm_uint num = ctx->num_mail;
2058
2059 if (lbm_is_symbol_nil(pats)) {
2060 /* A receive statement without any patterns */
2061 ctx->app_cont = true1;
2062 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2063 } else {
2064 /* The common case */
2065 lbm_value e;
2066 lbm_value new_env = ctx->curr_env;
2067 int n = find_match(pats, msgs, num, &e, &new_env);
2068 if (n == FM_NEED_GC-1) {
2069 gc();
2070 new_env = ctx->curr_env;
2071 n = find_match(pats, msgs, num, &e, &new_env);
2072 if (n == FM_NEED_GC-1) {
2073 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2074 }
2075 }
2076 if (n == FM_PATTERN_ERROR-3) {
2077 lbm_set_error_reason("Incorrect pattern format for recv");
2078 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),pats);
2079 } else if (n >= 0 ) { /* Match */
2080 mailbox_remove_mail(ctx, (lbm_uint)n);
2081 ctx->curr_env = new_env;
2082 ctx->curr_exp = e;
2083 } else { /* No match go back to sleep */
2084 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
2085 if (timeout) {
2086 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2,S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000),false0);
2087 } else {
2088 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,false0);
2089 }
2090 }
2091 }
2092 }
2093 return;
2094}
2095
2096static void eval_receive_timeout(eval_context_t *ctx) {
2097 if (is_atomic) {
2098 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2099 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2100 }
2101 lbm_value timeout_val = get_cadr(ctx->curr_exp);
2102 if (!lbm_is_number(timeout_val)) {
2103 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2104 }
2105 float timeout_time = lbm_dec_as_float(timeout_val);
2106 lbm_value pats = get_cdr(get_cdr(ctx->curr_exp));
2107 receive_base(ctx, pats, timeout_time, true1);
2108}
2109
2110// Receive
2111// (recv (pattern expr)
2112// (pattern expr))
2113static void eval_receive(eval_context_t *ctx) {
2114
2115 if (is_atomic) {
2116 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2117 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
2118 }
2119 lbm_value pats = get_cdr(ctx->curr_exp);
2120 receive_base(ctx, pats, 0, false0);
2121}
2122
2123/*********************************************************/
2124/* Continuation functions */
2125
2126/* cont_set_global_env
2127 sp-1 : Key-symbol
2128 */
2129static void cont_set_global_env(eval_context_t *ctx){
2130
2131 lbm_value key;
2132 lbm_value val = ctx->r;
2133
2134 lbm_pop(&ctx->K, &key);
2135 lbm_uint dec_key = lbm_dec_sym(key);
2136 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
2137 lbm_value *global_env = lbm_get_global_env();
2138 lbm_uint orig_env = global_env[ix_key];
2139 lbm_value new_env;
2140 // A key is a symbol and should not need to be remembered.
2141 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2142
2143 global_env[ix_key] = new_env;
2144 ctx->r = val;
2145
2146 ctx->app_cont = true1;
2147
2148 return;
2149}
2150
2151static void cont_resume(eval_context_t *ctx) {
2152 lbm_pop_2(&ctx->K, &ctx->curr_env, &ctx->curr_exp);
2153}
2154
2155static void cont_progn_rest(eval_context_t *ctx) {
2156 lbm_value *sptr = get_stack_ptr(ctx, 3);
2157
2158 lbm_value rest = sptr[2];
2159 lbm_value env = sptr[0];
2160
2161 lbm_value rest_car, rest_cdr;
2162 get_car_and_cdr(rest, &rest_car, &rest_cdr);
2163 ctx->curr_exp = rest_car;
2164 ctx->curr_env = env;
2165 if (lbm_is_symbol_nil(rest_cdr)) {
2166 // allow for tail recursion
2167 lbm_stack_drop(&ctx->K, 3);
2168 } else {
2169 sptr[2] = rest_cdr;
2170 stack_reserve(ctx, 1)[0] = PROGN_REST(((4) << 2) | 0xF8000001u);
2171 }
2172}
2173
2174static void cont_wait(eval_context_t *ctx) {
2175
2176 lbm_value cid_val;
2177 lbm_pop(&ctx->K, &cid_val);
2178 lbm_cid cid = (lbm_cid)lbm_dec_i(cid_val);
2179
2180 bool_Bool exists = false0;
2181
2182 lbm_blocked_iterator(context_exists, &cid, &exists);
2183 lbm_running_iterator(context_exists, &cid, &exists);
2184
2185 if (ctx_running->id == cid) {
2186 exists = true1;
2187 }
2188
2189 if (exists) {
2190 lbm_value *sptr = stack_reserve(ctx, 2);
2191 sptr[0] = lbm_enc_i(cid);
2192 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2193 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2194 ctx->app_cont = true1;
2195 yield_ctx(50000);
2196 } else {
2197 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2198 ctx->app_cont = true1;
2199 }
2200}
2201
2202static lbm_value perform_setvar(lbm_value key, lbm_value val, lbm_value env) {
2203
2204 lbm_uint s = lbm_dec_sym(key);
2205 if (s >= RUNTIME_SYMBOLS_START0x40000) {
2206 lbm_value new_env = lbm_env_modify_binding(env, key, val);
2207 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2208 lbm_uint ix_key = lbm_dec_sym(key) & GLOBAL_ENV_MASK0x1F;
2209 lbm_value *glob_env = lbm_get_global_env();
2210 new_env = lbm_env_modify_binding(glob_env[ix_key], key, val);
2211 glob_env[ix_key] = new_env;
2212 }
2213 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2214 lbm_set_error_reason((char*)lbm_error_str_variable_not_bound);
2215 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), key);
2216 }
2217 return val;
2218 }
2219 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2220 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // unreachable
2221}
2222
2223static void apply_setvar(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2224 if (nargs == 2 && lbm_is_symbol(args[0])) {
2225 lbm_value res;
2226 WITH_GC(res, perform_setvar(args[0], args[1], ctx->curr_env))(res) = (perform_setvar(args[0], args[1], ctx->curr_env));
if (lbm_is_symbol_merror((res))) { gc(); (res) = (perform_setvar
(args[0], args[1], ctx->curr_env)); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2227 ctx->r = args[1];
2228 lbm_stack_drop(&ctx->K, nargs+1);
2229 ctx->app_cont = true1;
2230 } else {
2231 if (nargs == 2) lbm_set_error_reason((char*)lbm_error_str_incorrect_arg);
2232 else lbm_set_error_reason((char*)lbm_error_str_num_args);
2233 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2234 }
2235}
2236
2237static void apply_read_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, bool_Bool program, bool_Bool incremental) {
2238 if (nargs == 1) {
2239 lbm_value chan = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2240 if (lbm_type_of_functional(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2241 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2242 gc();
2243 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2244 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2245 }
2246 }
2247 } else if (lbm_type_of(args[0]) == LBM_TYPE_CHANNEL0x90000000u) {
2248 chan = args[0];
2249 } else {
2250 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2251 }
2252 lbm_value *sptr = get_stack_ptr(ctx, 2);
2253
2254 // If we are inside a reader, its settings are stored.
2255 sptr[0] = lbm_enc_u(ctx->flags); // flags stored.
2256 sptr[1] = chan;
2257 lbm_value *rptr = stack_reserve(ctx,1);
2258 rptr[0] = READ_DONE(((20) << 2) | 0xF8000001u);
2259
2260 // Each reader starts in a fresh situation
2261 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
2262
2263 if (program) {
2264 if (incremental) {
2265 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2266 lbm_value *rptr1 = stack_reserve(ctx,3);
2267 rptr1[0] = chan;
2268 rptr1[1] = ctx->curr_env;
2269 rptr1[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
2270 } else {
2271 ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2272 lbm_value *rptr1 = stack_reserve(ctx,4);
2273 rptr1[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2274 rptr1[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2275 rptr1[2] = chan;
2276 rptr1[3] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
2277 }
2278 }
2279 rptr = stack_reserve(ctx,3); // reuse of variable rptr
2280 rptr[0] = chan;
2281 rptr[1] = lbm_enc_u(1);
2282 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
2283 ctx->app_cont = true1;
2284 } else {
2285 lbm_set_error_reason((char*)lbm_error_str_num_args);
2286 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2287 }
2288}
2289
2290static void apply_read_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2291 apply_read_base(args,nargs,ctx,true1,false0);
2292}
2293
2294static void apply_read_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2295 apply_read_base(args,nargs,ctx,true1,true1);
2296}
2297
2298static void apply_read(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2299 apply_read_base(args,nargs,ctx,false0,false0);
2300}
2301
2302static void apply_spawn_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, uint32_t context_flags) {
2303
2304 lbm_uint stack_size = EVAL_CPS_DEFAULT_STACK_SIZE256;
2305 lbm_uint closure_pos = 0;
2306 char *name = NULL((void*)0);
2307
2308 if (nargs >= 1 &&
2309 lbm_is_closure(args[0])) {
2310 closure_pos = 0;
2311 } else if (nargs >= 2 &&
2312 lbm_is_number(args[0]) &&
2313 lbm_is_closure(args[1])) {
2314 stack_size = lbm_dec_as_u32(args[0]);
2315 closure_pos = 1;
2316 } else if (nargs >= 2 &&
2317 lbm_is_array_r(args[0]) &&
2318 lbm_is_closure(args[1])) {
2319 name = lbm_dec_str(args[0]);
2320 closure_pos = 1;
2321 }else if (nargs >= 3 &&
2322 lbm_is_array_r(args[0]) &&
2323 lbm_is_number(args[1]) &&
2324 lbm_is_closure(args[2])) {
2325 stack_size = lbm_dec_as_u32(args[1]);
2326 closure_pos = 2;
2327 name = lbm_dec_str(args[0]);
2328 } else {
2329 if (context_flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01)
2330 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN_TRAP(((0x30005) << 4) | 0x00000000u));
2331 else
2332 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN(((0x30004) << 4) | 0x00000000u));
2333 }
2334
2335 lbm_value cl[3];
2336 extract_n(get_cdr(args[closure_pos]), cl, 3);
2337 lbm_value curr_param = cl[CLO_PARAMS0];
2338 lbm_value clo_env = cl[CLO_ENV2];
2339 lbm_uint i = closure_pos + 1;
2340 while (lbm_is_cons(curr_param) && i <= nargs) {
2341 lbm_value entry = cons_with_gc(get_car(curr_param), args[i], clo_env);
2342 lbm_value aug_env = cons_with_gc(entry, clo_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2343 clo_env = aug_env;
2344 curr_param = get_cdr(curr_param);
2345 i ++;
2346 }
2347
2348 lbm_stack_drop(&ctx->K, nargs+1);
2349
2350 lbm_value program = cons_with_gc(cl[CLO_BODY1], ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), clo_env);
2351
2352 lbm_cid cid = lbm_create_ctx_parent(program,
2353 clo_env,
2354 stack_size,
2355 lbm_get_current_cid(),
2356 context_flags,
2357 name);
2358 ctx->r = lbm_enc_i(cid);
2359 ctx->app_cont = true1;
2360}
2361
2362static void apply_spawn(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2363 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00);
2364}
2365
2366static void apply_spawn_trap(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2367 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01);
2368}
2369
2370static void apply_yield(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2371 if (is_atomic) {
2372 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2373 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2374 }
2375 if (nargs == 1 && lbm_is_number(args[0])) {
2376 lbm_uint ts = lbm_dec_as_u32(args[0]);
2377 lbm_stack_drop(&ctx->K, nargs+1);
2378 yield_ctx(ts);
2379 } else {
2380 lbm_set_error_reason((char*)lbm_error_str_no_number);
2381 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2382 }
2383}
2384
2385static void apply_sleep(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2386 if (is_atomic) {
2387 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2388 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2389 }
2390 if (nargs == 1 && lbm_is_number(args[0])) {
2391 lbm_uint ts = (lbm_uint)(1000000.0f * lbm_dec_as_float(args[0]));
2392 lbm_stack_drop(&ctx->K, nargs+1);
2393 yield_ctx(ts);
2394 } else {
2395 lbm_set_error_reason((char*)lbm_error_str_no_number);
2396 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2397 }
2398}
2399
2400static void apply_wait(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2401 if (nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2402 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2403 lbm_value *sptr = get_stack_ptr(ctx, 2);
2404 sptr[0] = lbm_enc_i(cid);
2405 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2406 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2407 ctx->app_cont = true1;
2408 yield_ctx(50000);
2409 } else {
2410 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_WAIT(((0x30007) << 4) | 0x00000000u));
2411 }
2412}
2413
2414/* (eval expr)
2415 (eval env expr) */
2416static void apply_eval(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2417 if ( nargs == 1) {
2418 ctx->curr_exp = args[0];
2419 } else if (nargs == 2) {
2420 ctx->curr_exp = args[1];
2421 ctx->curr_env = args[0];
2422 } else {
2423 lbm_set_error_reason((char*)lbm_error_str_num_args);
2424 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL(((0x30008) << 4) | 0x00000000u));
2425 }
2426 lbm_stack_drop(&ctx->K, nargs+1);
2427}
2428
2429static void apply_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2430 int prg_pos = 0;
2431 if (nargs == 2) {
2432 prg_pos = 1;
2433 ctx->curr_env = args[0];
2434 }
2435 if (nargs == 1 || nargs == 2) {
2436 lbm_value prg = args[prg_pos];
2437 lbm_value app_cont;
2438 lbm_value app_cont_prg;
2439 lbm_value new_prg;
2440 lbm_value prg_copy;
2441
2442 int len = -1;
2443 WITH_GC(prg_copy, lbm_list_copy(&len, prg))(prg_copy) = (lbm_list_copy(&len, prg)); if (lbm_is_symbol_merror
((prg_copy))) { gc(); (prg_copy) = (lbm_list_copy(&len, prg
)); if (lbm_is_symbol_merror((prg_copy))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2444 lbm_stack_drop(&ctx->K, nargs+1);
2445
2446 if (ctx->K.sp > nargs+2) { // if there is a continuation
2447 app_cont = cons_with_gc(ENC_SYM_APP_CONT(((0x111) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2448 app_cont_prg = cons_with_gc(app_cont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2449 new_prg = lbm_list_append(app_cont_prg, ctx->program);
2450 new_prg = lbm_list_append(prg_copy, new_prg);
2451 } else {
2452 new_prg = lbm_list_append(prg_copy, ctx->program);
2453 }
2454 if (!lbm_is_list(new_prg)) {
2455 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2456 }
2457 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);
2458 ctx->program = get_cdr(new_prg);
2459 ctx->curr_exp = get_car(new_prg);
2460 } else {
2461 lbm_set_error_reason((char*)lbm_error_str_num_args);
2462 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2463 }
2464}
2465
2466static void apply_send(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2467 if (nargs == 2) {
2468 if (lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2469 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2470 lbm_value msg = args[1];
2471 lbm_value status = lbm_find_receiver_and_send(cid, msg);
2472 /* return the status */
2473 lbm_stack_drop(&ctx->K, nargs+1);
2474 ctx->r = status;
2475 ctx->app_cont = true1;
2476 } else {
2477 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2478 }
2479 } else {
2480 lbm_set_error_reason((char*)lbm_error_str_num_args);
2481 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2482 }
2483}
2484
2485static void apply_ok(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2486 lbm_value ok_val = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2487 if (nargs >= 1) {
2488 ok_val = args[0];
2489 }
2490 ctx->r = ok_val;
2491 ok_ctx();
2492}
2493
2494static void apply_error(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2495 (void) ctx;
2496 lbm_value err_val = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
2497 if (nargs >= 1) {
2498 err_val = args[0];
2499 }
2500 error_at_ctx(err_val, ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
2501}
2502
2503// (map f arg-list)
2504static void apply_map(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2505 if (nargs == 2 && lbm_is_cons(args[1])) {
2506 lbm_value *sptr = get_stack_ptr(ctx, 3);
2507
2508 lbm_value f = args[0];
2509 lbm_value h = get_car(args[1]);
2510 lbm_value t = get_cdr(args[1]);
2511
2512 lbm_value appli_1;
2513 lbm_value appli;
2514 WITH_GC(appli_1, lbm_heap_allocate_list(2))(appli_1) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli_1))) { gc(); (appli_1) = (lbm_heap_allocate_list(2));
if (lbm_is_symbol_merror((appli_1))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2515 WITH_GC_RMBR_1(appli, lbm_heap_allocate_list(2), appli_1)(appli) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli))) { lbm_gc_mark_phase(appli_1); gc(); (appli) = (lbm_heap_allocate_list
(2)); if (lbm_is_symbol_merror((appli))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2516
2517 lbm_value appli_0 = get_cdr(appli_1);
2518
2519 lbm_set_car_and_cdr(appli_0, h, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2520 lbm_set_car(appli_1, ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u));
2521
2522 lbm_set_car_and_cdr(get_cdr(appli), appli_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2523 lbm_set_car(appli, f);
2524
2525 lbm_value elt = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), appli);
2526 sptr[0] = t; // reuse stack space
2527 sptr[1] = ctx->curr_env;
2528 sptr[2] = elt;
2529 lbm_value *rptr = stack_reserve(ctx,4);
2530 rptr[0] = elt;
2531 rptr[1] = appli;
2532 rptr[2] = appli_0;
2533 rptr[3] = MAP(((26) << 2) | 0xF8000001u);
2534 ctx->curr_exp = appli;
2535 } else if (nargs == 2 && lbm_is_symbol_nil(args[1])) {
2536 lbm_stack_drop(&ctx->K, 3);
2537 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2538 ctx->app_cont = true1;
2539 return;
2540 } else {
2541 lbm_set_error_reason((char*)lbm_error_str_num_args);
2542 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_MAP(((0x3000D) << 4) | 0x00000000u));
2543 }
2544}
2545
2546static void apply_reverse(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2547 if (nargs == 1 && lbm_is_list(args[0])) {
2548 lbm_value curr = args[0];
2549
2550 lbm_value new_list = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2551 while (lbm_is_cons(curr)) {
2552 lbm_value tmp = cons_with_gc(get_car(curr), new_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2553 new_list = tmp;
2554 curr = get_cdr(curr);
2555 }
2556 lbm_stack_drop(&ctx->K, 2);
2557 ctx->r = new_list;
2558 ctx->app_cont = true1;
2559 } else {
2560 lbm_set_error_reason("Reverse requires a list argument");
2561 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_REVERSE(((0x3000E) << 4) | 0x00000000u));
2562 }
2563}
2564
2565static void apply_flatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2566 if (nargs == 1) {
2567
2568 lbm_value v = flatten_value(args[0]);
2569 if ( v == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)) {
2570 gc();
2571 v = flatten_value(args[0]);
2572 }
2573
2574 if (lbm_is_symbol(v)) {
2575 error_at_ctx(v, ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2576 } else {
2577 lbm_stack_drop(&ctx->K, 2);
2578 ctx->r = v;
2579 ctx->app_cont = true1;
2580 }
2581 return;
2582 }
2583 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2584}
2585
2586static void apply_unflatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2587 if(nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2588 lbm_array_header_t *array;
2589 array = (lbm_array_header_t *)get_car(args[0]);
2590
2591 lbm_flat_value_t fv;
2592 fv.buf = (uint8_t*)array->data;
2593 fv.buf_size = array->size;
2594 fv.buf_pos = 0;
2595
2596 lbm_value res;
2597
2598 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2599 if (lbm_unflatten_value(&fv, &res)) {
2600 ctx->r = res;
2601 }
2602 lbm_stack_drop(&ctx->K, 2);
2603 ctx->app_cont = true1;
2604 return;
2605 }
2606 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_UNFLATTEN(((0x30010) << 4) | 0x00000000u));
2607}
2608
2609static void apply_kill(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2610 if (nargs == 2 && lbm_is_number(args[0])) {
2611 lbm_cid cid = lbm_dec_as_i32(args[0]);
2612
2613 if (ctx->id == cid) {
2614 ctx->r = args[1];
2615 finish_ctx();
2616 return;
2617 }
2618 mutex_lock(&qmutex);
2619 eval_context_t *found = NULL((void*)0);
2620 found = lookup_ctx_nm(&blocked, cid);
2621 if (found)
2622 drop_ctx_nm(&blocked, found);
2623 else
2624 found = lookup_ctx_nm(&queue, cid);
2625 if (found)
2626 drop_ctx_nm(&queue, found);
2627
2628 if (found) {
2629 found->K.data[found->K.sp - 1] = KILL(((40) << 2) | 0xF8000001u);
2630 found->r = args[1];
2631 found->app_cont = true1;
2632 enqueue_ctx_nm(&queue,found);
2633 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2634 } else {
2635 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2636 }
2637 lbm_stack_drop(&ctx->K, 3);
2638 ctx->app_cont = true1;
2639 mutex_unlock(&qmutex);
2640 return;
2641 }
2642 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_KILL(((0x30011) << 4) | 0x00000000u));
2643}
2644
2645// (merge comparator list1 list2)
2646static void apply_merge(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2647 if (nargs == 3 && lbm_is_list(args[1]) && lbm_is_list(args[2])) {
2648
2649 if (!lbm_is_closure(args[0])) {
2650 lbm_value closure;
2651 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2652 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2653 lbm_value cl1 = lbm_cdr(closure);
2654 lbm_value par;
2655 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2656 lbm_set_car(cl1, par);
2657 lbm_value cl2 = lbm_cdr(cl1);
2658 lbm_value body;
2659 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2660 lbm_set_car(cl2, body);
2661 lbm_value cl3 = lbm_cdr(cl2);
2662 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2663
2664 // Replace operator on stack with closure and rest of the code is
2665 // compatible.
2666 args[0] = closure;
2667 }
2668
2669 // Copy input lists for functional behaviour at top-level
2670 // merge itself is in-place in the copied lists.
2671 lbm_value a;
2672 lbm_value b;
2673 int len_a = -1;
2674 int len_b = -1;
2675 WITH_GC(a, lbm_list_copy(&len_a, args[1]))(a) = (lbm_list_copy(&len_a, args[1])); if (lbm_is_symbol_merror
((a))) { gc(); (a) = (lbm_list_copy(&len_a, args[1])); if
(lbm_is_symbol_merror((a))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } };
2676 WITH_GC_RMBR_1(b, lbm_list_copy(&len_b, args[2]), a)(b) = (lbm_list_copy(&len_b, args[2])); if (lbm_is_symbol_merror
((b))) { lbm_gc_mark_phase(a); gc(); (b) = (lbm_list_copy(&
len_b, args[2])); if (lbm_is_symbol_merror((b))) { error_ctx(
(((0x23) << 4) | 0x00000000u)); } };
2677
2678 if (len_a == 0) {
2679 ctx->r = b;
2680 lbm_stack_drop(&ctx->K, 4);
2681 ctx->app_cont = true1;
2682 return;
2683 }
2684 if (len_b == 0) {
2685 ctx->r = a;
2686 lbm_stack_drop(&ctx->K, 4);
2687 ctx->app_cont = true1;
2688 return;
2689 }
2690
2691 args[1] = a; // keep safe by replacing the original on stack.
2692 args[2] = b;
2693
2694 lbm_value a_1 = a;
2695 lbm_value a_rest = lbm_cdr(a);
2696 lbm_value b_1 = b;
2697 lbm_value b_rest = lbm_cdr(b);
2698
2699 lbm_value cl[3]; // Comparator closure
2700 extract_n(lbm_cdr(args[0]), cl, 3);
2701 lbm_value cmp_env = cl[CLO_ENV2];
2702 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2703 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2704 lbm_uint len = lbm_list_length(cl[CLO_PARAMS0]);
2705 if (len == 2) {
2706 par1 = get_car(cl[CLO_PARAMS0]);
2707 par2 = get_cadr(cl[CLO_PARAMS0]);
2708 lbm_value new_env0;
2709 lbm_value new_env;
2710 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a_1)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a_1))); if (
lbm_is_symbol_merror((new_env0))) { gc(); (new_env0) = (lbm_env_set
(cmp_env, par1, lbm_car(a_1))); if (lbm_is_symbol_merror((new_env0
))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2711 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b_1)),new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1))); if (
lbm_is_symbol_merror((new_env))) { lbm_gc_mark_phase(new_env0
); gc(); (new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1
))); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2712 cmp_env = new_env;
2713 } else {
2714 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2715 }
2716 lbm_set_cdr(a_1, b_1);
2717 lbm_set_cdr(b_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2718 lbm_value cmp = cl[CLO_BODY1];
2719
2720 lbm_stack_drop(&ctx->K, 4); // TODO: Optimize drop 4 alloc 10 into alloc 6
2721 lbm_uint *sptr = stack_reserve(ctx, 10);
2722 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged list
2723 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged list
2724 sptr[2] = a_1;
2725 sptr[3] = a_rest;
2726 sptr[4] = b_rest;
2727 sptr[5] = cmp;
2728 sptr[6] = cmp_env;
2729 sptr[7] = par1;
2730 sptr[8] = par2;
2731 sptr[9] = MERGE_REST(((43) << 2) | 0xF8000001u);
2732 ctx->curr_exp = cl[CLO_BODY1];
2733 ctx->curr_env = cmp_env;
2734 return;
2735 }
2736 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MERGE(((0x30013) << 4) | 0x00000000u));
2737}
2738
2739// (sort comparator list)
2740static void apply_sort(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2741 if (nargs == 2 && lbm_is_list(args[1])) {
2742
2743 if (!lbm_is_closure(args[0])) {
2744 lbm_value closure;
2745 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2746 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2747 lbm_value cl1 = lbm_cdr(closure);
2748 lbm_value par;
2749 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2750 lbm_set_car(cl1, par);
2751 lbm_value cl2 = lbm_cdr(cl1);
2752 lbm_value body;
2753 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2754 lbm_set_car(cl2, body);
2755 lbm_value cl3 = lbm_cdr(cl2);
2756 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2757
2758 // Replace operator on stack with closure and rest of the code is
2759 // compatible.
2760 args[0] = closure;
2761 }
2762
2763 int len = -1;
2764 lbm_value list_copy;
2765 WITH_GC(list_copy, lbm_list_copy(&len, args[1]))(list_copy) = (lbm_list_copy(&len, args[1])); if (lbm_is_symbol_merror
((list_copy))) { gc(); (list_copy) = (lbm_list_copy(&len,
args[1])); if (lbm_is_symbol_merror((list_copy))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2766 if (len <= 1) {
2767 lbm_stack_drop(&ctx->K, 3);
2768 ctx->r = list_copy;
2769 ctx->app_cont = true1;
2770 return;
2771 }
2772
2773 args[1] = list_copy; // Keep safe, original replaced on stack.
2774
2775 // Take the headmost 2, 1-element sublists.
2776 lbm_value a = list_copy;
2777 lbm_value b = lbm_cdr(a);
2778 lbm_value rest = lbm_cdr(b);
2779 // Do not terminate b. keep rest of list safe from GC in the following
2780 // closure extraction.
2781 //lbm_set_cdr(a, b); // This is void
2782
2783 lbm_value cl[3]; // Comparator closure
2784 extract_n(lbm_cdr(args[0]), cl, 3);
2785 lbm_value cmp_env = cl[CLO_ENV2];
2786 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2787 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2788 lbm_uint cl_len = lbm_list_length(cl[CLO_PARAMS0]);
2789 if (cl_len == 2) {
2790 par1 = get_car(cl[CLO_PARAMS0]);
2791 par2 = get_cadr(cl[CLO_PARAMS0]);
2792 lbm_value new_env0;
2793 lbm_value new_env;
2794 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a))); if (lbm_is_symbol_merror
((new_env0))) { gc(); (new_env0) = (lbm_env_set(cmp_env, par1
, lbm_car(a))); if (lbm_is_symbol_merror((new_env0))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2795 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b)), new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { lbm_gc_mark_phase(new_env0); gc(); (new_env) =
(lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { error_ctx((((0x23) << 4) | 0x00000000u))
; } };
2796 cmp_env = new_env;
2797 } else {
2798 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2799 }
2800 lbm_value cmp = cl[CLO_BODY1];
2801
2802 // Terminate the comparator argument list.
2803 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2804
2805 lbm_stack_drop(&ctx->K, 3); //TODO: optimize drop 3, alloc 20 into alloc 17
2806 lbm_uint *sptr = stack_reserve(ctx, 20);
2807 sptr[0] = cmp;
2808 sptr[1] = cmp_env;
2809 sptr[2] = par1;
2810 sptr[3] = par2;
2811 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged accumulation of sublists
2812 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged accumulation of sublists
2813 sptr[6] = rest;
2814 sptr[7] = lbm_enc_i(1);
2815 sptr[8] = lbm_enc_i(len); //TODO: 28 bit i vs 32 bit i
2816 sptr[9] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
2817 sptr[10] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged sublist
2818 sptr[11] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged sublist
2819 sptr[12] = a;
2820 sptr[13] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no a_rest, 1 element lists in layer 1.
2821 sptr[14] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no b_rest, 1 element lists in layer 1.
2822 sptr[15] = cmp;
2823 sptr[16] = cmp_env;
2824 sptr[17] = par1;
2825 sptr[18] = par2;
2826 sptr[19] = MERGE_REST(((43) << 2) | 0xF8000001u);
2827 ctx->curr_exp = cmp;
2828 ctx->curr_env = cmp_env;
2829 return;
2830 }
2831 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
2832}
2833
2834static void apply_rest_args(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2835 lbm_value res;
2836 if (lbm_env_lookup_b(&res, ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ctx->curr_env)) {
2837 if (nargs == 1 && lbm_is_number(args[0])) {
2838 int32_t ix = lbm_dec_as_i32(args[0]);
2839 res = lbm_index_list(res, ix);
2840 }
2841 ctx->r = res;
2842 } else {
2843 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2844 }
2845 lbm_stack_drop(&ctx->K, nargs+1);
2846 ctx->app_cont = true1;
2847}
2848
2849/* (rotate list-expr dist/dir-expr) */
2850static void apply_rotate(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2851 if (nargs == 2 && lbm_is_list(args[0]) && lbm_is_number(args[1])) {
2852 int len = -1;
2853 lbm_value ls = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2854 WITH_GC(ls, lbm_list_copy(&len, args[0]))(ls) = (lbm_list_copy(&len, args[0])); if (lbm_is_symbol_merror
((ls))) { gc(); (ls) = (lbm_list_copy(&len, args[0])); if
(lbm_is_symbol_merror((ls))) { error_ctx((((0x23) << 4
) | 0x00000000u)); } };
2855 int dist = lbm_dec_as_i32(args[1]);
2856 if (len > 0 && dist != 0) {
2857 int d = dist;
2858 if (dist > 0) {
2859 ls = lbm_list_destructive_reverse(ls);
2860 } else {
2861 d = -dist;
2862 }
2863
2864 lbm_value start = ls;
2865 lbm_value end = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2866 lbm_value curr = start;
2867 while (lbm_is_cons(curr)) {
2868 end = curr;
2869 curr = get_cdr(curr);
2870 }
2871
2872 for (int i = 0; i < d; i ++) {
2873 lbm_value a = start;
2874 start = lbm_cdr(start);
2875 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2876 lbm_set_cdr(end, a);
2877 end = a;
2878 }
2879 ls = start;
2880 if (dist > 0) {
2881 ls = lbm_list_destructive_reverse(ls);
2882 }
2883 }
2884 lbm_stack_drop(&ctx->K, nargs+1);
2885 ctx->app_cont = true1;
2886 ctx->r = ls;
2887 return;
2888 }
2889 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2890}
2891
2892/***************************************************/
2893/* Application lookup table */
2894
2895typedef void (*apply_fun)(lbm_value *, lbm_uint, eval_context_t *);
2896static const apply_fun fun_table[] =
2897 {
2898 apply_setvar,
2899 apply_read,
2900 apply_read_program,
2901 apply_read_eval_program,
2902 apply_spawn,
2903 apply_spawn_trap,
2904 apply_yield,
2905 apply_wait,
2906 apply_eval,
2907 apply_eval_program,
2908 apply_send,
2909 apply_ok,
2910 apply_error,
2911 apply_map,
2912 apply_reverse,
2913 apply_flatten,
2914 apply_unflatten,
2915 apply_kill,
2916 apply_sleep,
2917 apply_merge,
2918 apply_sort,
2919 apply_rest_args,
2920 apply_rotate,
2921 };
2922
2923/***************************************************/
2924/* Application of function that takes arguments */
2925/* passed over the stack. */
2926
2927static void application(eval_context_t *ctx, lbm_value *fun_args, lbm_uint arg_count) {
2928 /* If arriving here, we know that the fun is a symbol.
2929 * and can be a built in operation or an extension.
2930 */
2931 lbm_value fun = fun_args[0];
2932
2933 lbm_uint fun_val = lbm_dec_sym(fun);
2934 lbm_uint fun_kind = SYMBOL_KIND(fun_val)((fun_val) >> 16);
2935
2936 switch (fun_kind) {
2937 case SYMBOL_KIND_EXTENSION1: {
2938 extension_fptr f = extension_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)].fptr;
2939
2940 lbm_value ext_res;
2941 WITH_GC(ext_res, f(&fun_args[1], arg_count))(ext_res) = (f(&fun_args[1], arg_count)); if (lbm_is_symbol_merror
((ext_res))) { gc(); (ext_res) = (f(&fun_args[1], arg_count
)); if (lbm_is_symbol_merror((ext_res))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2942 if (lbm_is_error(ext_res)) { //Error other than merror
2943 error_at_ctx(ext_res, fun);
2944 }
2945 lbm_stack_drop(&ctx->K, arg_count + 1);
2946
2947 ctx->app_cont = true1;
2948 ctx->r = ext_res;
2949
2950 if (blocking_extension) {
2951 blocking_extension = false0;
2952 if (blocking_extension_timeout) {
2953 blocking_extension_timeout = false0;
2954 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, blocking_extension_timeout_us,true1);
2955 } else {
2956 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,true1);
2957 }
2958 mutex_unlock(&blocking_extension_mutex);
2959 }
2960 } break;
2961 case SYMBOL_KIND_FUNDAMENTAL2:
2962 call_fundamental(SYMBOL_IX(fun_val)((fun_val) & 0xFFFF), &fun_args[1], arg_count, ctx);
2963 break;
2964 case SYMBOL_KIND_APPFUN3:
2965 fun_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)](&fun_args[1], arg_count, ctx);
2966 break;
2967 default:
2968 // Symbols that are "special" but not in the way caught above
2969 // ends up here.
2970 lbm_set_error_reason("Symbol does not represent a function");
2971 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),fun_args[0]);
2972 break;
2973 }
2974}
2975
2976static void cont_closure_application_args(eval_context_t *ctx) {
2977 lbm_uint* sptr = get_stack_ptr(ctx, 5);
2978
2979 lbm_value arg_env = (lbm_value)sptr[0];
2980 lbm_value exp = (lbm_value)sptr[1];
2981 lbm_value clo_env = (lbm_value)sptr[2];
2982 lbm_value params = (lbm_value)sptr[3];
2983 lbm_value args = (lbm_value)sptr[4];
2984
2985 lbm_value car_params, cdr_params;
2986 get_car_and_cdr(params, &car_params, &cdr_params);
2987
2988 bool_Bool a_nil = lbm_is_symbol_nil(args);
2989 bool_Bool p_nil = lbm_is_symbol_nil(cdr_params);
2990
2991 lbm_value binder = allocate_binding(car_params, ctx->r, clo_env);
2992
2993 if (!a_nil && !p_nil) {
2994 lbm_value car_args, cdr_args;
2995 get_car_and_cdr(args, &car_args, &cdr_args);
2996 sptr[2] = binder;
2997 sptr[3] = cdr_params;
2998 sptr[4] = cdr_args;
2999 stack_reserve(ctx,1)[0] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
3000 ctx->curr_exp = car_args;
3001 ctx->curr_env = arg_env;
3002 } else if (a_nil && p_nil) {
3003 // Arguments and parameters match up in number
3004 lbm_stack_drop(&ctx->K, 5);
3005 ctx->curr_env = binder;
3006 ctx->curr_exp = exp;
3007 } else if (p_nil) {
3008 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), binder);
3009 sptr[2] = rest_binder;
3010 sptr[3] = get_cdr(args);
3011 sptr[4] = get_car(rest_binder); // last element of rest_args so far
3012 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3013 ctx->curr_exp = get_car(args);
3014 ctx->curr_env = arg_env;
3015 } else {
3016 lbm_set_error_reason((char*)lbm_error_str_num_args);
3017 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
3018 }
3019}
3020
3021
3022static void cont_closure_args_rest(eval_context_t *ctx) {
3023 lbm_uint* sptr = get_stack_ptr(ctx, 5);
3024 lbm_value arg_env = (lbm_value)sptr[0];
3025 lbm_value exp = (lbm_value)sptr[1];
3026 lbm_value clo_env = (lbm_value)sptr[2];
3027 lbm_value args = (lbm_value)sptr[3];
3028 lbm_value last = (lbm_value)sptr[4];
3029 lbm_cons_t* heap = lbm_heap_state.heap;
3030
3031 lbm_value binding = lbm_heap_state.freelist;
3032 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3033 gc();
3034 binding = lbm_heap_state.freelist;
3035 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3036 }
3037 lbm_uint binding_ix = lbm_dec_ptr(binding);
3038 lbm_heap_state.freelist = heap[binding_ix].cdr;
3039 lbm_heap_state.num_alloc += 1;
3040 heap[binding_ix].car = ctx->r;
3041 heap[binding_ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3042
3043
3044 lbm_set_cdr(last, binding);
3045 sptr[4] = binding;
3046
3047 if (args == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3048 lbm_stack_drop(&ctx->K, 5);
3049 ctx->curr_env = clo_env;
3050 ctx->curr_exp = exp;
3051 } else {
3052 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3053 sptr[3] = get_cdr(args);
3054 ctx->curr_exp = get_car(args);
3055 ctx->curr_env = arg_env;
3056 }
3057}
3058
3059static void cont_application_args(eval_context_t *ctx) {
3060 lbm_uint *sptr = get_stack_ptr(ctx, 3);
3061
3062 lbm_value env = sptr[0];
3063 lbm_value rest = sptr[1];
3064 lbm_value count = sptr[2];
3065
3066 ctx->curr_env = env;
3067 sptr[0] = ctx->r; // Function 1st then Arguments
3068 if (lbm_is_cons(rest)) {
3069 lbm_cons_t *cell = lbm_ref_cell(rest);
3070 sptr[1] = env;
3071 sptr[2] = cell->cdr;
3072 lbm_value *rptr = stack_reserve(ctx,2);
3073 rptr[0] = count + (1 << LBM_VAL_SHIFT4);
3074 rptr[1] = APPLICATION_ARGS(((5) << 2) | 0xF8000001u);
3075 ctx->curr_exp = cell->car;
3076 } else {
3077 // No more arguments
3078 lbm_stack_drop(&ctx->K, 2);
3079 lbm_uint nargs = lbm_dec_u(count);
3080 lbm_value *args = get_stack_ptr(ctx, (uint32_t)(nargs + 1));
3081 application(ctx,args, nargs);
3082 }
3083}
3084
3085static void cont_and(eval_context_t *ctx) {
3086 lbm_value env;
3087 lbm_value rest;
3088 lbm_value arg = ctx->r;
3089 lbm_pop_2(&ctx->K, &rest, &env);
3090 if (lbm_is_symbol_nil(arg)) {
3091 ctx->app_cont = true1;
3092 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3093 } else if (lbm_is_symbol_nil(rest)) {
3094 ctx->app_cont = true1;
3095 } else {
3096 lbm_value *sptr = stack_reserve(ctx, 3);
3097 sptr[0] = env;
3098 sptr[1] = get_cdr(rest);
3099 sptr[2] = AND(((6) << 2) | 0xF8000001u);
3100 ctx->curr_env = env;
3101 ctx->curr_exp = get_car(rest);
3102 }
3103}
3104
3105static void cont_or(eval_context_t *ctx) {
3106 lbm_value env;
3107 lbm_value rest;
3108 lbm_value arg = ctx->r;
3109 lbm_pop_2(&ctx->K, &rest, &env);
3110 if (!lbm_is_symbol_nil(arg)) {
3111 ctx->app_cont = true1;
3112 } else if (lbm_is_symbol_nil(rest)) {
3113 ctx->app_cont = true1;
3114 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3115 } else {
3116 lbm_value *sptr = stack_reserve(ctx, 3);
3117 sptr[0] = env;
3118 sptr[1] = get_cdr(rest);
3119 sptr[2] = OR(((7) << 2) | 0xF8000001u);
3120 ctx->curr_exp = get_car(rest);
3121 ctx->curr_env = env;
3122 }
3123}
3124
3125static int fill_binding_location(lbm_value key, lbm_value value, lbm_value env) {
3126 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) {
3127 if (key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return FB_OK0;
3128 lbm_env_modify_binding(env,key,value);
3129 return FB_OK0;
3130 } else if (lbm_is_cons(key) &&
3131 lbm_is_cons(value)) {
3132 int r = fill_binding_location(get_car(key), get_car(value), env);
3133 if (r == FB_OK0) {
3134 r = fill_binding_location(get_cdr(key), get_cdr(value), env);
3135 }
3136 return r;
3137 }
3138 return FB_TYPE_ERROR-1;
3139}
3140
3141static void cont_bind_to_key_rest(eval_context_t *ctx) {
3142
3143 lbm_value *sptr = get_stack_ptr(ctx, 4);
3144
3145 lbm_value rest = sptr[1];
3146 lbm_value env = sptr[2];
3147 lbm_value key = sptr[3];
3148
3149 if (fill_binding_location(key, ctx->r, env) < 0) {
3150 lbm_set_error_reason("Incorrect type of name/key in let-binding");
3151 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
3152 }
3153
3154 if (lbm_is_cons(rest)) {
3155 lbm_value car_rest = get_car(rest);
3156 lbm_value key_val[2];
3157 extract_n(car_rest, key_val, 2);
3158
3159 sptr[1] = get_cdr(rest);
3160 sptr[3] = key_val[0];
3161 stack_reserve(ctx,1)[0] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
3162 ctx->curr_exp = key_val[1];
3163 ctx->curr_env = env;
3164 } else {
3165 // Otherwise evaluate the expression in the populated env
3166 ctx->curr_exp = sptr[0];
3167 ctx->curr_env = env;
3168 lbm_stack_drop(&ctx->K, 4);
3169 }
3170}
3171
3172static void cont_if(eval_context_t *ctx) {
3173
3174 lbm_value arg = ctx->r;
3175
3176 lbm_value *sptr = pop_stack_ptr(ctx, 2);
3177
3178 ctx->curr_env = sptr[1];
3179 if (lbm_is_symbol_nil(arg)) {
3180 ctx->curr_exp = get_cadr(sptr[0]); // else branch
3181 } else {
3182 ctx->curr_exp = get_car(sptr[0]); // then branch
3183 }
3184}
3185
3186static void cont_match(eval_context_t *ctx) {
3187 lbm_value e = ctx->r;
3188 bool_Bool do_gc = false0;
3189
3190 lbm_uint *sptr = get_stack_ptr(ctx, 2);
3191 lbm_value patterns = (lbm_value)sptr[0];
3192 lbm_value orig_env = (lbm_value)sptr[1]; // restore enclosing environment.
3193 lbm_value new_env = orig_env;
3194
3195 if (lbm_is_symbol_nil(patterns)) {
3196 // no more patterns
3197 lbm_stack_drop(&ctx->K, 2);
3198 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
3199 ctx->app_cont = true1;
3200 } else if (lbm_is_cons(patterns)) {
3201 lbm_value match_case = get_car(patterns);
3202 lbm_value pattern = get_car(match_case);
3203 lbm_value n1 = get_cadr(match_case);
3204 lbm_value n2 = get_cadr(get_cdr(match_case));
3205 lbm_value body;
3206 bool_Bool check_guard = false0;
3207 if (lbm_is_symbol_nil(n2)) { // TODO: Not a very robust check.
3208 body = n1;
3209 } else {
3210 body = n2;
3211 check_guard = true1;
3212 }
3213
3214 bool_Bool is_match = match(pattern, e, &new_env, &do_gc);
3215 if (do_gc) {
3216 gc();
3217 do_gc = false0;
3218 new_env = orig_env;
3219 is_match = match(pattern, e, &new_env, &do_gc);
3220 if (do_gc) {
3221 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3222 }
3223 }
3224 if (is_match) {
3225 if (check_guard) {
3226 lbm_value *rptr = stack_reserve(ctx,5);
3227 sptr[0] = get_cdr(patterns);
3228 sptr[1] = ctx->curr_env;
3229 rptr[0] = MATCH(((9) << 2) | 0xF8000001u);
3230 rptr[1] = new_env;
3231 rptr[2] = body;
3232 rptr[3] = e;
3233 rptr[4] = MATCH_GUARD(((27) << 2) | 0xF8000001u);
3234 ctx->curr_env = new_env;
3235 ctx->curr_exp = n1; // The guard
3236 } else {
3237 lbm_stack_drop(&ctx->K, 2);
3238 ctx->curr_env = new_env;
3239 ctx->curr_exp = body;
3240 }
3241 } else {
3242 // set up for checking of next pattern
3243 sptr[0] = get_cdr(patterns);
3244 sptr[1] = orig_env;
3245 stack_reserve(ctx,1)[0] = MATCH(((9) << 2) | 0xF8000001u);
3246 // leave r unaltered
3247 ctx->app_cont = true1;
3248 }
3249 } else {
3250 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MATCH(((0x108) << 4) | 0x00000000u));
3251 }
3252}
3253
3254static void cont_exit_atomic(eval_context_t *ctx) {
3255 is_atomic --;
3256 ctx->app_cont = true1;
3257}
3258
3259static void cont_map(eval_context_t *ctx) {
3260 lbm_value *sptr = get_stack_ptr(ctx, 6);
3261
3262 lbm_value ls = sptr[0];
3263 lbm_value env = sptr[1];
3264 lbm_value t = sptr[3];
3265 lbm_set_car(t, ctx->r); // update car field tailmost position.
3266 if (lbm_is_cons(ls)) {
3267 lbm_value next, rest;
3268 get_car_and_cdr(ls, &next, &rest);
3269 sptr[0] = rest;
3270 stack_reserve(ctx,1)[0] = MAP(((26) << 2) | 0xF8000001u);
3271 lbm_set_car(sptr[5], next); // new arguments
3272
3273 lbm_value elt = cons_with_gc(ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3274 lbm_set_cdr(t, elt);
3275 sptr[3] = elt; // (r1 ... rN . (nil . nil))
3276 ctx->curr_exp = sptr[4];
3277 ctx->curr_env = env;
3278 } else {
3279 ctx->r = sptr[2]; //head of result list
3280 ctx->curr_env = env;
3281 lbm_stack_drop(&ctx->K, 6);
3282 ctx->app_cont = true1;
3283 }
3284}
3285
3286static void cont_match_guard(eval_context_t *ctx) {
3287 if (lbm_is_symbol_nil(ctx->r)) {
3288 lbm_value e;
3289 lbm_pop(&ctx->K, &e);
3290 lbm_stack_drop(&ctx->K, 2);
3291 ctx->r = e;
3292 ctx->app_cont = true1;
3293 } else {
3294 lbm_value body;
3295 lbm_value env;
3296 lbm_stack_drop(&ctx->K, 1);
3297 lbm_pop_2(&ctx->K, &body, &env);
3298 lbm_stack_drop(&ctx->K, 3);
3299 ctx->curr_env = env;
3300 ctx->curr_exp = body;
3301 }
3302}
3303
3304static void cont_terminate(eval_context_t *ctx) {
3305 error_ctx(ctx->r);
3306}
3307
3308static void cont_loop(eval_context_t *ctx) {
3309 lbm_value *sptr = get_stack_ptr(ctx, 2);
3310 stack_reserve(ctx,1)[0] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
3311 ctx->curr_exp = sptr[1];
3312}
3313
3314static void cont_loop_condition(eval_context_t *ctx) {
3315 if (lbm_is_symbol_nil(ctx->r)) {
3316 lbm_stack_drop(&ctx->K, 2);
3317 ctx->app_cont = true1; // A loop returns nil? Makes sense to me... but in general?
3318 return;
3319 }
3320 lbm_value *sptr = get_stack_ptr(ctx, 2);
3321 stack_reserve(ctx,1)[0] = LOOP(((41) << 2) | 0xF8000001u);
3322 ctx->curr_exp = sptr[0];
3323}
3324
3325static void cont_merge_rest(eval_context_t *ctx) {
3326 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3327
3328 // If comparator returns true (result is in ctx->r):
3329 // "a" should be moved to the last element position in merged list.
3330 // A new element from "a_rest" should be moved into comparator argument 1 pos.
3331 // else
3332 // "b" should be moved to last element position in merged list.
3333 // A new element from "b_rest" should be moved into comparator argument 2 pos.
3334 //
3335 // If a_rest or b_rest is NIL:
3336 // we are done, the remaining elements of
3337 // non_nil list should be appended to merged list.
3338 // else
3339 // Set up for a new comparator evaluation and recurse.
3340 lbm_value a = sptr[2];
3341 lbm_value b = lbm_cdr(a);
3342 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate 1 element list
3343
3344 if (ctx->r == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) { // Comparison false
3345
3346 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3347 sptr[0] = b;
3348 sptr[1] = b;
3349 } else {
3350 lbm_set_cdr(sptr[1], b);
3351 sptr[1] = b;
3352 }
3353 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3354 lbm_set_cdr(a, sptr[3]);
3355 lbm_set_cdr(sptr[1], a);
3356 ctx->r = sptr[0];
3357 lbm_stack_drop(&ctx->K, 9);
3358 ctx->app_cont = true1;
3359 return;
3360 } else {
3361 b = sptr[4];
3362 sptr[4] = lbm_cdr(sptr[4]);
3363 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3364 }
3365 } else {
3366 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3367 sptr[0] = a;
3368 sptr[1] = a;
3369 } else {
3370 lbm_set_cdr(sptr[1], a);
3371 sptr[1] = a;
3372 }
3373
3374 if (sptr[3] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3375 lbm_set_cdr(b, sptr[4]);
3376 lbm_set_cdr(sptr[1], b);
3377 ctx->r = sptr[0];
3378 lbm_stack_drop(&ctx->K, 9);
3379 ctx->app_cont = true1;
3380 return;
3381 } else {
3382 a = sptr[3];
3383 sptr[3] = lbm_cdr(sptr[3]);
3384 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3385 }
3386 }
3387 lbm_set_cdr(a, b);
3388 sptr[2] = a;
3389
3390 lbm_value par1 = sptr[7];
3391 lbm_value par2 = sptr[8];
3392 lbm_value cmp_body = sptr[5];
3393 lbm_value cmp_env = sptr[6];
3394 // Environment should be preallocated already at this point
3395 // and the operations below should never need GC.
3396 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3397 lbm_value new_env = lbm_env_set(new_env0, par2, lbm_car(b));
3398 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3399 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3400 }
3401 cmp_env = new_env;
3402
3403 stack_reserve(ctx,1)[0] = MERGE_REST(((43) << 2) | 0xF8000001u);
3404 ctx->curr_exp = cmp_body;
3405 ctx->curr_env = cmp_env;
3406}
3407
3408// merge_layer stack contents
3409// s[sp-9] = cmp
3410// s[sp-8] = cmp_env
3411// s[sp-7] = par1
3412// s[sp-6] = par2
3413// s[sp-5] = acc - first cell
3414// s[sp-4] = acc - last cell
3415// s[sp-3] = rest;
3416// s[sp-2] = layer
3417// s[sp-1] = length or original list
3418//
3419// ctx->r merged sublist
3420static void cont_merge_layer(eval_context_t *ctx) {
3421 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3422 lbm_int layer = lbm_dec_i(sptr[7]);
3423 lbm_int len = lbm_dec_i(sptr[8]);
3424
3425 lbm_value r_curr = ctx->r;
3426 while (lbm_is_cons(r_curr)) {
3427 lbm_value next = lbm_cdr(r_curr);
3428 if (next == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3429 break;
3430 }
3431 r_curr = next;
3432 }
3433
3434 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3435 sptr[4] = ctx->r;
3436 sptr[5] = r_curr;
3437 } else {
3438 lbm_set_cdr(sptr[5], ctx->r); // accumulate merged sublists.
3439 sptr[5] = r_curr;
3440 }
3441
3442 lbm_value layer_rest = sptr[6];
3443 // switch layer or done ?
3444 if (layer_rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3445 if (layer * 2 >= len) {
3446 ctx->r = sptr[4];
3447 ctx->app_cont = true1;
3448 lbm_stack_drop(&ctx->K, 9);
3449 return;
3450 } else {
3451 // Setup for merges of the next layer
3452 layer = layer * 2;
3453 sptr[7] = lbm_enc_i(layer);
3454 layer_rest = sptr[4]; // continue on the accumulation of all sublists.
3455 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3456 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3457 }
3458 }
3459 // merge another sublist based on current layer.
3460 lbm_value a_list = layer_rest;
3461 // build sublist a
3462 lbm_value curr = layer_rest;
3463 for (int i = 0; i < layer-1; i ++) {
3464 if (lbm_is_cons(curr)) {
3465 curr = lbm_cdr(curr);
3466 } else {
3467 break;
3468 }
3469 }
3470 layer_rest = lbm_cdr(curr);
3471 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3472
3473 lbm_value b_list = layer_rest;
3474 // build sublist b
3475 curr = layer_rest;
3476 for (int i = 0; i < layer-1; i ++) {
3477 if (lbm_is_cons(curr)) {
3478 curr = lbm_cdr(curr);
3479 } else {
3480 break;
3481 }
3482 }
3483 layer_rest = lbm_cdr(curr);
3484 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3485
3486 sptr[6] = layer_rest;
3487
3488 if (b_list == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3489 stack_reserve(ctx,1)[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3490 ctx->r = a_list;
3491 ctx->app_cont = true1;
3492 return;
3493 }
3494 // Set up for a merge of sublists.
3495
3496 lbm_value a_rest = lbm_cdr(a_list);
3497 lbm_value b_rest = lbm_cdr(b_list);
3498 lbm_value a = a_list;
3499 lbm_value b = b_list;
3500 lbm_set_cdr(a, b);
3501 // Terminating the b list would be incorrect here
3502 // if there was any chance that the environment update below
3503 // performs GC.
3504 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3505
3506 lbm_value cmp_body = sptr[0];
3507 lbm_value cmp_env = sptr[1];
3508 lbm_value par1 = sptr[2];
3509 lbm_value par2 = sptr[3];
3510 // Environment should be preallocated already at this point
3511 // and the operations below should never need GC.
3512 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3513 lbm_value new_env = lbm_env_set(cmp_env, par2, lbm_car(b));
3514 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3515 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3516 }
3517 cmp_env = new_env;
3518
3519 lbm_uint *merge_cont = stack_reserve(ctx, 11);
3520 merge_cont[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3521 merge_cont[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3522 merge_cont[2] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3523 merge_cont[3] = a;
3524 merge_cont[4] = a_rest;
3525 merge_cont[5] = b_rest;
3526 merge_cont[6] = cmp_body;
3527 merge_cont[7] = cmp_env;
3528 merge_cont[8] = par1;
3529 merge_cont[9] = par2;
3530 merge_cont[10] = MERGE_REST(((43) << 2) | 0xF8000001u);
3531 ctx->curr_exp = cmp_body;
3532 ctx->curr_env = cmp_env;
3533 return;
3534}
3535
3536/****************************************************/
3537/* READER */
3538
3539static void read_finish(lbm_char_channel_t *str, eval_context_t *ctx) {
3540
3541 /* Tokenizer reached "end of file"
3542 The parser could be in a state where it needs
3543 more tokens to correctly finish an expression.
3544
3545 Three cases
3546 1. The program / expression is malformed and the context should die.
3547 2. We are finished reading a program and should close off the
3548 internal representation with a closing parenthesis. Then
3549 apply continuation.
3550 3. We are finished reading an expression and should
3551 apply the continuation.
3552
3553 In case 3, we should find the READ_DONE at sp - 1.
3554 In case 2, we should find the READ_DONE at sp - 5.
3555
3556 */
3557
3558 if (lbm_is_symbol(ctx->r)) {
3559 lbm_uint sym_val = lbm_dec_sym(ctx->r);
3560 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
3561 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
3562 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3563 }
3564 }
3565
3566 if (ctx->K.data[ctx->K.sp-1] == READ_DONE(((20) << 2) | 0xF8000001u) &&
3567 lbm_dec_u(ctx->K.data[ctx->K.sp-3]) == 0) {
3568 /* successfully finished reading an expression (CASE 3) */
3569 ctx->app_cont = true1;
3570 } else if (ctx->K.sp > 4 && ctx->K.data[ctx->K.sp - 4] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3571 lbm_value env;
3572 lbm_value s;
3573 lbm_value sym;
3574 lbm_pop_3(&ctx->K, &sym, &env, &s);
3575 ctx->curr_env = env;
3576 ctx->app_cont = true1; // Program evaluated and result is in ctx->r.
3577 } else if (ctx->K.sp > 5 && ctx->K.data[ctx->K.sp - 5] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3578 /* successfully finished reading a program (CASE 2) */
3579 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3580 ctx->app_cont = true1;
3581 } else {
3582 /* Parsing failed */
3583 if (lbm_channel_row(str) == 1 &&
3584 lbm_channel_column(str) == 1 ){
3585 // eof at empty stream.
3586 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3587 ctx->app_cont = true1;
3588 } else {
3589 lbm_set_error_reason((char*)lbm_error_str_parse_eof);
3590 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3591 }
3592 lbm_channel_reader_close(str);
3593 }
3594}
3595
3596/* cont_read_next_token
3597 sp-2 : Stream
3598 sp-1 : Grab row
3599*/
3600static void cont_read_next_token(eval_context_t *ctx) {
3601 lbm_value *sptr = get_stack_ptr(ctx, 2);
3602 lbm_value stream = sptr[0];
3603 lbm_value grab_row0 = sptr[1];
3604
3605 lbm_char_channel_t *chan = lbm_dec_channel(stream);
3606 if (chan == NULL((void*)0) || chan->state == NULL((void*)0)) {
3607 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3608 }
3609
3610 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3611 lbm_stack_drop(&ctx->K, 2);
3612 read_finish(chan, ctx);
3613 return;
3614 }
3615 /* Eat whitespace and comments */
3616 if (!tok_clean_whitespace(chan)) {
3617 sptr[0] = stream;
3618 sptr[1] = lbm_enc_u(0);
3619 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3620 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3621 return;
3622 }
3623 /* After eating whitespace we may be at end of file/stream */
3624 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3625 lbm_stack_drop(&ctx->K, 2);
3626 read_finish(chan, ctx);
3627 return;
3628 }
3629
3630 if (lbm_dec_u(grab_row0)) {
3631 ctx->row0 = (int32_t)lbm_channel_row(chan);
3632 }
3633
3634 /* Attempt to extract tokens from the character stream */
3635 int n = 0;
3636 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3637 unsigned int string_len = 0;
3638
3639 /*
3640 * SYNTAX
3641 */
3642 uint32_t match;
3643 n = tok_syntax(chan, &match);
3644 if (n > 0) {
3645 if (!lbm_channel_drop(chan, (unsigned int)n)) {
3646 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3647 }
3648 ctx->app_cont = true1;
3649 lbm_uint do_next = 0;
3650 switch(match) {
3651 case TOKOPENPAR1u: {
3652 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3653 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3654 lbm_value *rptr = stack_reserve(ctx,5);
3655 rptr[0] = stream;
3656 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3657 rptr[2] = stream;
3658 rptr[3] = lbm_enc_u(0);
3659 rptr[4] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3660 ctx->r = ENC_SYM_OPENPAR(((0x70) << 4) | 0x00000000u);
3661 } return;
3662 case TOKCLOSEPAR2u: {
3663 lbm_stack_drop(&ctx->K, 2);
3664 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3665 } return;
3666 case TOKOPENBRACK3u: {
3667 sptr[0] = stream;
3668 sptr[1] = READ_START_ARRAY(((24) << 2) | 0xF8000001u);
3669 lbm_value *rptr = stack_reserve(ctx, 3);
3670 rptr[0] = stream;
3671 rptr[1] = lbm_enc_u(0);
3672 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3673 ctx->r = ENC_SYM_OPENBRACK(((0x80) << 4) | 0x00000000u);
3674 } return;
3675 case TOKCLOSEBRACK4u:
3676 lbm_stack_drop(&ctx->K, 2);
3677 ctx->r = ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u);
3678 return;
3679 case TOKDOT5u:
3680 lbm_stack_drop(&ctx->K, 2);
3681 ctx->r = ENC_SYM_DOT(((0x76) << 4) | 0x00000000u);
3682 return;
3683 case TOKDONTCARE6u:
3684 lbm_stack_drop(&ctx->K, 2);
3685 ctx->r = ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u);
3686 return;
3687 case TOKQUOTE7u:
3688 do_next = READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u);
3689 break;
3690 case TOKBACKQUOTE8u: {
3691 sptr[0] = QQ_EXPAND_START(((35) << 2) | 0xF8000001u);
3692 sptr[1] = stream;
3693 lbm_value *rptr = stack_reserve(ctx, 2);
3694 rptr[0] = lbm_enc_u(0);
3695 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3696 ctx->app_cont = true1;
3697 } return;
3698 case TOKCOMMAAT9u:
3699 do_next = READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u);
3700 break;
3701 case TOKCOMMA10u:
3702 do_next = READ_COMMA_RESULT(((23) << 2) | 0xF8000001u);
3703 break;
3704 case TOKMATCHANY11u:
3705 lbm_stack_drop(&ctx->K, 2);
3706 ctx->r = ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u);
3707 return;
3708 case TOKOPENCURL12u: {
3709 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3710 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3711 lbm_value *rptr = stack_reserve(ctx,2);
3712 rptr[0] = stream;
3713 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3714 ctx->r = ENC_SYM_PROGN(((0x102) << 4) | 0x00000000u);
3715 } return;
3716 case TOKCLOSECURL13u:
3717 lbm_stack_drop(&ctx->K, 2);
3718 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3719 return;
3720 case TOKCONSTSTART14u: /* fall through */
3721 case TOKCONSTEND15u:
3722 case TOKCONSTSYMSTR16u: {
3723 if (match == TOKCONSTSTART14u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3724 if (match == TOKCONSTEND15u) ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3725 if (match == TOKCONSTSYMSTR16u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04;
3726 sptr[0] = stream;
3727 sptr[1] = lbm_enc_u(0);
3728 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3729 ctx->app_cont = true1;
3730 } return;
3731 default:
3732 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3733 }
3734 sptr[0] = do_next;
3735 sptr[1] = stream;
3736 lbm_value *rptr = stack_reserve(ctx, 2);
3737 rptr[0] = lbm_enc_u(0);
3738 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3739 ctx->app_cont = true1;
3740 return;
3741 } else if (n < 0) goto retry_token;
3742
3743 /*
3744 * STRING
3745 */
3746 n = tok_string(chan, &string_len);
3747 if (n >= 2) {
3748 lbm_channel_drop(chan, (unsigned int)n);
3749 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3750 gc();
3751 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3752 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3753 return; // dead return but static analysis does not know that.
3754 }
3755 }
3756 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(res);
3757 char *data = (char*)arr->data;
3758 memset(data,0, string_len + 1);
3759 memcpy(data, tokpar_sym_str, string_len);
3760 lbm_stack_drop(&ctx->K, 2);
3761 ctx->r = res;
3762 ctx->app_cont = true1;
3763 return;
3764 } else if (n < 0) goto retry_token;
3765
3766 /*
3767 * FLOAT
3768 */
3769 token_float f_val;
3770 n = tok_double(chan, &f_val);
3771 if (n > 0) {
3772 lbm_channel_drop(chan, (unsigned int) n);
3773 switch(f_val.type) {
3774 case TOKTYPEF32107u:
3775 WITH_GC(res, lbm_enc_float((float)f_val.value))(res) = (lbm_enc_float((float)f_val.value)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (lbm_enc_float((float)f_val.value));
if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
3776 break;
3777 case TOKTYPEF64108u:
3778 res = lbm_enc_double(f_val.value);
3779 break;
3780 default:
3781 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3782 }
3783 lbm_stack_drop(&ctx->K, 2);
3784 ctx->r = res;
3785 ctx->app_cont = true1;
3786 return;
3787 } else if (n < 0) goto retry_token;
3788
3789 /*
3790 * INTEGER
3791 */
3792 token_int int_result;
3793 n = tok_integer(chan, &int_result);
3794 if (n > 0) {
3795 lbm_channel_drop(chan, (unsigned int)n);
3796 switch(int_result.type) {
3797 case TOKTYPEBYTE100u:
3798 res = lbm_enc_char((uint8_t)(int_result.negative ? -int_result.value : int_result.value));
3799 break;
3800 case TOKTYPEI101u:
3801 res = lbm_enc_i((lbm_int)(int_result.negative ? -int_result.value : int_result.value));
3802 break;
3803 case TOKTYPEU102u:
3804 res = lbm_enc_u((lbm_uint)(int_result.negative ? -int_result.value : int_result.value));
3805 break;
3806 case TOKTYPEI32103u:
3807 WITH_GC(res, lbm_enc_i32((int32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i32((int32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i32((int32_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3808 break;
3809 case TOKTYPEU32104u:
3810 WITH_GC(res,lbm_enc_u32((uint32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u32((uint32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u32((uint32_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3811 break;
3812 case TOKTYPEI64105u:
3813 WITH_GC(res,lbm_enc_i64((int64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i64((int64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i64((int64_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3814 break;
3815 case TOKTYPEU64106u:
3816 WITH_GC(res,lbm_enc_u64((uint64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u64((uint64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u64((uint64_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3817 break;
3818 default:
3819 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3820 }
3821 lbm_stack_drop(&ctx->K, 2);
3822 ctx->r = res;
3823 ctx->app_cont = true1;
3824 return;
3825 } else if (n < 0) goto retry_token;
3826
3827 /*
3828 * SYMBOL
3829 */
3830 n = tok_symbol(chan);
3831 if (n > 0) {
3832 lbm_channel_drop(chan, (unsigned int) n);
3833 lbm_uint symbol_id;
3834 if (lbm_get_symbol_by_name(tokpar_sym_str, &symbol_id)) {
3835 res = lbm_enc_sym(symbol_id);
3836 } else {
3837 int r = 0;
3838 if (n > 4 &&
3839 tokpar_sym_str[0] == 'e' &&
3840 tokpar_sym_str[1] == 'x' &&
3841 tokpar_sym_str[2] == 't' &&
3842 tokpar_sym_str[3] == '-') {
3843 lbm_uint ext_id;
3844 lbm_uint ext_name_len = (lbm_uint)n + 1;
3845 char *ext_name = lbm_malloc(ext_name_len);
3846 if (!ext_name) {
3847 gc();
3848 ext_name = lbm_malloc(ext_name_len);
3849 }
3850 if (ext_name) {
3851 memcpy(ext_name, tokpar_sym_str, ext_name_len);
3852 r = lbm_add_extension(ext_name, lbm_extensions_default);
3853 if (!lbm_lookup_extension_id(ext_name, &ext_id)) {
3854 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3855 }
3856 symbol_id = ext_id;
3857 } else {
3858 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3859 }
3860 } else {
3861 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04 &&
3862 ctx->flags & EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08) {
3863 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id, true1); //flash
3864 if (!r) {
3865 lbm_set_error_reason((char*)lbm_error_str_flash_error);
3866 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3867 }
3868 } else {
3869 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3870 if (!r) {
3871 gc();
3872 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3873 }
3874 }
3875 }
3876 if (r) {
3877 res = lbm_enc_sym(symbol_id);
3878 } else {
3879 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3880 }
3881 }
3882 lbm_stack_drop(&ctx->K, 2);
3883 ctx->r = res;
3884 ctx->app_cont = true1;
3885 return;
3886 } else if (n == TOKENIZER_NEED_MORE-1) {
3887 goto retry_token;
3888 } else if (n <= TOKENIZER_STRING_ERROR-2) {
3889 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3890 }
3891
3892 /*
3893 * CHAR
3894 */
3895 char c_val;
3896 n = tok_char(chan, &c_val);
3897 if(n > 0) {
3898 lbm_channel_drop(chan,(unsigned int) n);
3899 lbm_stack_drop(&ctx->K, 2);
3900 ctx->r = lbm_enc_char((uint8_t)c_val);
3901 ctx->app_cont = true1;
3902 return;
3903 }else if (n < 0) goto retry_token;
3904
3905 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3906
3907 retry_token:
3908 if (n == TOKENIZER_NEED_MORE-1) {
3909 sptr[0] = stream;
3910 sptr[1] = lbm_enc_u(0);
3911 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3912 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3913 return;
3914 }
3915 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3916}
3917
3918static void cont_read_start_array(eval_context_t *ctx) {
3919 lbm_value *sptr = get_stack_ptr(ctx, 1);
3920 lbm_value stream = sptr[0];
3921
3922 lbm_char_channel_t *str = lbm_dec_channel(stream);
3923 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
3924 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3925 }
3926
3927 lbm_uint num_free = lbm_memory_longest_free();
3928 lbm_uint initial_size = (lbm_uint)((float)num_free * 0.9);
3929 if (initial_size == 0) {
3930 gc();
3931 num_free = lbm_memory_longest_free();
3932 initial_size = (lbm_uint)((float)num_free * 0.9);
3933 if (initial_size == 0) {
3934 lbm_channel_reader_close(str);
3935 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3936 }
3937 }
3938
3939 if (lbm_is_number(ctx->r)) {
3940 lbm_value array;
3941 initial_size = sizeof(lbm_uint) * initial_size;
3942
3943 if (!lbm_heap_allocate_array(&array, initial_size)) {
3944 lbm_set_error_reason("Out of memory while reading.");
3945 lbm_channel_reader_close(str);
3946 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3947 // NOTE: If array is not created evaluation ends here.
3948 // Static analysis seems unaware.
3949 }
3950
3951 sptr[0] = array;
3952 lbm_value *rptr = stack_reserve(ctx, 4);
3953 rptr[0] = lbm_enc_u(initial_size);
3954 rptr[1] = lbm_enc_u(0);
3955 rptr[2] = stream;
3956 rptr[3] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3957 ctx->app_cont = true1;
3958 } else {
3959 lbm_channel_reader_close(str);
3960 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3961 }
3962}
3963
3964static void cont_read_append_array(eval_context_t *ctx) {
3965 lbm_uint *sptr = get_stack_ptr(ctx, 4);
3966
3967 lbm_value array = sptr[0];
3968 lbm_value size = lbm_dec_as_u32(sptr[1]);
3969 lbm_value ix = lbm_dec_as_u32(sptr[2]);
3970 lbm_value stream = sptr[3];
3971
3972 if (ix >= (size - 1)) {
3973 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3974 }
3975
3976 // get_car can return nil. Whose value is 0!
3977 // So static Analysis is right about this being a potential NULL pointer.
3978 // However, if the array was created correcly to begin with, it should be fine.
3979 lbm_value arr_car = get_car(array);
3980 lbm_array_header_t *arr = (lbm_array_header_t*)arr_car;
3981
3982 if (lbm_is_number(ctx->r)) {
3983 ((uint8_t*)arr->data)[ix] = (uint8_t)lbm_dec_as_u32(ctx->r);
3984
3985 sptr[2] = lbm_enc_u(ix + 1);
3986 lbm_value *rptr = stack_reserve(ctx, 4);
3987 rptr[0] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3988 rptr[1] = stream;
3989 rptr[2] = lbm_enc_u(0);
3990 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3991 ctx->app_cont = true1;
3992 } else if (lbm_is_symbol(ctx->r) && ctx->r == ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u)) {
3993 lbm_uint array_size = ix / sizeof(lbm_uint);
3994
3995 if (ix % sizeof(lbm_uint) != 0) {
3996 array_size = array_size + 1;
3997 }
3998 lbm_memory_shrink((lbm_uint*)arr->data, array_size);
3999 arr->size = ix;
4000 lbm_stack_drop(&ctx->K, 4);
4001 ctx->r = array;
4002 ctx->app_cont = true1;
4003 } else {
4004 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
4005 }
4006}
4007
4008static void cont_read_append_continue(eval_context_t *ctx) {
4009 lbm_value *sptr = get_stack_ptr(ctx, 3);
4010
4011 lbm_value first_cell = sptr[0];
4012 lbm_value last_cell = sptr[1];
4013 lbm_value stream = sptr[2];
4014
4015 lbm_char_channel_t *str = lbm_dec_channel(stream);
4016 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4017 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4018 }
4019
4020 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4021
4022 switch(ctx->r) {
4023 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4024 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4025 lbm_set_cdr(last_cell, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate the list
4026 ctx->r = first_cell;
4027 } else {
4028 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4029 }
4030 lbm_stack_drop(&ctx->K, 3);
4031 /* Skip reading another token and apply the continuation */
4032 ctx->app_cont = true1;
4033 return;
4034 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4035 lbm_value *rptr = stack_reserve(ctx, 4);
4036 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4037 rptr[1] = stream;
4038 rptr[2] = lbm_enc_u(0);
4039 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4040 ctx->app_cont = true1;
4041 } return;
4042 }
4043 }
4044 lbm_value new_cell = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4045 if (lbm_is_symbol_merror(new_cell)) {
4046 lbm_channel_reader_close(str);
4047 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4048 return;
4049 }
4050 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4051 lbm_set_cdr(last_cell, new_cell);
4052 last_cell = new_cell;
4053 } else {
4054 first_cell = last_cell = new_cell;
4055 }
4056 sptr[0] = first_cell;
4057 sptr[1] = last_cell;
4058 sptr[2] = stream; // unchanged.
4059 lbm_value *rptr = stack_reserve(ctx, 4);
4060 rptr[0] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
4061 rptr[1] = stream;
4062 rptr[2] = lbm_enc_u(0);
4063 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4064 ctx->app_cont = true1;
4065}
4066
4067static void cont_read_eval_continue(eval_context_t *ctx) {
4068 lbm_value env;
4069 lbm_value stream;
4070 lbm_pop_2(&ctx->K, &env, &stream);
4071
4072 lbm_char_channel_t *str = lbm_dec_channel(stream);
4073 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4074 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4075 }
4076
4077 ctx->row1 = (lbm_int)str->row(str);
4078
4079 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4080
4081 switch(ctx->r) {
4082 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4083 ctx->app_cont = true1;
4084 return;
4085 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4086 // This case is a bit mysterious.
4087 // A dot, may in reality be an error in this location.
4088 lbm_value *rptr = stack_reserve(ctx, 4);
4089 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4090 rptr[1] = stream;
4091 rptr[2] = lbm_enc_u(0);
4092 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4093 ctx->app_cont = true1;
4094 } return;
4095 }
4096 }
4097
4098 lbm_value *rptr = stack_reserve(ctx, 6);
4099 rptr[0] = stream;
4100 rptr[1] = env;
4101 rptr[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
4102 rptr[3] = stream;
4103 rptr[4] = lbm_enc_u(1);
4104 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4105 rptr[6] = lbm_enc_u(ctx->flags);
4106 rptr[7] = POP_READER_FLAGS(((47) << 2) | 0xF8000001u);
4107 ctx->curr_env = env;
4108 ctx->curr_exp = ctx->r;
4109}
4110
4111static void cont_read_expect_closepar(eval_context_t *ctx) {
4112 lbm_value res;
4113 lbm_value stream;
4114
4115 lbm_pop_2(&ctx->K, &res, &stream);
4116
4117 lbm_char_channel_t *str = lbm_dec_channel(stream);
4118 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4119 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4120 }
4121
4122 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4123 ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u)) {
4124 ctx->r = res;
4125 ctx->app_cont = true1;
4126 } else {
4127 lbm_channel_reader_close(str);
4128 lbm_set_error_reason((char*)lbm_error_str_parse_close);
4129 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4130 }
4131}
4132
4133static void cont_read_dot_terminate(eval_context_t *ctx) {
4134 lbm_value *sptr = get_stack_ptr(ctx, 3);
4135
4136 lbm_value first_cell = sptr[0];
4137 lbm_value last_cell = sptr[1];
4138 lbm_value stream = sptr[2];
4139
4140 lbm_char_channel_t *str = lbm_dec_channel(stream);
4141 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4142 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4143 }
4144
4145 lbm_stack_drop(&ctx->K ,3);
4146
4147 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4148 (ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u) ||
4149 ctx->r == ENC_SYM_DOT(((0x76) << 4) | 0x00000000u))) {
4150 lbm_channel_reader_close(str);
4151 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4152 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4153 } else {
4154 if (lbm_is_cons(last_cell)) {
4155 lbm_set_cdr(last_cell, ctx->r);
4156 ctx->r = first_cell;
4157 lbm_value *rptr = stack_reserve(ctx, 6);
4158 rptr[0] = stream;
4159 rptr[1] = ctx->r;
4160 rptr[2] = READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u);
4161 rptr[3] = stream;
4162 rptr[4] = lbm_enc_u(0);
4163 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4164 ctx->app_cont = true1;
4165 } else {
4166 lbm_channel_reader_close(str);
4167 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4168 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4169 }
4170 }
4171}
4172
4173static void cont_read_done(eval_context_t *ctx) {
4174 lbm_value stream;
4175 lbm_value f_val;
4176 lbm_pop_2(&ctx->K, &stream ,&f_val);
4177
4178 uint32_t flags = lbm_dec_as_u32(f_val);
4179 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4180 ctx->flags |= (flags & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4181
4182 lbm_char_channel_t *str = lbm_dec_channel(stream);
4183 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4184 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4185 }
4186
4187 lbm_channel_reader_close(str);
4188 if (lbm_is_symbol(ctx->r)) {
4189 lbm_uint sym_val = lbm_dec_sym(ctx->r);
4190 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
4191 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
4192 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4193 }
4194 }
4195
4196 ctx->row0 = -1;
4197 ctx->row1 = -1;
4198 ctx->app_cont = true1;
4199}
4200
4201static void cont_read_quote_result(eval_context_t *ctx) {
4202 lbm_value cell;
4203 WITH_GC(cell, lbm_heap_allocate_list_init(2,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4204 ENC_SYM_QUOTE,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4205 ctx->r))(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
};
4206 ctx->r = cell;
4207 ctx->app_cont = true1;
4208}
4209
4210static void cont_read_commaat_result(eval_context_t *ctx) {
4211 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4212 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4213 ctx->r = cell1;
4214 ctx->app_cont = true1;
4215}
4216
4217static void cont_read_comma_result(eval_context_t *ctx) {
4218 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u),ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4219 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4220 ctx->r = cell1;
4221 ctx->app_cont = true1;
4222}
4223
4224static void cont_application_start(eval_context_t *ctx) {
4225
4226 /* sptr[0] = env
4227 * sptr[1] = args
4228 * ctx->r = function
4229 */
4230
4231 if (lbm_is_symbol(ctx->r)) {
4232 stack_reserve(ctx,1)[0] = lbm_enc_u(0);
4233 cont_application_args(ctx);
4234 } else if (lbm_is_cons(ctx->r)) {
4235 lbm_uint *sptr = get_stack_ptr(ctx, 2);
4236 lbm_value args = (lbm_value)sptr[1];
4237 switch (get_car(ctx->r)) {
4238 case ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u): {
4239 lbm_value cl[3];
4240 extract_n(get_cdr(ctx->r), cl, 3);
4241 lbm_value arg_env = (lbm_value)sptr[0];
4242 lbm_value arg0, arg_rest;
4243 get_car_and_cdr(args, &arg0, &arg_rest);
4244 sptr[1] = cl[CLO_BODY1];
4245 bool_Bool a_nil = lbm_is_symbol_nil(args);
4246 bool_Bool p_nil = lbm_is_symbol_nil(cl[CLO_PARAMS0]);
4247 lbm_value *reserved = stack_reserve(ctx, 4);
4248
4249 if (!a_nil && !p_nil) {
4250 reserved[0] = cl[CLO_ENV2];
4251 reserved[1] = cl[CLO_PARAMS0];
4252 reserved[2] = arg_rest;
4253 reserved[3] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
4254 ctx->curr_exp = arg0;
4255 ctx->curr_env = arg_env;
4256 } else if (a_nil && p_nil) {
4257 // No params, No args
4258 lbm_stack_drop(&ctx->K, 6);
4259 ctx->curr_exp = cl[CLO_BODY1];
4260 ctx->curr_env = cl[CLO_ENV2];
4261 } else if (p_nil) {
4262 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), cl[CLO_ENV2]);
4263 reserved[0] = rest_binder;
4264 reserved[1] = get_cdr(args);
4265 reserved[2] = get_car(rest_binder);
4266 reserved[3] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
4267 ctx->curr_exp = get_car(args);
4268 ctx->curr_env = arg_env;
4269 } else {
4270 lbm_set_error_reason((char*)lbm_error_str_num_args);
4271 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->r);
4272 }
4273 } break;
4274 case ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u):{
4275 /* Continuation created using call-cc.
4276 * ((SYM_CONT . cont-array) arg0 )
4277 */
4278 lbm_value c = get_cdr(ctx->r); /* should be the continuation array*/
4279
4280 if (!lbm_is_lisp_array_r(c)) {
4281 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4282 }
4283
4284 lbm_uint arg_count = lbm_list_length(args);
4285 lbm_value arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4286 switch (arg_count) {
4287 case 0:
4288 arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4289 break;
4290 case 1:
4291 arg = get_car(args);
4292 break;
4293 default:
4294 lbm_set_error_reason((char*)lbm_error_str_num_args);
4295 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4296 }
4297 lbm_stack_clear(&ctx->K);
4298
4299 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(c);
4300
4301 ctx->K.sp = arr->size / sizeof(lbm_uint);
4302 memcpy(ctx->K.data, arr->data, arr->size);
4303
4304 ctx->curr_exp = arg;
4305 break;
4306 }
4307 case ENC_SYM_MACRO(((0x10D) << 4) | 0x00000000u):{
4308 /*
4309 * Perform macro expansion.
4310 * Macro expansion is really just evaluation in an
4311 * environment augmented with the unevaluated expressions passed
4312 * as arguments.
4313 */
4314 lbm_value env = (lbm_value)sptr[0];
4315
4316 lbm_value curr_param = get_cadr(ctx->r);
4317 lbm_value curr_arg = args;
4318 lbm_value expand_env = env;
4319 while (lbm_is_cons(curr_param) &&
4320 lbm_is_cons(curr_arg)) {
4321 lbm_value car_curr_param, cdr_curr_param;
4322 lbm_value car_curr_arg, cdr_curr_arg;
4323 get_car_and_cdr(curr_param, &car_curr_param, &cdr_curr_param);
4324 get_car_and_cdr(curr_arg, &car_curr_arg, &cdr_curr_arg);
4325
4326 lbm_value entry = cons_with_gc(car_curr_param, car_curr_arg, expand_env);
4327 lbm_value aug_env = cons_with_gc(entry, expand_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4328 expand_env = aug_env;
4329
4330 curr_param = cdr_curr_param;
4331 curr_arg = cdr_curr_arg;
4332 }
4333 /* Two rounds of evaluation is performed.
4334 * First to instantiate the arguments into the macro body.
4335 * Second to evaluate the resulting program.
4336 */
4337 sptr[1] = EVAL_R(((11) << 2) | 0xF8000001u);
4338 lbm_value exp = get_cadr(get_cdr(ctx->r));
4339 ctx->curr_exp = exp;
4340 ctx->curr_env = expand_env;
4341 } break;
4342 default:
4343 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4344 }
4345 } else {
4346 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4347 }
4348}
4349
4350static void cont_eval_r(eval_context_t* ctx) {
4351 lbm_value env;
4352 lbm_pop(&ctx->K, &env);
4353 ctx->curr_exp = ctx->r;
4354 ctx->curr_env = env;
4355}
4356
4357static void cont_progn_var(eval_context_t* ctx) {
4358
4359 lbm_value key;
4360 lbm_value env;
4361
4362 lbm_pop_2(&ctx->K, &key, &env);
4363
4364 if (fill_binding_location(key, ctx->r, env) < 0) {
4365 lbm_set_error_reason("Incorrect type of name/key in let-binding");
4366 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
4367 }
4368
4369 ctx->app_cont = true1;
4370}
4371
4372static void cont_setq(eval_context_t *ctx) {
4373 lbm_value sym;
4374 lbm_value env;
4375 lbm_pop_2(&ctx->K, &sym, &env);
4376 lbm_value res;
4377 WITH_GC(res, perform_setvar(sym, ctx->r, env))(res) = (perform_setvar(sym, ctx->r, env)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (perform_setvar(sym, ctx->r, env)
); if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
4378 ctx->r = res;
4379 ctx->app_cont = true1;
4380}
4381
4382lbm_flash_status request_flash_storage_cell(lbm_value val, lbm_value *res) {
4383
4384 lbm_value flash_cell;
4385 lbm_flash_status s = lbm_allocate_const_cell(&flash_cell);
4386 if (s != LBM_FLASH_WRITE_OK)
4387 return s;
4388 lbm_value new_val = val;
4389 new_val &= ~LBM_PTR_VAL_MASK0x03FFFFFCu; // clear the value part of the ptr
4390 new_val |= (flash_cell & LBM_PTR_VAL_MASK0x03FFFFFCu);
4391 new_val |= LBM_PTR_TO_CONSTANT_BIT0x04000000u;
4392 *res = new_val;
4393 return s;
4394}
4395
4396static void cont_move_to_flash(eval_context_t *ctx) {
4397
4398 lbm_value args;
4399 lbm_pop(&ctx->K, &args);
4400
4401 if (lbm_is_symbol_nil(args)) {
4402 // Done looping over arguments. return true.
4403 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
4404 ctx->app_cont = true1;
4405 return;
4406 }
4407
4408 lbm_value first_arg, rest;
4409 get_car_and_cdr(args, &first_arg, &rest);
4410
4411 lbm_value val;
4412 if (lbm_is_symbol(first_arg) && lbm_global_env_lookup(&val, first_arg)) {
4413 // Prepare to copy the rest of the arguments when done with first.
4414 lbm_value *rptr = stack_reserve(ctx, 2);
4415 rptr[0] = rest;
4416 rptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
4417 if (lbm_is_ptr(val) &&
4418 (!(val & LBM_PTR_TO_CONSTANT_BIT0x04000000u))) {
4419 lbm_value * rptr1 = stack_reserve(ctx, 3);
4420 rptr1[0] = first_arg;
4421 rptr1[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
4422 rptr1[2] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4423 ctx->r = val;
4424 }
4425 ctx->app_cont = true1;
4426 return;
4427 }
4428 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4429}
4430
4431static void cont_move_val_to_flash_dispatch(eval_context_t *ctx) {
4432
4433 lbm_value val = ctx->r;
4434
4435 if (lbm_is_cons(val)) {
4436 lbm_value *rptr = stack_reserve(ctx, 5);
4437 rptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // fst cell of list
4438 rptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last cell of list
4439 rptr[2] = get_cdr(val);
4440 rptr[3] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4441 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4442 ctx->r = get_car(val);
4443 ctx->app_cont = true1;
4444 return;
4445 }
4446
4447 if (lbm_is_ptr(val) && (val & LBM_PTR_TO_CONSTANT_BIT0x04000000u)) {
4448 ctx->r = val;
4449 ctx->app_cont = true1;
4450 return;
4451 }
4452
4453 if (lbm_is_ptr(val)) {
4454 lbm_cons_t *ref = lbm_ref_cell(val);
4455 if (lbm_type_of(ref->cdr) == LBM_TYPE_SYMBOL0x00000000u) {
4456 switch (ref->cdr) {
4457 case ENC_SYM_RAW_I_TYPE(((0x31) << 4) | 0x00000000u): /* fall through */
4458 case ENC_SYM_RAW_U_TYPE(((0x32) << 4) | 0x00000000u):
4459 case ENC_SYM_RAW_F_TYPE(((0x33) << 4) | 0x00000000u): {
4460 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4461 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4462 handle_flash_status(write_const_car(flash_cell, ref->car));
4463 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4464 ctx->r = flash_cell;
4465 } break;
4466 case ENC_SYM_IND_I_TYPE(((0x34) << 4) | 0x00000000u): /* fall through */
4467 case ENC_SYM_IND_U_TYPE(((0x35) << 4) | 0x00000000u):
4468 case ENC_SYM_IND_F_TYPE(((0x36) << 4) | 0x00000000u): {
4469#ifndef LBM64
4470 /* 64 bit values are in lbm mem on 32bit platforms. */
4471 lbm_uint *lbm_mem_ptr = (lbm_uint*)ref->car;
4472 lbm_uint flash_ptr;
4473
4474 handle_flash_status(lbm_write_const_raw(lbm_mem_ptr, 2, &flash_ptr));
4475 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4476 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4477 handle_flash_status(write_const_car(flash_cell, flash_ptr));
4478 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4479 ctx->r = flash_cell;
4480#else
4481 // There are no indirect types in LBM64
4482 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4483#endif
4484 } break;
4485 case ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u): {
4486 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4487 lbm_uint size = arr->size / sizeof(lbm_uint);
4488 lbm_uint flash_addr;
4489 lbm_value *arrdata = (lbm_value *)arr->data;
4490 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4491 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4492 handle_flash_status(lbm_allocate_const_raw(size, &flash_addr));
4493 lift_array_flash(flash_cell,
4494 false0,
4495 (char *)flash_addr,
4496 arr->size);
4497 // Move array contents to flash recursively
4498 lbm_value *rptr = stack_reserve(ctx, 5);
4499 rptr[0] = flash_cell;
4500 rptr[1] = lbm_enc_u(0);
4501 rptr[2] = val;
4502 rptr[3] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4503 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4504 ctx->r = arrdata[0];
4505 ctx->app_cont = true1;
4506 return;
4507 }
4508 case ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u): {
4509 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4510 // arbitrary address: flash_arr.
4511 lbm_uint flash_arr;
4512 handle_flash_status(lbm_write_const_array_padded((uint8_t*)arr->data, arr->size, &flash_arr));
4513 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4514 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4515 lift_array_flash(flash_cell,
4516 true1,
4517 (char *)flash_arr,
4518 arr->size);
4519 ctx->r = flash_cell;
4520 } break;
4521 case ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u): /* fall through */
4522 case ENC_SYM_CUSTOM_TYPE(((0x38) << 4) | 0x00000000u):
4523 lbm_set_error_reason((char *)lbm_error_str_flash_not_possible);
4524 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4525 }
4526 } else {
4527 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4528 }
4529 ctx->app_cont = true1;
4530 return;
4531 }
4532 ctx->r = val;
4533 ctx->app_cont = true1;
4534}
4535
4536static void cont_move_list_to_flash(eval_context_t *ctx) {
4537
4538 // ctx->r holds the value that should go in car
4539
4540 lbm_value *sptr = get_stack_ptr(ctx, 3);
4541
4542 lbm_value fst = sptr[0];
4543 lbm_value lst = sptr[1];
4544 lbm_value val = sptr[2];
4545
4546
4547 lbm_value new_lst = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4548 // Allocate element ptr storage after storing the element to flash.
4549 handle_flash_status(request_flash_storage_cell(lbm_enc_cons_ptr(LBM_PTR_NULL(0x03FFFFFCu >> 2)), &new_lst));
4550
4551 if (lbm_is_symbol_nil(fst)) {
4552 lst = new_lst;
4553 fst = new_lst;
4554 handle_flash_status(write_const_car(lst, ctx->r));
4555 } else {
4556 handle_flash_status(write_const_cdr(lst, new_lst)); // low before high
4557 handle_flash_status(write_const_car(new_lst, ctx->r));
4558 lst = new_lst;
4559 }
4560
4561 if (lbm_is_cons(val)) {
4562 sptr[0] = fst;
4563 sptr[1] = lst;//rest_cell;
4564 sptr[2] = get_cdr(val);
4565 lbm_value *rptr = stack_reserve(ctx, 2);
4566 rptr[0] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4567 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4568 ctx->r = get_car(val);
4569 } else {
4570 sptr[0] = fst;
4571 sptr[1] = lst;
4572 sptr[2] = CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u);
4573 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4574 ctx->r = val;
4575 }
4576 ctx->app_cont = true1;
4577}
4578
4579static void cont_close_list_in_flash(eval_context_t *ctx) {
4580 lbm_value fst;
4581 lbm_value lst;
4582 lbm_pop_2(&ctx->K, &lst, &fst);
4583 lbm_value val = ctx->r;
4584 handle_flash_status(write_const_cdr(lst, val));
4585 ctx->r = fst;
4586 ctx->app_cont = true1;
4587}
4588
4589static void cont_move_array_elts_to_flash(eval_context_t *ctx) {
4590 lbm_value *sptr = get_stack_ptr(ctx, 3);
4591 // sptr[2] = source array in RAM
4592 // sptr[1] = current index
4593 // sptr[0] = target array in flash
4594 lbm_array_header_t *src_arr = (lbm_array_header_t*)get_car(sptr[2]);
4595 lbm_uint size = src_arr->size / sizeof(lbm_uint);
4596 lbm_value *srcdata = (lbm_value *)src_arr->data;
4597
4598 lbm_array_header_t *tgt_arr = (lbm_array_header_t*)get_car(sptr[0]);
4599 lbm_uint *tgtdata = (lbm_value *)tgt_arr->data;
4600 lbm_uint ix = lbm_dec_as_u32(sptr[1]);
4601 handle_flash_status(lbm_const_write(&tgtdata[ix], ctx->r));
4602 if (ix >= size-1) {
4603 ctx->r = sptr[0];
4604 lbm_stack_drop(&ctx->K, 3);
4605 ctx->app_cont = true1;
4606 return;
4607 }
4608 sptr[1] = lbm_enc_u(ix + 1);
4609 lbm_value *rptr = stack_reserve(ctx, 2);
4610 rptr[0] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4611 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4612 ctx->r = srcdata[ix+1];
4613 ctx->app_cont = true1;
4614 return;
4615}
4616
4617static void cont_qq_expand_start(eval_context_t *ctx) {
4618 lbm_value *rptr = stack_reserve(ctx, 2);
4619 rptr[0] = ctx->r;
4620 rptr[1] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4621 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4622 ctx->app_cont = true1;
4623}
4624
4625lbm_value quote_it(lbm_value qquoted) {
4626 if (lbm_is_symbol(qquoted) &&
4627 lbm_is_special(qquoted)) return qquoted;
4628
4629 lbm_value val = cons_with_gc(qquoted, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4630 return cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4631}
4632
4633bool_Bool is_append(lbm_value a) {
4634 return (lbm_is_cons(a) &&
4635 lbm_is_symbol(get_car(a)) &&
4636 (get_car(a) == ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u)));
4637}
4638
4639lbm_value append(lbm_value front, lbm_value back) {
4640 if (lbm_is_symbol_nil(front)) return back;
4641 if (lbm_is_symbol_nil(back)) return front;
4642
4643 if (lbm_is_quoted_list(front) &&
4644 lbm_is_quoted_list(back)) {
4645 lbm_value f = get_cadr(front);
4646 lbm_value b = get_cadr(back);
4647 return quote_it(lbm_list_append(f, b));
4648 }
4649
4650 if (is_append(back) &&
4651 lbm_is_quoted_list(get_cadr(back)) &&
4652 lbm_is_quoted_list(front)) {
4653 lbm_value ql = get_cadr(back);
4654 lbm_value f = get_cadr(front);
4655 lbm_value b = get_cadr(ql);
4656
4657 lbm_value v = lbm_list_append(f, b);
4658 lbm_set_car(get_cdr(ql), v);
4659 return back;
4660 }
4661
4662 if (is_append(back)) {
4663 back = get_cdr(back);
4664 lbm_value new = cons_with_gc(front, back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4665 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), new, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4666 }
4667
4668 lbm_value t0, t1;
4669
4670 t0 = cons_with_gc(back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), front);
4671 t1 = cons_with_gc(front, t0, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4672 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), t1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4673}
4674
4675/* Bawden's qq-expand implementation
4676(define (qq-expand x)
4677 (cond ((tag-comma? x)
4678 (tag-data x))
4679 ((tag-comma-atsign? x)
4680 (error "Illegal"))
4681 ((tag-backquote? x)
4682 (qq-expand
4683 (qq-expand (tag-data x))))
4684 ((pair? x)
4685 `(append
4686 ,(qq-expand-list (car x))
4687 ,(qq-expand (cdr x))))
4688 (else `',x)))
4689 */
4690static void cont_qq_expand(eval_context_t *ctx) {
4691 lbm_value qquoted;
4692 lbm_pop(&ctx->K, &qquoted);
4693
4694 switch(lbm_type_of(qquoted)) {
4695 case LBM_TYPE_CONS0x10000000u: {
4696 lbm_value car_val = get_car(qquoted);
4697 lbm_value cdr_val = get_cdr(qquoted);
4698 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4699 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4700 ctx->r = append(ctx->r, get_car(cdr_val));
4701 ctx->app_cont = true1;
4702 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4703 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4704 error_ctx(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u));
4705 } else {
4706 lbm_value *rptr = stack_reserve(ctx, 6);
4707 rptr[0] = ctx->r;
4708 rptr[1] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4709 rptr[2] = cdr_val;
4710 rptr[3] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4711 rptr[4] = car_val;
4712 rptr[5] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4713 ctx->app_cont = true1;
4714 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4715 }
4716
4717 } break;
4718 default: {
4719 lbm_value res = quote_it(qquoted);
4720 ctx->r = append(ctx->r, res);
4721 ctx->app_cont = true1;
4722 }
4723 }
4724}
4725
4726static void cont_qq_append(eval_context_t *ctx) {
4727 lbm_value head;
4728 lbm_pop(&ctx->K, &head);
4729 ctx->r = append(head, ctx->r);
4730 ctx->app_cont = true1;
4731}
4732
4733/* Bawden's qq-expand-list implementation
4734(define (qq-expand-list x)
4735 (cond ((tag-comma? x)
4736 `(list ,(tag-data x)))
4737 ((tag-comma-atsign? x)
4738 (tag-data x))
4739 ((tag-backquote? x)
4740 (qq-expand-list
4741 (qq-expand (tag-data x))))
4742 ((pair? x)
4743 `(list
4744 (append
4745 ,(qq-expand-list (car x))
4746 ,(qq-expand (cdr x)))))
4747 (else `'(,x))))
4748*/
4749
4750static void cont_qq_expand_list(eval_context_t* ctx) {
4751 lbm_value l;
4752 lbm_pop(&ctx->K, &l);
4753
4754 ctx->app_cont = true1;
4755 switch(lbm_type_of(l)) {
4756 case LBM_TYPE_CONS0x10000000u: {
4757 lbm_value car_val = get_car(l);
4758 lbm_value cdr_val = get_cdr(l);
4759 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4760 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4761 lbm_value tl = cons_with_gc(get_car(cdr_val), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4762 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4763 ctx->r = append(ctx->r, tmp);
4764 return;
4765 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4766 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4767 ctx->r = get_car(cdr_val);
4768 return;
4769 } else {
4770 lbm_value *rptr = stack_reserve(ctx, 7);
4771 rptr[0] = QQ_LIST(((39) << 2) | 0xF8000001u);
4772 rptr[1] = ctx->r;
4773 rptr[2] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4774 rptr[3] = cdr_val;
4775 rptr[4] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4776 rptr[5] = car_val;
4777 rptr[6] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4778 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4779 }
4780
4781 } break;
4782 default: {
4783 lbm_value a_list = cons_with_gc(l, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4784 lbm_value tl = cons_with_gc(a_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4785 lbm_value tmp = cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4786 ctx->r = append(ctx->r, tmp);
4787 }
4788 }
4789}
4790
4791static void cont_qq_list(eval_context_t *ctx) {
4792 lbm_value val = ctx->r;
4793 lbm_value apnd_app = cons_with_gc(val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4794 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), apnd_app, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4795 ctx->r = tmp;
4796 ctx->app_cont = true1;
4797}
4798
4799static void cont_kill(eval_context_t *ctx) {
4800 (void) ctx;
4801 finish_ctx();
4802}
4803
4804static void cont_pop_reader_flags(eval_context_t *ctx) {
4805 lbm_value flags;
4806 lbm_pop(&ctx->K, &flags);
4807 ctx->flags = ctx->flags & ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4808 ctx->flags |= (lbm_dec_as_u32(flags) & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4809 // r is unchanged.
4810 ctx->app_cont = true1;
4811}
4812
4813static void cont_exception_handler(eval_context_t *ctx) {
4814 lbm_value *sptr = pop_stack_ptr(ctx, 2);
4815 lbm_value retval = sptr[0];
4816 lbm_value flags = sptr[1];
4817 lbm_set_car(get_cdr(retval), ctx->r);
4818 ctx->flags = flags;
4819 ctx->r = retval;
4820 ctx->app_cont = true1;
4821}
4822
4823/*********************************************************/
4824/* Continuations table */
4825typedef void (*cont_fun)(eval_context_t *);
4826
4827static const cont_fun continuations[NUM_CONTINUATIONS49] =
4828 { advance_ctx, // CONT_DONE
4829 cont_set_global_env,
4830 cont_bind_to_key_rest,
4831 cont_if,
4832 cont_progn_rest,
4833 cont_application_args,
4834 cont_and,
4835 cont_or,
4836 cont_wait,
4837 cont_match,
4838 cont_application_start,
4839 cont_eval_r,
4840 cont_resume,
4841 cont_closure_application_args,
4842 cont_exit_atomic,
4843 cont_read_next_token,
4844 cont_read_append_continue,
4845 cont_read_eval_continue,
4846 cont_read_expect_closepar,
4847 cont_read_dot_terminate,
4848 cont_read_done,
4849 cont_read_quote_result,
4850 cont_read_commaat_result,
4851 cont_read_comma_result,
4852 cont_read_start_array,
4853 cont_read_append_array,
4854 cont_map,
4855 cont_match_guard,
4856 cont_terminate,
4857 cont_progn_var,
4858 cont_setq,
4859 cont_move_to_flash,
4860 cont_move_val_to_flash_dispatch,
4861 cont_move_list_to_flash,
4862 cont_close_list_in_flash,
4863 cont_qq_expand_start,
4864 cont_qq_expand,
4865 cont_qq_append,
4866 cont_qq_expand_list,
4867 cont_qq_list,
4868 cont_kill,
4869 cont_loop,
4870 cont_loop_condition,
4871 cont_merge_rest,
4872 cont_merge_layer,
4873 cont_closure_args_rest,
4874 cont_move_array_elts_to_flash,
4875 cont_pop_reader_flags,
4876 cont_exception_handler
4877 };
4878
4879/*********************************************************/
4880/* Evaluators lookup table (special forms) */
4881typedef void (*evaluator_fun)(eval_context_t *);
4882
4883static const evaluator_fun evaluators[] =
4884 {
4885 eval_quote,
4886 eval_define,
4887 eval_progn,
4888 eval_lambda,
4889 eval_if,
4890 eval_let,
4891 eval_and,
4892 eval_or,
4893 eval_match,
4894 eval_receive,
4895 eval_receive_timeout,
4896 eval_callcc,
4897 eval_atomic,
4898 eval_selfevaluating, // macro
4899 eval_selfevaluating, // cont
4900 eval_selfevaluating, // closure
4901 eval_cond,
4902 eval_app_cont,
4903 eval_var,
4904 eval_setq,
4905 eval_move_to_flash,
4906 eval_loop,
4907 eval_trap
4908 };
4909
4910
4911/*********************************************************/
4912/* Evaluator step function */
4913
4914static void evaluation_step(void){
4915 eval_context_t *ctx = ctx_running;
4916#ifdef VISUALIZE_HEAP
4917 heap_vis_gen_image();
4918#endif
4919
4920 if (ctx->app_cont) {
4921 lbm_value k;
4922 lbm_pop(&ctx->K, &k);
4923 ctx->app_cont = false0;
4924
4925 lbm_uint decoded_k = DEC_CONTINUATION(k)(((k) & ~0xF8000001u) >> 2);
4926
4927 if (decoded_k < NUM_CONTINUATIONS49) {
4928 continuations[decoded_k](ctx);
4929 } else {
4930 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4931 }
4932 return;
4933 }
4934
4935 if (lbm_is_symbol(ctx->curr_exp)) {
4936 eval_symbol(ctx);
4937 return;
4938 }
4939 if (lbm_is_cons(ctx->curr_exp)) {
4940 lbm_cons_t *cell = lbm_ref_cell(ctx->curr_exp);
4941 lbm_value h = cell->car;
4942 if (lbm_is_symbol(h) && ((h & ENC_SPECIAL_FORMS_MASK0xFFFFF000) == ENC_SPECIAL_FORMS_BIT0x00001000)) {
4943 lbm_uint eval_index = lbm_dec_sym(h) & SPECIAL_FORMS_INDEX_MASK0x000000FF;
4944 evaluators[eval_index](ctx);
4945 return;
4946 }
4947 /*
4948 * At this point head can be anything. It should evaluate
4949 * into a form that can be applied (closure, symbol, ...) though.
4950 */
4951 lbm_value *reserved = stack_reserve(ctx, 3);
4952 reserved[0] = ctx->curr_env;
4953 reserved[1] = cell->cdr;
4954 reserved[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
4955 ctx->curr_exp = h; // evaluate the function
4956 return;
4957 }
4958
4959 eval_selfevaluating(ctx);
4960 return;
4961}
4962
4963void lbm_pause_eval(void ) {
4964 eval_cps_next_state_arg = 0;
4965 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4966 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4967}
4968
4969void lbm_pause_eval_with_gc(uint32_t num_free) {
4970 eval_cps_next_state_arg = num_free;
4971 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4972 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4973}
4974
4975void lbm_continue_eval(void) {
4976 eval_cps_next_state = EVAL_CPS_STATE_RUNNING2;
4977 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4978}
4979
4980void lbm_kill_eval(void) {
4981 eval_cps_next_state = EVAL_CPS_STATE_KILL4;
4982 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4983}
4984
4985uint32_t lbm_get_eval_state(void) {
4986 return eval_cps_run_state;
4987}
4988
4989// Will wake up thread that is sleeping as well.
4990// Not sure this is good behavior.
4991static void handle_event_unblock_ctx(lbm_cid cid, lbm_value v) {
4992 eval_context_t *found = NULL((void*)0);
4993 mutex_lock(&qmutex);
4994
4995 found = lookup_ctx_nm(&blocked, cid);
4996 if (found) {
4997 drop_ctx_nm(&blocked,found);
4998 if (lbm_is_error(v)) {
4999 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
5000 found->app_cont = true1;
5001 }
5002 found->r = v;
5003 enqueue_ctx_nm(&queue,found);
5004 }
5005 mutex_unlock(&qmutex);
5006}
5007
5008static void handle_event_define(lbm_value key, lbm_value val) {
5009 lbm_uint dec_key = lbm_dec_sym(key);
5010 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
5011 lbm_value *global_env = lbm_get_global_env();
5012 lbm_uint orig_env = global_env[ix_key];
5013 lbm_value new_env;
5014 // A key is a symbol and should not need to be remembered.
5015 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
5016
5017 global_env[ix_key] = new_env;
5018}
5019
5020static lbm_value get_event_value(lbm_event_t *e) {
5021 lbm_value v;
5022 if (e->buf_len > 0) {
5023 lbm_flat_value_t fv;
5024 fv.buf = (uint8_t*)e->buf_ptr;
5025 fv.buf_size = e->buf_len;
5026 fv.buf_pos = 0;
5027 if (!lbm_unflatten_value(&fv, &v)) {
5028 lbm_set_flags(LBM_FLAG_HANDLER_EVENT_DELIVERY_FAILED(1 << 1));
5029 v = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
5030 }
5031 // Free the flat value buffer. GC is unaware of its existence.
5032 lbm_free(fv.buf);
5033 } else {
5034 v = (lbm_value)e->buf_ptr;
5035 }
5036 return v;
5037}
5038
5039static void process_events(void) {
5040
5041 if (!lbm_events) return;
5042 lbm_event_t e;
5043
5044 while (lbm_event_pop(&e)) {
5045
5046 lbm_value event_val = get_event_value(&e);
5047 switch(e.type) {
5048 case LBM_EVENT_UNBLOCK_CTX:
5049 handle_event_unblock_ctx((lbm_cid)e.parameter, event_val);
5050 break;
5051 case LBM_EVENT_DEFINE:
5052 handle_event_define((lbm_value)e.parameter, event_val);
5053 break;
5054 case LBM_EVENT_FOR_HANDLER:
5055 if (lbm_event_handler_pid >= 0) {
5056 lbm_find_receiver_and_send(lbm_event_handler_pid, event_val);
5057 }
5058 break;
5059 }
5060 }
5061}
5062
5063/* eval_cps_run can be paused
5064 I think it would be better use a mailbox for
5065 communication between other threads and the run_eval
5066 but for now a set of variables will be used. */
5067void lbm_run_eval(void){
5068
5069 if (setjmp(critical_error_jmp_buf)_setjmp (critical_error_jmp_buf) > 0) {
5070 printf_callback("GC stack overflow!\n");
5071 critical_error_callback();
5072 // terminate evaluation thread.
5073 return;
5074 }
5075
5076 setjmp(error_jmp_buf)_setjmp (error_jmp_buf);
5077
5078 while (eval_running) {
5079 if (eval_cps_state_changed || eval_cps_run_state == EVAL_CPS_STATE_PAUSED1) {
5080 eval_cps_state_changed = false0;
5081 switch (eval_cps_next_state) {
5082 case EVAL_CPS_STATE_PAUSED1:
5083 if (eval_cps_run_state != EVAL_CPS_STATE_PAUSED1) {
5084 if (lbm_heap_num_free() < eval_cps_next_state_arg) {
5085 gc();
5086 }
5087 eval_cps_next_state_arg = 0;
5088 }
5089 eval_cps_run_state = EVAL_CPS_STATE_PAUSED1;
5090 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5091 continue; /* jump back to start of eval_running loop */
5092 case EVAL_CPS_STATE_KILL4:
5093 eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
5094 eval_running = false0;
5095 continue;
5096 default: // running state
5097 eval_cps_run_state = eval_cps_next_state;
5098 break;
5099 }
5100 }
5101 while (true1) {
5102 if (eval_steps_quota && ctx_running) {
5103 eval_steps_quota--;
5104 evaluation_step();
5105 } else {
5106 if (eval_cps_state_changed) break;
5107 eval_steps_quota = eval_steps_refill;
5108 if (is_atomic) {
5109 if (!ctx_running) {
5110 lbm_set_flags(LBM_FLAG_ATOMIC_MALFUNCTION(1 << 0));
5111 is_atomic = 0;
5112 }
5113 } else {
5114 if (gc_requested) {
5115 gc();
5116 }
5117 process_events();
5118 mutex_lock(&qmutex);
5119 if (ctx_running) {
5120 enqueue_ctx_nm(&queue, ctx_running);
5121 ctx_running = NULL((void*)0);
5122 }
5123 wake_up_ctxs_nm();
5124 ctx_running = dequeue_ctx_nm(&queue);
5125 mutex_unlock(&qmutex);
5126 if (!ctx_running) {
5127 lbm_system_sleeping = true1;
5128 //Fixed sleep interval to poll events regularly.
5129 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5130 lbm_system_sleeping = false0;
5131 }
5132 }
5133 }
5134 }
5135 }
5136}
5137
5138lbm_cid lbm_eval_program(lbm_value lisp) {
5139 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), 256, NULL((void*)0));
5140}
5141
5142lbm_cid lbm_eval_program_ext(lbm_value lisp, unsigned int stack_size) {
5143 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), stack_size, NULL((void*)0));
5144}
5145
5146int lbm_eval_init() {
5147 if (!qmutex_initialized) {
5148 mutex_init(&qmutex);
5149 qmutex_initialized = true1;
5150 }
5151 if (!lbm_events_mutex_initialized) {
5152 mutex_init(&lbm_events_mutex);
5153 lbm_events_mutex_initialized = true1;
5154 }
5155 if (!blocking_extension_mutex_initialized) {
5156 mutex_init(&blocking_extension_mutex);
5157 blocking_extension_mutex_initialized = true1;
5158 }
5159
5160 mutex_lock(&qmutex);
5161 mutex_lock(&lbm_events_mutex);
5162
5163 blocked.first = NULL((void*)0);
5164 blocked.last = NULL((void*)0);
5165 queue.first = NULL((void*)0);
5166 queue.last = NULL((void*)0);
5167 ctx_running = NULL((void*)0);
5168
5169 eval_cps_run_state = EVAL_CPS_STATE_RUNNING2;
5170
5171 mutex_unlock(&lbm_events_mutex);
5172 mutex_unlock(&qmutex);
5173
5174 if (!lbm_init_env()) return 0;
5175 eval_running = true1;
5176 return 1;
5177}
5178
5179bool_Bool lbm_eval_init_events(unsigned int num_events) {
5180
5181 mutex_lock(&lbm_events_mutex);
5182 lbm_events = (lbm_event_t*)lbm_malloc(num_events * sizeof(lbm_event_t));
5183 bool_Bool r = false0;
5184 if (lbm_events) {
5185 lbm_events_max = num_events;
5186 lbm_events_head = 0;
5187 lbm_events_tail = 0;
5188 lbm_events_full = false0;
5189 lbm_event_handler_pid = -1;
5190 r = true1;
5191 }
5192 mutex_unlock(&lbm_events_mutex);
5193 return r;
5194}
+
+
←

./include/heap.h

+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1
2/*
3 Copyright 2018, 2024 Joel Svensson svenssonjoel@yahoo.se
4
5 This program is free software: you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation, either version 3 of the License, or
8 (at your option) any later version.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
14
15 You should have received a copy of the GNU General Public License
16 along with this program. If not, see <http://www.gnu.org/licenses/>.
17*/
18/** \file heap.h */
19
20#ifndef HEAP_H_
21#define HEAP_H_
22
23#include <string.h>
24#include <stdarg.h>
25
26#include "lbm_types.h"
27#include "symrepr.h"
28#include "stack.h"
29#include "lbm_memory.h"
30#include "lbm_defines.h"
31#include "lbm_channel.h"
32
33#ifdef __cplusplus
34extern "C" {
35#endif
36
37/*
38Planning for a more space efficient heap representation.
39TODO: Need to find a good reference to read up on this.
40 - List based heap
41 - Easy to implement and somewhat efficient
42
430000 0000 Size Free bits
44003F FFFF 4MB 10
45007F FFFF 8MB 9
4600FF FFFF 16MB 8
4701FF FFFF 32MB 7
4803FF FFFF 64MB 6 * Kind of heap size I am looking for
4907FF FFFF 128MB 5
500FFF FFFF 256MB 4
511FFF FFFF 512MB 3
52
53
54--- May 9 2021 ---
55Actually now I am much more interested in way smaller memories ;)
56
570000 0000 Size Free bits
580000 0FFF 4KB 20 |
590000 1FFF 8KB 19 |
600000 3FFF 16KB 18 |
610000 7FFF 32KB 17 |
620000 FFFF 64KB 16 |
630001 FFFF 128KB 15 |
640003 FFFF 256KB 14 | - This range is very interesting.
650007 FFFF 512KB 13
66000F FFFF 1MB 12
67001F FFFF 2MB 11
68003F FFFF 4MB 10
69007F FFFF 8MB 9
7000FF FFFF 16MB 8
7101FF FFFF 32MB 7
7203FF FFFF 64MB 6
7307FF FFFF 128MB 5
740FFF FFFF 256MB 4
751FFF FFFF 512MB 3
76
77Those are the kind of platforms that are fun... so a bunch of
78wasted bits in heap pointers if we run on small MCUs.
79
80-----------------
81
82it is also the case that not all addresses will be used if all "cells" are
83of the same size, 8 bytes...
84
85value 0: 0000 0000
86value 1: 0000 0008
87value 3: 0000 0010
88value 4: 0000 0018
89
90Means bits 0,1,2 will always be empty in a valid address.
91
92Cons cells also need to be have room for 2 pointers. So each ted cell from
93memory should be 8bytes.
94
95Things that needs to be represented within these bits:
96
97 - GC MARK one per cell
98 - TYPE: type of CAR and type of cons
99
100Types I would want:
101 - Full 32bit integer. Does not leave room for identification of type
102 - Float values. Same problem
103
104
105Free bits in pointers 64MB heap:
10631 30 29 28 27 26 2 1 0
1070 0 0 0 0 0 XX XXXX XXXX XXXX XXXX XXXX X 0 0 0
108
109
110Information needed for each cell:
111 Meaning | bits total | bits per car | bits per cdr
112 GC mark | 2 | 1 | 1 - only one of them will be used (the other is wasted)
113 Type | 2x | x | x
114 Ptr/!ptr | 2 | 1 | 1
115
116
117Types (unboxed):
118 - Symbols
119 - 28bit integer ( will need signed shift right functionality )
120 - 28bit unsigned integer
121 - Character
122
123If four types is all that should be possible (unboxed). then 2 bits are needed to differentiate.
1242 + 1 + 1 = 4 => 28bits for data.
125
126bit 0: ptr/!ptr
127bit 1: gc
128bit 2-3: type (if not ptr)
129bit 3 - 24 ptr (if ptr)
130bit 4 - 31 value (if value)
131
132An unboxed value can occupy a car or cdr field in a cons cell.
133
134types (boxed) extra information in pointer to cell can contain information
135 - 32 bit integer
136 - 32 bit unsigned integer
137 - 32 bit float
138
139boxed representation:
140 [ptr| cdr]
141 |
142 [Value | Aux + GC_MARK]
143
144Kinds of pointers:
145 - Pointer to cons cell.
146 - Pointer to unboxed value (fixnums not in a list, I hope this is so rare that it can be removed )
147 - integer
148 - unsigned integer
149 - symbol
150 - float
151 - Pointer to boxed value.
152 - 32 bit integer
153 - 32 bit unsigned integer
154 - 32 bit float
155 - (Maybe something else ? Vectors/strings allocated in memory not occupied by heap?)
156 - vector of int
157 - vector of uint
158 - vector of float
159 - vector of double
160 - String
161
16213 pointer"types" -> needs 4 bits
163for 64MB heap there are 6 free bits. So with this scheme going to 128MB or 256MB heap
164is also possible
165
166 a pointer to some off heap vector/string could be represented by
167
168 [ptr | cdr]
169 |
170 [full pointer | Aux + GC_MARK]
171 |
172 [VECTOR]
173
174Aux bits could be used for storing vector size. Up to 30bits should be available there
175>> This is problematic. Now the information that something is a vector is split up
176>> between 2 cons cells. This means GC needs both of these intact to be able to make
177>> proper decision.
178>> Will try to resolve this by adding some special symbols. But these must be symbols
179>> that cannot occur normally in programs. Then an array could be:
180
181 [Full pointer | ARRAY_SYM + GC_MARK]
182 |
183 [VECTOR]
184
185>> Boxed values same treatment as above.
186>> TODO: Could this be simpler?
187
188[ VALUE | TYPE_SYM + GC_MARK]
189
190
1910000 00XX XXXX XXXX XXXX XXXX XXXX X000 : 0x03FF FFF8
1921111 AA00 0000 0000 0000 0000 0000 0000 : 0xFC00 0000 (AA bits left unused for now, future heap growth?)
193 */
194
195typedef enum {
196 LBM_FLASH_WRITE_OK,
197 LBM_FLASH_FULL,
198 LBM_FLASH_WRITE_ERROR
199} lbm_flash_status;
200
201/** Struct representing a heap cons-cell.
202 *
203 */
204typedef struct {
205 lbm_value car;
206 lbm_value cdr;
207} lbm_cons_t;
208
209/**
210 * Heap state
211 */
212typedef struct {
213 lbm_cons_t *heap;
214 lbm_value freelist; // list of free cons cells.
215 lbm_stack_t gc_stack;
216
217 lbm_uint heap_size; // In number of cells.
218 lbm_uint heap_bytes; // In bytes.
219
220 lbm_uint num_alloc; // Number of cells allocated.
221 lbm_uint num_alloc_arrays; // Number of arrays allocated.
222
223 lbm_uint gc_num; // Number of times gc has been performed.
224 lbm_uint gc_marked; // Number of cells marked by mark phase.
225 lbm_uint gc_recovered; // Number of cells recovered by sweep phase.
226 lbm_uint gc_recovered_arrays;// Number of arrays recovered by sweep.
227 lbm_uint gc_least_free; // The smallest length of the freelist.
228 lbm_uint gc_last_free; // Number of elements on the freelist
229 // after most recent GC.
230} lbm_heap_state_t;
231
232extern lbm_heap_state_t lbm_heap_state;
233
234typedef bool_Bool (*const_heap_write_fun)(lbm_uint ix, lbm_uint w);
235
236typedef struct {
237 lbm_uint *heap;
238 lbm_uint next; // next free index.
239 lbm_uint size; // in lbm_uint words. (cons-cells = words / 2)
240} lbm_const_heap_t;
241
242/**
243 * The header portion of an array stored in array and symbol memory.
244 * An array is always a byte array. use the array-extensions for
245 * storing and reading larger values from arrays.
246 */
247typedef struct {
248 lbm_uint size; /// Number of elements
249 lbm_uint *data; /// pointer to lbm_memory array or C array.
250} lbm_array_header_t;
251
252typedef struct {
253 lbm_uint size;
254 lbm_uint *data;
255 uint32_t index; // Limits arrays to max 2^32-1 elements.
256} lbm_array_header_extended_t;
257
258/** Lock GC mutex
259 * Locks a mutex during GC marking when using the pointer reversal algorithm.
260 * Does nothing when using stack based GC mark.
261 */
262void lbm_gc_lock(void);
263/* Unlock GC mutex
264 */
265void lbm_gc_unlock(void);
266
267/** Initialize heap storage.
268 * \param addr Pointer to an array of lbm_cons_t elements. This array must at least be aligned 4.
269 * \param num_cells Number of lbm_cons_t elements in the array.
270 * \param gc_stack_size Size of the gc_stack in number of words.
271 * \return 1 on success or 0 for failure.
272 */
273int lbm_heap_init(lbm_cons_t *addr, lbm_uint num_cells,
274 lbm_uint gc_stack_size);
275
276/** Add GC time statistics to heap_stats
277 *
278 * \param dur Duration as reported by the timestamp callback.
279 */
280void lbm_heap_new_gc_time(lbm_uint dur);
281/** Add a new free_list length to the heap_stats.
282 * Calculates a new freelist length and updates
283 * the GC statistics.
284 */
285void lbm_heap_new_freelist_length(void);
286/** Check how many lbm_cons_t cells are on the free-list
287 *
288 * \return Number of free lbm_cons_t cells.
289 */
290lbm_uint lbm_heap_num_free(void);
291/** Check how many lbm_cons_t cells are allocated.
292 *
293 * \return Number of lbm_cons_t cells that are currently allocated.
294 */
295lbm_uint lbm_heap_num_allocated(void);
296/** Size of the heap in number of lbm_cons_t cells.
297 *
298 * \return Size of the heap in number of lbm_cons_t cells.
299 */
300lbm_uint lbm_heap_size(void);
301/** Size of the heap in bytes.
302 *
303 * \return Size of heap in bytes.
304 */
305lbm_uint lbm_heap_size_bytes(void);
306/** Allocate an lbm_cons_t cell from the heap.
307 *
308 * \param type A type that can be encoded onto the cell (most often LBM_PTR_TYPE_CONS).
309 * \param car Value to write into car position of allocated cell.
310 * \param cdr Value to write into cdr position of allocated cell.
311 * \return An lbm_value referring to a cons_cell or enc_sym(SYM_MERROR) in case the heap is full.
312 */
313lbm_value lbm_heap_allocate_cell(lbm_type type, lbm_value car, lbm_value cdr);
314/** Allocate a list of n heap-cells.
315 * \param n The number of heap-cells to allocate.
316 * \return A list of heap-cells of Memory error if unable to allocate.
317 */
318lbm_value lbm_heap_allocate_list(lbm_uint n);
319/** Allocate a list of n heap-cells and initialize the values.
320 * \pram ls The result list is passed through this ptr.
321 * \param n The length of list to allocate.
322 * \param valist The values in a va_list to initialize the list with.
323 * \return True of False depending on success of allocation.
324 */
325lbm_value lbm_heap_allocate_list_init_va(unsigned int n, va_list valist);
326/** Allocate a list of n heap-cells and initialize the values.
327 * \param n The length of list to allocate.
328 * \param ... The values to initialize the list with.
329 * \return allocated list or error symbol.
330 */
331lbm_value lbm_heap_allocate_list_init(unsigned int n, ...);
332/** Decode an lbm_value representing a string into a C string
333 *
334 * \param val Value
335 * \return allocated list or error symbol
336 */
337char *lbm_dec_str(lbm_value val);
338/** Decode an lbm_value representing a char channel into an lbm_char_channel_t pointer.
339 *
340 * \param val Value
341 * \return A pointer to an lbm_char_channel_t or NULL if the value does not encode a channel.
342 */
343lbm_char_channel_t *lbm_dec_channel(lbm_value val);
344/** Decode an lbm_value representing a custom type into a lbm_uint value.
345 *
346 * \param val Value.
347 * \return The custom type payload.
348 */
349lbm_uint lbm_dec_custom(lbm_value val);
350/** Decode a numerical value as if it is char
351 *
352 * \param val Value to decode
353 * \return The value encoded in val casted to a char. Returns 0 if val does not encode a number.
354 */
355uint8_t lbm_dec_as_char(lbm_value a);
356/** Decode a numerical value as if it is unsigned
357 *
358 * \param val Value to decode
359 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
360 */
361uint32_t lbm_dec_as_u32(lbm_value val);
362/** Decode a numerical value as a signed integer.
363 *
364 * \param val Value to decode
365 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
366 */
367int32_t lbm_dec_as_i32(lbm_value val);
368/** Decode a numerical value as a float.
369 *
370 * \param val Value to decode.
371 * \return The value encoded in val casted to a float. Returns 0 if val does not encode a number.
372 */
373float lbm_dec_as_float(lbm_value val);
374/** Decode a numerical value as if it is a 64bit unsigned
375 *
376 * \param val Value to decode
377 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
378 */
379uint64_t lbm_dec_as_u64(lbm_value val);
380/** Decode a numerical value as a 64bit signed integer.
381 *
382 * \param val Value to decode
383 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
384 */
385int64_t lbm_dec_as_i64(lbm_value val);
386/** Decode a numerical value as a float.
387 *
388 * \param val Value to decode.
389 * \return The value encoded in val casted to a float. Returns 0 if val does not encode a number.
390 */
391double lbm_dec_as_double(lbm_value val);
392
393/** Decode a numerical value into the architecture defined unsigned integer type.
394 *
395 * \param val Value to decode
396 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
397 */
398lbm_uint lbm_dec_as_uint(lbm_value val);
399
400/** Decode a numerical value into the architecture defined signed integer type.
401 *
402 * \param val Value to decode
403 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
404 */
405lbm_int lbm_dec_as_int(lbm_value val);
406
407lbm_uint lbm_dec_raw(lbm_value v);
408/** Allocates an lbm_cons_t cell from the heap and populates it.
409 *
410 * \param car The value to put in the car field of the allocated lbm_cons_t.
411 * \param cdr The value to put in the cdr field of the allocated lbm_cons_t.
412 * \return A value referencing the lbm_cons_t or enc_sym(SYM_MERROR) if heap is full.
413 */
414lbm_value lbm_cons(lbm_value car, lbm_value cdr);
415
416/** Accesses the car field of an lbm_cons_t.
417 *
418 * \param cons Value
419 * \return The car field of the lbm_cons_t if cons is a reference to a heap cell.
420 * If cons is nil, the return value is nil. If the value
421 * is not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
422 */
423lbm_value lbm_car(lbm_value cons);
424/** Accesses the car field the car field of an lbm_cons_t.
425 *
426 * \param cons Value
427 * \return The car of car field or nil.
428 */
429lbm_value lbm_caar(lbm_value c);
430/** Accesses the car of the cdr of an cons cell
431 *
432 * \param c Value
433 * \return the cdr field or type error.
434 */
435lbm_value lbm_cadr(lbm_value c);
436/** Accesses the cdr field of an lbm_cons_t.
437 *
438 * \param cons Value
439 * \return The cdr field of the lbm_cons_t if cons is a reference to a heap cell.
440 * If cons is nil, the return value is nil. If the value
441 * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
442 */
443lbm_value lbm_cdr(lbm_value cons);
444/** Accesses the cdr of an cdr field of an lbm_cons_t.
445 *
446 * \param cons Value
447 * \return The cdr of the cdr field of the lbm_cons_t if cons is a reference to a heap cell.
448 * If cons is nil, the return value is nil. If the value
449 * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
450 */
451lbm_value lbm_cddr(lbm_value c);
452/** Update the value stored in the car field of a heap cell.
453 *
454 * \param c Value referring to a heap cell.
455 * \param v Value to replace the car field with.
456 * \return 1 on success and 0 if the c value does not refer to a heap cell.
457 */
458int lbm_set_car(lbm_value c, lbm_value v);
459/** Update the value stored in the cdr field of a heap cell.
460 *
461 * \param c Value referring to a heap cell.
462 * \param v Value to replace the cdr field with.
463 * \return 1 on success and 0 if the c value does not refer to a heap cell.
464 */
465int lbm_set_cdr(lbm_value c, lbm_value v);
466/** Update the value stored in the car and cdr fields of a heap cell.
467 *
468 * \param c Value referring to a heap cell.
469 * \param car_val Value to replace the car field with.
470 * \param cdr_val Value to replace the cdr field with.
471 * \return 1 on success and 0 if the c value does not refer to a heap cell.
472 */
473int lbm_set_car_and_cdr(lbm_value c, lbm_value car_val, lbm_value cdr_val);
474// List functions
475/** Calculate the length of a proper list
476 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
477 * may lead to the function not terminating.
478 *
479 * \param c A list
480 * \return The length of the list. Unless the value is a cyclic structure on the heap, this function will terminate.
481 */
482lbm_uint lbm_list_length(lbm_value c);
483
484/** Calculate the length of a proper list and evaluate a predicate for each element.
485 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
486 * may lead to the function not terminating.
487 *
488 * \param c A list
489 * \param pres Boolean result of predicate, false if predicate is false for any of the elements in the list, otherwise true.
490 * \param pred Predicate to evaluate for each element of the list.
491 */
492unsigned int lbm_list_length_pred(lbm_value c, bool_Bool *pres, bool_Bool (*pred)(lbm_value));
493/** Reverse a proper list
494 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
495 * may lead to the function not terminating.
496 *
497 * \param list A list
498 * \return The list reversed or enc_sym(SYM_MERROR) if heap is full.
499 */
500lbm_value lbm_list_reverse(lbm_value list);
501/** Reverse a proper list destroying the original.
502 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
503 * may lead to the function not terminating.
504 *
505 * \param list A list
506 * \return The list reversed
507 */
508lbm_value lbm_list_destructive_reverse(lbm_value list);
509/** Copy a list
510 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
511 * may lead to the function not terminating.
512 *
513 * \param m Number of elements to copy or -1 for all. If 1, m will be updated with the length of the list
514 * \param list A list.
515 * \return Reversed list or enc_sym(SYM_MERROR) if heap is full.
516 */
517lbm_value lbm_list_copy(int *m, lbm_value list);
518
519/** A destructive append of two lists
520 *
521 * \param list1 A list
522 * \param list2 A list
523 * \return list1 with list2 appended at the end.
524 */
525lbm_value lbm_list_append(lbm_value list1, lbm_value list2);
526
527/** Drop values from the head of a list.
528 * \param n Number of values to drop.
529 * \param ls List to drop values from.
530 * \return The list with the n first elements removed.
531 */
532lbm_value lbm_list_drop(unsigned int n, lbm_value ls);
533/** Index into a list.
534 * \param l List to index into.
535 * \param n Position to read out of the list.
536 * \return Value at position n of l or nil if out of bounds.
537 */
538lbm_value lbm_index_list(lbm_value l, int32_t n);
539
540// State and statistics
541/** Get a copy of the heap statistics structure.
542 *
543 * \param A pointer to an lbm_heap_state_t to populate
544 * with the current statistics.
545 */
546void lbm_get_heap_state(lbm_heap_state_t *);
547/** Get the maximum stack level of the GC stack
548 * \return maximum value the gc stack sp reached so far.
549 */
550lbm_uint lbm_get_gc_stack_max(void);
551/** Get the size of the GC stack.
552 * \return the size of the gc stack.
553 */
554lbm_uint lbm_get_gc_stack_size(void);
555// Garbage collection
556/** Increment the counter that is counting the number of times GC ran
557 *
558 */
559void lbm_gc_state_inc(void);
560/** Set the freelist to NIL. Means that no memory will be available
561 * until after a garbage collection.
562 */
563void lbm_nil_freelist(void);
564/** Mark all heap cells reachable from an environment.
565 * \param environment.
566 */
567void lbm_gc_mark_env(lbm_value);
568/** Mark heap cells reachable from the lbm_value v.
569 * \param root
570 */
571void lbm_gc_mark_phase(lbm_value root);
572/** Performs lbm_gc_mark_phase on all the values of an array.
573 * This function is similar to lbm_gc_mark_roots but performs
574 * extra checks to not traverse into non-standard values.
575 * TODO: Check if this function is really needed.
576 * \param data Array of roots to traverse from.
577 * \param n Number of elements in roots-array.
578 */
579void lbm_gc_mark_aux(lbm_uint *data, lbm_uint n);
580/** Performs lbm_gc_mark_phase on all the values in the roots array.
581 * \param roots pointer to array of roots.
582 * \param num_roots size of array of roots.
583 */
584void lbm_gc_mark_roots(lbm_uint *roots, lbm_uint num_roots);
585/** Sweep up all non marked heap cells and place them on the free list.
586 *
587 * \return 1
588 */
589int lbm_gc_sweep_phase(void);
590
591// Array functionality
592/** Allocate an bytearray in symbols and arrays memory (lispbm_memory.h)
593 * and create a heap cell that refers to this bytearray.
594 * \param res The resulting lbm_value is returned through this argument.
595 * \param size Array size in number of 32 bit words.
596 * \return 1 for success of 0 for failure.
597 */
598int lbm_heap_allocate_array(lbm_value *res, lbm_uint size);
599/** Allocate an array in symbols and arrays memory (lispbm_memory.h)
600 * and create a heap cell that refers to this array.
601 * \param res The resulting lbm_value is returned through this argument.
602 * \param size Array size in number of 32 bit words.
603 * \return 1 for success of 0 for failure.
604 */
605int lbm_heap_allocate_lisp_array(lbm_value *res, lbm_uint size);
606/** Convert a C array into an lbm array. If the C array is allocated in LBM MEMORY
607 * the lifetime of the array will be managed by GC.
608 * \param res lbm_value result pointer for storage of the result array.
609 * \param data C array.
610 * \param type The type tag to assign to the resulting LBM array.
611 * \param num_elt Number of elements in the array.
612 * \return 1 for success and 0 for failure.
613 */
614int lbm_lift_array(lbm_value *value, char *data, lbm_uint num_elt);
615/** Get the size of an array value.
616 * \param arr lbm_value array to get size of.
617 * \return -1 for failure or length of array.
618 */
619lbm_int lbm_heap_array_get_size(lbm_value arr);
620/** Get a pointer to the data of an array for read only purposes.
621 * \param arr lbm_value array to get pointer from.
622 * \return NULL or valid pointer.
623 */
624const uint8_t *lbm_heap_array_get_data_ro(lbm_value arr);
625/** Get a pointer to the data of an array for read/write purposes.
626 * \param arr lbm_value array to get pointer from.
627 * \return NULL or valid pointer.
628 */
629uint8_t *lbm_heap_array_get_data_rw(lbm_value arr);
630/** Explicitly free an array.
631 * This function needs to be used with care and knowledge.
632 * \param arr Array value.
633 */
634int lbm_heap_explicit_free_array(lbm_value arr);
635/** Query the size in bytes of an lbm_type.
636 * \param t Type
637 * \return Size in bytes of type or 0 if the type represents a composite.
638 */
639lbm_uint lbm_size_of(lbm_type t);
640
641int lbm_const_heap_init(const_heap_write_fun w_fun,
642 lbm_const_heap_t *heap,
643 lbm_uint *addr,
644 lbm_uint num_words);
645
646lbm_flash_status lbm_allocate_const_cell(lbm_value *res);
647lbm_flash_status lbm_write_const_raw(lbm_uint *data, lbm_uint n, lbm_uint *res);
648lbm_flash_status lbm_allocate_const_raw(lbm_uint nwords, lbm_uint *res);
649lbm_flash_status write_const_cdr(lbm_value cell, lbm_value val);
650lbm_flash_status write_const_car(lbm_value cell, lbm_value val);
651lbm_flash_status lbm_const_write(lbm_uint *tgt, lbm_uint val);
652lbm_uint lbm_flash_memory_usage(void);
653
654/** Query the type information of a value.
655 *
656 * \param x Value to check the type of.
657 * \return The type information.
658 */
659static inline lbm_type lbm_type_of(lbm_value x) {
660 return (x & LBM_PTR_BIT0x00000001u) ? (x & LBM_PTR_TYPE_MASK0xFC000000u) : (x & LBM_VAL_TYPE_MASK0x0000000Cu);
661}
662
663// type-of check that is safe in functional code
664static inline lbm_type lbm_type_of_functional(lbm_value x) {
665 return (x & LBM_PTR_BIT0x00000001u) ?
666 (x & (LBM_PTR_TO_CONSTANT_MASK~0x04000000u & LBM_PTR_TYPE_MASK0xFC000000u)) :
667 (x & LBM_VAL_TYPE_MASK0x0000000Cu);
668}
669
670static inline lbm_value lbm_enc_cons_ptr(lbm_uint x) {
671 return ((x << LBM_ADDRESS_SHIFT2) | LBM_TYPE_CONS0x10000000u | LBM_PTR_BIT0x00000001u);
672}
673
674static inline lbm_uint lbm_dec_ptr(lbm_value p) {
675 return ((LBM_PTR_VAL_MASK0x03FFFFFCu & p) >> LBM_ADDRESS_SHIFT2);
676}
677
678extern lbm_cons_t *lbm_heaps[2];
679
680static inline lbm_uint lbm_dec_cons_cell_ptr(lbm_value p) {
681 lbm_uint h = (p & LBM_PTR_TO_CONSTANT_BIT0x04000000u) >> LBM_PTR_TO_CONSTANT_SHIFT26;
682 return lbm_dec_ptr(p) >> h;
683}
684
685static inline lbm_cons_t *lbm_dec_heap(lbm_value p) {
686 lbm_uint h = (p & LBM_PTR_TO_CONSTANT_BIT0x04000000u) >> LBM_PTR_TO_CONSTANT_SHIFT26;
687 return lbm_heaps[h];
688}
689
690static inline lbm_value lbm_set_ptr_type(lbm_value p, lbm_type t) {
691 return ((LBM_PTR_VAL_MASK0x03FFFFFCu & p) | t | LBM_PTR_BIT0x00000001u);
692}
693
694static inline lbm_value lbm_enc_sym(lbm_uint s) {
695 return (s << LBM_VAL_SHIFT4) | LBM_TYPE_SYMBOL0x00000000u;
696}
697
698static inline lbm_value lbm_enc_i(lbm_int x) {
699 return ((lbm_uint)x << LBM_VAL_SHIFT4) | LBM_TYPE_I0x00000008u;
700}
701
702static inline lbm_value lbm_enc_u(lbm_uint x) {
703 return (x << LBM_VAL_SHIFT4) | LBM_TYPE_U0x0000000Cu;
704}
705
706/** Encode 32 bit integer into an lbm_value.
707 * \param x Value to encode.
708 * \return result encoded value.
709 */
710extern lbm_value lbm_enc_i32(int32_t x);
711
712/** Encode 32 bit unsigned integer into an lbm_value.
713 * \param x Value to encode.
714 * \return result encoded value.
715 */
716extern lbm_value lbm_enc_u32(uint32_t x);
717
718/** Encode a float into an lbm_value.
719 * \param x float value to encode.
720 * \return result encoded value.
721 */
722extern lbm_value lbm_enc_float(float x);
723
724/** Encode a 64 bit integer into an lbm_value.
725 * \param x 64 bit integer to encode.
726 * \return result encoded value.
727 */
728extern lbm_value lbm_enc_i64(int64_t x);
729
730/** Encode a 64 bit unsigned integer into an lbm_value.
731 * \param x 64 bit unsigned integer to encode.
732 * \return result encoded value.
733 */
734extern lbm_value lbm_enc_u64(uint64_t x);
735
736/** Encode a double into an lbm_value.
737 * \param x double to encode.
738 * \return result encoded value.
739 */
740extern lbm_value lbm_enc_double(double x);
741
742static inline lbm_value lbm_enc_char(uint8_t x) {
743 return ((lbm_uint)x << LBM_VAL_SHIFT4) | LBM_TYPE_CHAR0x00000004u;
744}
745
746static inline lbm_int lbm_dec_i(lbm_value x) {
747 return (lbm_int)x >> LBM_VAL_SHIFT4;
748}
749
750static inline lbm_uint lbm_dec_u(lbm_value x) {
751 return x >> LBM_VAL_SHIFT4;
752}
753
754static inline uint8_t lbm_dec_char(lbm_value x) {
755 return (uint8_t)(x >> LBM_VAL_SHIFT4);
756}
757
758static inline lbm_uint lbm_dec_sym(lbm_value x) {
759 return x >> LBM_VAL_SHIFT4;
760}
761
762/** Decode an lbm_value representing a float.
763 * \param x Value to decode.
764 * \return decoded float.
765 */
766extern float lbm_dec_float(lbm_value x);
767
768/** Decode an lbm_value representing a double.
769 * \param x Value to decode.
770 * \return decoded float.
771 */
772extern double lbm_dec_double(lbm_value x);
773
774
775static inline uint32_t lbm_dec_u32(lbm_value x) {
776#ifndef LBM64
777 return (uint32_t)lbm_car(x);
778#else
779 return (uint32_t)(x >> LBM_VAL_SHIFT4);
780#endif
781}
782
783/** Decode an lbm_value representing a 64 bit unsigned integer.
784 * \param x Value to decode.
785 * \return decoded uint64_t.
786 */
787extern uint64_t lbm_dec_u64(lbm_value x);
788
789static inline int32_t lbm_dec_i32(lbm_value x) {
790#ifndef LBM64
791 return (int32_t)lbm_car(x);
792#else
793 return (int32_t)(x >> LBM_VAL_SHIFT4);
794#endif
795}
796
797/** Decode an lbm_value representing a 64 bit integer.
798 * \param x Value to decode.
799 * \return decoded int64_t.
800 */
801extern int64_t lbm_dec_i64(lbm_value x);
802
803/**
804 * Check if a value is a heap pointer
805 * \param x Value to check
806 * \return true if x is a pointer to a heap cell, false otherwise.
807 */
808static inline bool_Bool lbm_is_ptr(lbm_value x) {
809 return (x & LBM_PTR_BIT0x00000001u);
810}
811
812/**
813 * Check if a value is a Read/Writeable cons cell
814 * \param x Value to check
815 * \return true if x is a Read/Writeable cons cell, false otherwise.
816 */
817static inline bool_Bool lbm_is_cons_rw(lbm_value x) {
818 return (lbm_type_of(x) == LBM_TYPE_CONS0x10000000u);
819}
820
821/**
822 * Check if a value is a Readable cons cell
823 * \param x Value to check
824 * \return true if x is a readable cons cell, false otherwise.
825 */
826static inline bool_Bool lbm_is_cons(lbm_value x) {
827 return lbm_is_ptr(x) && ((x & LBM_CONS_TYPE_MASK0xF0000000u) == LBM_TYPE_CONS0x10000000u);
828}
829
830/** Check if a value represents a number
831 * \param x Value to check.
832 * \return true is x represents a number and false otherwise.
833 */
834static inline bool_Bool lbm_is_number(lbm_value x) {
835 return
836 (x & LBM_PTR_BIT0x00000001u) ?
837 ((x & LBM_NUMBER_MASK0x08000000u) == LBM_NUMBER_MASK0x08000000u) :
838 (x & LBM_VAL_TYPE_MASK0x0000000Cu);
839}
840
841/** Check if value is an array that can be READ
842 * \param x Value to check.
843 * \return true if x represents a readable array and false otherwise.
844 */
845static inline bool_Bool lbm_is_array_r(lbm_value x) {
846 lbm_type t = lbm_type_of(x);
847 return ((t & LBM_PTR_TO_CONSTANT_MASK~0x04000000u) == LBM_TYPE_ARRAY0x80000000u);
848}
849
850static inline bool_Bool lbm_is_array_rw(lbm_value x) {
851 return( (lbm_type_of(x) == LBM_TYPE_ARRAY0x80000000u) && !(x & LBM_PTR_TO_CONSTANT_BIT0x04000000u));
852}
853
854static inline bool_Bool lbm_is_lisp_array_r(lbm_value x) {
855 lbm_type t = lbm_type_of(x);
856 return ((t & LBM_PTR_TO_CONSTANT_MASK~0x04000000u) == LBM_TYPE_LISPARRAY0xB0000000u);
857}
858
859static inline bool_Bool lbm_is_lisp_array_rw(lbm_value x) {
860 return( (lbm_type_of(x) == LBM_TYPE_LISPARRAY0xB0000000u) && !(x & LBM_PTR_TO_CONSTANT_BIT0x04000000u));
861}
862
863
864static inline bool_Bool lbm_is_channel(lbm_value x) {
865 return (lbm_type_of(x) == LBM_TYPE_CHANNEL0x90000000u &&
866 lbm_type_of(lbm_cdr(x)) == LBM_TYPE_SYMBOL0x00000000u &&
867 lbm_cdr(x) == ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
868}
869static inline bool_Bool lbm_is_char(lbm_value x) {
870 return (lbm_type_of(x) == LBM_TYPE_CHAR0x00000004u);
871}
872
873static inline bool_Bool lbm_is_special(lbm_value symrep) {
874 return ((lbm_type_of(symrep) == LBM_TYPE_SYMBOL0x00000000u) &&
875 (lbm_dec_sym(symrep) < SPECIAL_SYMBOLS_END0xFFFF));
876}
877
878static inline bool_Bool lbm_is_closure(lbm_value exp) {
879 return ((lbm_is_cons(exp)) &&
880 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
881 (lbm_car(exp) == ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u)));
882}
883
884static inline bool_Bool lbm_is_continuation(lbm_value exp) {
885 return ((lbm_type_of(exp) == LBM_TYPE_CONS0x10000000u) &&
886 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
887 (lbm_car(exp) == ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u)));
888}
889
890static inline bool_Bool lbm_is_macro(lbm_value exp) {
891 return ((lbm_type_of(exp) == LBM_TYPE_CONS0x10000000u) &&
892 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
893 (lbm_car(exp) == ENC_SYM_MACRO(((0x10D) << 4) | 0x00000000u)));
894}
895
896static inline bool_Bool lbm_is_match_binder(lbm_value exp) {
897 return (lbm_is_cons(exp) &&
898 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
899 (lbm_car(exp) == ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u)));
900}
901
902static inline bool_Bool lbm_is_comma_qualified_symbol(lbm_value exp) {
903 return (lbm_is_cons(exp) &&
904 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
905 (lbm_car(exp) == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) &&
906 (lbm_type_of(lbm_cadr(exp)) == LBM_TYPE_SYMBOL0x00000000u));
907}
908
909static inline bool_Bool lbm_is_symbol(lbm_value exp) {
910 return !(exp & LBM_LOW_RESERVED_BITS0x0000000Fu);
911}
912
913static inline bool_Bool lbm_is_symbol_nil(lbm_value exp) {
914 return !exp;
9
←
Assuming 'exp' is 0
→
10
←
Returning the value 1, which participates in a condition later
→
915}
916
917static inline bool_Bool lbm_is_symbol_true(lbm_value exp) {
918 return (lbm_is_symbol(exp) && exp == ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u));
919}
920
921static inline bool_Bool lbm_is_symbol_eval(lbm_value exp) {
922 return (lbm_is_symbol(exp) && exp == ENC_SYM_EVAL(((0x30008) << 4) | 0x00000000u));
923}
924
925static inline bool_Bool lbm_is_symbol_merror(lbm_value exp) {
926 return lbm_is_symbol(exp) && (exp == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
927}
928
929static inline bool_Bool lbm_is_list(lbm_value x) {
930 return (lbm_is_cons(x) || lbm_is_symbol_nil(x));
931}
932
933static inline bool_Bool lbm_is_list_rw(lbm_value x) {
934 return (lbm_is_cons_rw(x) || lbm_is_symbol_nil(x));
935}
936
937static inline bool_Bool lbm_is_quoted_list(lbm_value x) {
938 return (lbm_is_cons(x) &&
939 lbm_is_symbol(lbm_car(x)) &&
940 (lbm_car(x) == ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u)) &&
941 lbm_is_cons(lbm_cdr(x)) &&
942 lbm_is_cons(lbm_cadr(x)));
943}
944
945#ifndef LBM64
946#define ERROR_SYMBOL_MASK0xFFFFFFF0 0xFFFFFFF0
947#else
948#define ERROR_SYMBOL_MASK0xFFFFFFF0 0xFFFFFFFFFFFFFFF0
949#endif
950
951/* all error signaling symbols are in the range 0x20 - 0x2F */
952static inline bool_Bool lbm_is_error(lbm_value v){
953 return (lbm_is_symbol(v) &&
954 ((lbm_dec_sym(v) & ERROR_SYMBOL_MASK0xFFFFFFF0) == 0x20));
955}
956
957// ref_cell: returns a reference to the cell addressed by bits 3 - 26
958// Assumes user has checked that is_ptr was set
959static inline lbm_cons_t* lbm_ref_cell(lbm_value addr) {
960 return &lbm_dec_heap(addr)[lbm_dec_cons_cell_ptr(addr)];
961 //return &lbm_heap_state.heap[lbm_dec_ptr(addr)];
962}
963
964
965// lbm_uint a = lbm_heaps[0];
966// lbm_uint b = lbm_heaps[1];
967// lbm_uint i = (addr & LBM_PTR_TO_CONSTANT_BIT) >> LBM_PTR_TO_CONSTANT_SHIFT) - 1;
968// lbm_uint h = (a & i) | (b & ~i);
969
970#ifdef __cplusplus
971}
972#endif
973#endif
diff --git a/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-9d5914.html b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-9d5914.html new file mode 100644 index 00000000..1a11e252 --- /dev/null +++ b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-9d5914.html @@ -0,0 +1,6556 @@ + + + +src/eval_cps.c + + + + + + + + + + + + + + + + + + + + + + + + + + +

Bug Summary

+ + + + +
File:eval_cps.c
Warning:line 4252, column 21
Assigned value is garbage or undefined
+ +

Annotated Source Code

+

Press '?' + to see keyboard shortcuts

+ + +
clang -cc1 -triple i386-pc-linux-gnu -analyze -disable-free -disable-llvm-verifier -discard-value-names -main-file-name eval_cps.c -analyzer-store=region -analyzer-opt-analyze-nested-blocks -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -mrelocation-model static -mthread-model posix -mframe-pointer=none -fmath-errno -fno-rounding-math -masm-verbose -mconstructor-aliases -target-cpu i686 -dwarf-column-info -fno-split-dwarf-inlining -debugger-tuning=gdb -resource-dir /usr/lib/llvm-10/lib/clang/10.0.0 -I ./include -I ./include/extensions -I platform/linux/include -D _PRELUDE -internal-isystem /usr/local/include -internal-isystem /usr/lib/llvm-10/lib/clang/10.0.0/include -internal-externc-isystem /usr/include/i386-linux-gnu -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -std=c99 -fdebug-compilation-dir /home/joels/Current/lispbm -ferror-limit 19 -fmessage-length 0 -fgnuc-version=4.2.1 -fobjc-runtime=gcc -fdiagnostics-show-option -vectorize-loops -vectorize-slp -analyzer-output=html -faddrsig -o /home/joels/Current/lispbm/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1 -x c src/eval_cps.c +
+ + + +
+ + +
+ + + + +
+

src/eval_cps.c

+
→
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1/*
2 Copyright 2018, 2020 - 2024 Joel Svensson svenssonjoel@yahoo.se
3
4 This program is free software: you can redistribute it and/or modify
5 it under the terms of the GNU General Public License as published by
6 the Free Software Foundation, either version 3 of the License, or
7 (at your option) any later version.
8
9 This program is distributed in the hope that it will be useful,
10 but WITHOUT ANY WARRANTY; without even the implied warranty of
11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 GNU General Public License for more details.
13
14 You should have received a copy of the GNU General Public License
15 along with this program. If not, see <http://www.gnu.org/licenses/>.
16*/
17
18#include <lbm_memory.h>
19#include <lbm_types.h>
20#include "symrepr.h"
21#include "heap.h"
22#include "env.h"
23#include "eval_cps.h"
24#include "stack.h"
25#include "fundamental.h"
26#include "extensions.h"
27#include "tokpar.h"
28#include "lbm_channel.h"
29#include "print.h"
30#include "platform_mutex.h"
31#include "lbm_flat_value.h"
32#include "lbm_flags.h"
33
34#ifdef VISUALIZE_HEAP
35#include "heap_vis.h"
36#endif
37
38#include <setjmp.h>
39#include <stdarg.h>
40
41static jmp_buf error_jmp_buf;
42static jmp_buf critical_error_jmp_buf;
43
44#define S_TO_US(X)(lbm_uint)((X) * 1000000) (lbm_uint)((X) * 1000000)
45
46#define DEC_CONTINUATION(x)(((x) & ~0xF8000001u) >> 2) (((x) & ~LBM_CONTINUATION_INTERNAL0xF8000001u) >> LBM_ADDRESS_SHIFT2)
47#define IS_CONTINUATION(x)(((x) & 0xF8000001u) == 0xF8000001u) (((x) & LBM_CONTINUATION_INTERNAL0xF8000001u) == LBM_CONTINUATION_INTERNAL0xF8000001u)
48#define CONTINUATION(x)(((x) << 2) | 0xF8000001u) (((x) << LBM_ADDRESS_SHIFT2) | LBM_CONTINUATION_INTERNAL0xF8000001u)
49
50#define DONE(((0) << 2) | 0xF8000001u) CONTINUATION(0)(((0) << 2) | 0xF8000001u)
51#define SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u) CONTINUATION(1)(((1) << 2) | 0xF8000001u)
52#define BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u) CONTINUATION(2)(((2) << 2) | 0xF8000001u)
53#define IF(((3) << 2) | 0xF8000001u) CONTINUATION(3)(((3) << 2) | 0xF8000001u)
54#define PROGN_REST(((4) << 2) | 0xF8000001u) CONTINUATION(4)(((4) << 2) | 0xF8000001u)
55#define APPLICATION_ARGS(((5) << 2) | 0xF8000001u) CONTINUATION(5)(((5) << 2) | 0xF8000001u)
56#define AND(((6) << 2) | 0xF8000001u) CONTINUATION(6)(((6) << 2) | 0xF8000001u)
57#define OR(((7) << 2) | 0xF8000001u) CONTINUATION(7)(((7) << 2) | 0xF8000001u)
58#define WAIT(((8) << 2) | 0xF8000001u) CONTINUATION(8)(((8) << 2) | 0xF8000001u)
59#define MATCH(((9) << 2) | 0xF8000001u) CONTINUATION(9)(((9) << 2) | 0xF8000001u)
60#define APPLICATION_START(((10) << 2) | 0xF8000001u) CONTINUATION(10)(((10) << 2) | 0xF8000001u)
61#define EVAL_R(((11) << 2) | 0xF8000001u) CONTINUATION(11)(((11) << 2) | 0xF8000001u)
62#define RESUME(((12) << 2) | 0xF8000001u) CONTINUATION(12)(((12) << 2) | 0xF8000001u)
63#define CLOSURE_ARGS(((13) << 2) | 0xF8000001u) CONTINUATION(13)(((13) << 2) | 0xF8000001u)
64#define EXIT_ATOMIC(((14) << 2) | 0xF8000001u) CONTINUATION(14)(((14) << 2) | 0xF8000001u)
65#define READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u) CONTINUATION(15)(((15) << 2) | 0xF8000001u)
66#define READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u) CONTINUATION(16)(((16) << 2) | 0xF8000001u)
67#define READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u) CONTINUATION(17)(((17) << 2) | 0xF8000001u)
68#define READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u) CONTINUATION(18)(((18) << 2) | 0xF8000001u)
69#define READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u) CONTINUATION(19)(((19) << 2) | 0xF8000001u)
70#define READ_DONE(((20) << 2) | 0xF8000001u) CONTINUATION(20)(((20) << 2) | 0xF8000001u)
71#define READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u) CONTINUATION(21)(((21) << 2) | 0xF8000001u)
72#define READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u) CONTINUATION(22)(((22) << 2) | 0xF8000001u)
73#define READ_COMMA_RESULT(((23) << 2) | 0xF8000001u) CONTINUATION(23)(((23) << 2) | 0xF8000001u)
74#define READ_START_ARRAY(((24) << 2) | 0xF8000001u) CONTINUATION(24)(((24) << 2) | 0xF8000001u)
75#define READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u) CONTINUATION(25)(((25) << 2) | 0xF8000001u)
76#define MAP(((26) << 2) | 0xF8000001u) CONTINUATION(26)(((26) << 2) | 0xF8000001u)
77#define MATCH_GUARD(((27) << 2) | 0xF8000001u) CONTINUATION(27)(((27) << 2) | 0xF8000001u)
78#define TERMINATE(((28) << 2) | 0xF8000001u) CONTINUATION(28)(((28) << 2) | 0xF8000001u)
79#define PROGN_VAR(((29) << 2) | 0xF8000001u) CONTINUATION(29)(((29) << 2) | 0xF8000001u)
80#define SETQ(((30) << 2) | 0xF8000001u) CONTINUATION(30)(((30) << 2) | 0xF8000001u)
81#define MOVE_TO_FLASH(((31) << 2) | 0xF8000001u) CONTINUATION(31)(((31) << 2) | 0xF8000001u)
82#define MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u) CONTINUATION(32)(((32) << 2) | 0xF8000001u)
83#define MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u) CONTINUATION(33)(((33) << 2) | 0xF8000001u)
84#define CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u) CONTINUATION(34)(((34) << 2) | 0xF8000001u)
85#define QQ_EXPAND_START(((35) << 2) | 0xF8000001u) CONTINUATION(35)(((35) << 2) | 0xF8000001u)
86#define QQ_EXPAND(((36) << 2) | 0xF8000001u) CONTINUATION(36)(((36) << 2) | 0xF8000001u)
87#define QQ_APPEND(((37) << 2) | 0xF8000001u) CONTINUATION(37)(((37) << 2) | 0xF8000001u)
88#define QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u) CONTINUATION(38)(((38) << 2) | 0xF8000001u)
89#define QQ_LIST(((39) << 2) | 0xF8000001u) CONTINUATION(39)(((39) << 2) | 0xF8000001u)
90#define KILL(((40) << 2) | 0xF8000001u) CONTINUATION(40)(((40) << 2) | 0xF8000001u)
91#define LOOP(((41) << 2) | 0xF8000001u) CONTINUATION(41)(((41) << 2) | 0xF8000001u)
92#define LOOP_CONDITION(((42) << 2) | 0xF8000001u) CONTINUATION(42)(((42) << 2) | 0xF8000001u)
93#define MERGE_REST(((43) << 2) | 0xF8000001u) CONTINUATION(43)(((43) << 2) | 0xF8000001u)
94#define MERGE_LAYER(((44) << 2) | 0xF8000001u) CONTINUATION(44)(((44) << 2) | 0xF8000001u)
95#define CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u) CONTINUATION(45)(((45) << 2) | 0xF8000001u)
96#define MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u) CONTINUATION(46)(((46) << 2) | 0xF8000001u)
97#define POP_READER_FLAGS(((47) << 2) | 0xF8000001u) CONTINUATION(47)(((47) << 2) | 0xF8000001u)
98#define EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u) CONTINUATION(48)(((48) << 2) | 0xF8000001u)
99#define NUM_CONTINUATIONS49 49
100
101#define FM_NEED_GC-1 -1
102#define FM_NO_MATCH-2 -2
103#define FM_PATTERN_ERROR-3 -3
104
105typedef enum {
106 BL_OK = 0,
107 BL_NO_MEMORY,
108 BL_INCORRECT_KEY
109} binding_location_status;
110
111#define FB_OK0 0
112#define FB_TYPE_ERROR-1 -1
113
114const char* lbm_error_str_parse_eof = "End of parse stream.";
115const char* lbm_error_str_parse_dot = "Incorrect usage of '.'.";
116const char* lbm_error_str_parse_close = "Expected closing parenthesis.";
117const char* lbm_error_str_num_args = "Incorrect number of arguments.";
118const char* lbm_error_str_forbidden_in_atomic = "Operation is forbidden in an atomic block.";
119const char* lbm_error_str_no_number = "Argument(s) must be a number.";
120const char* lbm_error_str_not_a_boolean = "Argument must be t or nil (true or false).";
121const char* lbm_error_str_incorrect_arg = "Incorrect argument.";
122const char* lbm_error_str_var_outside_progn = "Usage of var outside of progn.";
123const char* lbm_error_str_flash_not_possible = "Value cannot be written to flash.";
124const char* lbm_error_str_flash_error = "Error writing to flash.";
125const char* lbm_error_str_flash_full = "Flash memory is full.";
126const char* lbm_error_str_variable_not_bound = "Variable not bound.";
127
128static lbm_value lbm_error_suspect;
129static bool_Bool lbm_error_has_suspect = false0;
130#ifdef LBM_ALWAYS_GC
131
132#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
133 gc(); \
134 (y) = (x); \
135 if (lbm_is_symbol_merror((y))) { \
136 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
137 }
138
139#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
140 lbm_gc_mark_phase(r); \
141 gc(); \
142 (y) = (x); \
143 if (lbm_is_symbol_merror((y))) { \
144 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
145 }
146
147#else
148
149#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
150 (y) = (x); \
151 if (lbm_is_symbol_merror((y))) { \
152 gc(); \
153 (y) = (x); \
154 if (lbm_is_symbol_merror((y))) { \
155 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
156 } \
157 /* continue executing statements below */ \
158 }
159#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
160 (y) = (x); \
161 if (lbm_is_symbol_merror((y))) { \
162 lbm_gc_mark_phase(r); \
163 gc(); \
164 (y) = (x); \
165 if (lbm_is_symbol_merror((y))) { \
166 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
167 } \
168 /* continue executing statements below */ \
169 }
170
171#endif
172
173typedef struct {
174 eval_context_t *first;
175 eval_context_t *last;
176} eval_context_queue_t;
177
178#ifdef CLEAN_UP_CLOSURES
179static lbm_value clean_cl_env_symbol = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
180#endif
181
182static int gc(void);
183static void error_ctx(lbm_value);
184static void error_at_ctx(lbm_value err_val, lbm_value at);
185static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx);
186static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail);
187
188// The currently executing context.
189eval_context_t *ctx_running = NULL((void*)0);
190volatile bool_Bool lbm_system_sleeping = false0;
191
192static volatile bool_Bool gc_requested = false0;
193void lbm_request_gc(void) {
194 gc_requested = true1;
195}
196
197/*
198 On ChibiOs the CH_CFG_ST_FREQUENCY setting in chconf.h sets the
199 resolution of the timer used for sleep operations. If this is set
200 to 10KHz the resolution is 100us.
201
202 The CH_CFG_ST_TIMEDELTA specifies the minimum number of ticks that
203 can be safely specified in a timeout directive (wonder if that
204 means sleep-period). The timedelta is set to 2.
205
206 If I have understood these correctly it means that the minimum
207 sleep duration possible is 2 * 100us = 200us.
208*/
209
210#define EVAL_CPS_DEFAULT_STACK_SIZE256 256
211#define EVAL_CPS_MIN_SLEEP200 200
212#define EVAL_STEPS_QUOTA10 10
213
214static volatile uint32_t eval_steps_refill = EVAL_STEPS_QUOTA10;
215static uint32_t eval_steps_quota = EVAL_STEPS_QUOTA10;
216
217void lbm_set_eval_step_quota(uint32_t quota) {
218 eval_steps_refill = quota;
219}
220
221static uint32_t eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
222static volatile uint32_t eval_cps_next_state = EVAL_CPS_STATE_NONE0;
223static volatile uint32_t eval_cps_next_state_arg = 0;
224static volatile bool_Bool eval_cps_state_changed = false0;
225
226static void usleep_nonsense(uint32_t us) {
227 (void) us;
228}
229
230static bool_Bool dynamic_load_nonsense(const char *sym, const char **code) {
231 (void) sym;
232 (void) code;
233 return false0;
234}
235
236static uint32_t timestamp_nonsense(void) {
237 return 0;
238}
239
240static int printf_nonsense(const char *fmt, ...) {
241 (void) fmt;
242 return 0;
243}
244
245static void ctx_done_nonsense(eval_context_t *ctx) {
246 (void) ctx;
247}
248
249static void critical_nonsense(void) {
250 return;
251}
252
253static void (*critical_error_callback)(void) = critical_nonsense;
254static void (*usleep_callback)(uint32_t) = usleep_nonsense;
255static uint32_t (*timestamp_us_callback)(void) = timestamp_nonsense;
256static void (*ctx_done_callback)(eval_context_t *) = ctx_done_nonsense;
257static int (*printf_callback)(const char *, ...) = printf_nonsense;
258static bool_Bool (*dynamic_load_callback)(const char *, const char **) = dynamic_load_nonsense;
259
260void lbm_set_critical_error_callback(void (*fptr)(void)) {
261 if (fptr == NULL((void*)0)) critical_error_callback = critical_nonsense;
262 else critical_error_callback = fptr;
263}
264
265void lbm_set_usleep_callback(void (*fptr)(uint32_t)) {
266 if (fptr == NULL((void*)0)) usleep_callback = usleep_nonsense;
267 else usleep_callback = fptr;
268}
269
270void lbm_set_timestamp_us_callback(uint32_t (*fptr)(void)) {
271 if (fptr == NULL((void*)0)) timestamp_us_callback = timestamp_nonsense;
272 else timestamp_us_callback = fptr;
273}
274
275void lbm_set_ctx_done_callback(void (*fptr)(eval_context_t *)) {
276 if (fptr == NULL((void*)0)) ctx_done_callback = ctx_done_nonsense;
277 else ctx_done_callback = fptr;
278}
279
280void lbm_set_printf_callback(int (*fptr)(const char*, ...)){
281 if (fptr == NULL((void*)0)) printf_callback = printf_nonsense;
282 else printf_callback = fptr;
283}
284
285void lbm_set_dynamic_load_callback(bool_Bool (*fptr)(const char *, const char **)) {
286 if (fptr == NULL((void*)0)) dynamic_load_callback = dynamic_load_nonsense;
287 else dynamic_load_callback = fptr;
288}
289
290static volatile lbm_event_t *lbm_events = NULL((void*)0);
291static unsigned int lbm_events_head = 0;
292static unsigned int lbm_events_tail = 0;
293static unsigned int lbm_events_max = 0;
294static bool_Bool lbm_events_full = false0;
295static mutex_t lbm_events_mutex;
296static bool_Bool lbm_events_mutex_initialized = false0;
297static volatile lbm_cid lbm_event_handler_pid = -1;
298
299lbm_cid lbm_get_event_handler_pid(void) {
300 return lbm_event_handler_pid;
301}
302
303void lbm_set_event_handler_pid(lbm_cid pid) {
304 lbm_event_handler_pid = pid;
305}
306
307bool_Bool lbm_event_handler_exists(void) {
308 return(lbm_event_handler_pid > 0);
309}
310
311
312static bool_Bool event_internal(lbm_event_type_t event_type, lbm_uint parameter, lbm_uint buf_ptr, lbm_uint buf_len) {
313 bool_Bool r = false0;
314 if (lbm_events) {
315 mutex_lock(&lbm_events_mutex);
316 if (!lbm_events_full) {
317 lbm_event_t event;
318 event.type = event_type;
319 event.parameter = parameter;
320 event.buf_ptr = buf_ptr;
321 event.buf_len = buf_len;
322 lbm_events[lbm_events_head] = event;
323 lbm_events_head = (lbm_events_head + 1) % lbm_events_max;
324 lbm_events_full = lbm_events_head == lbm_events_tail;
325 r = true1;
326 }
327 mutex_unlock(&lbm_events_mutex);
328 }
329 return r;
330}
331
332bool_Bool lbm_event_define(lbm_value key, lbm_flat_value_t *fv) {
333 return event_internal(LBM_EVENT_DEFINE, key, (lbm_uint)fv->buf, fv->buf_size);
334}
335
336bool_Bool lbm_event_unboxed(lbm_value unboxed) {
337 lbm_uint t = lbm_type_of(unboxed);
338 if (t == LBM_TYPE_SYMBOL0x00000000u ||
339 t == LBM_TYPE_I0x00000008u ||
340 t == LBM_TYPE_U0x0000000Cu ||
341 t == LBM_TYPE_CHAR0x00000004u) {
342 if (lbm_event_handler_pid > 0) {
343 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)unboxed, 0);
344 }
345 }
346 return false0;
347}
348
349bool_Bool lbm_event(lbm_flat_value_t *fv) {
350 if (lbm_event_handler_pid > 0) {
351 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)fv->buf, fv->buf_size);
352 }
353 return false0;
354}
355
356static bool_Bool lbm_event_pop(lbm_event_t *event) {
357 mutex_lock(&lbm_events_mutex);
358 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
359 mutex_unlock(&lbm_events_mutex);
360 return false0;
361 }
362 *event = lbm_events[lbm_events_tail];
363 lbm_events_tail = (lbm_events_tail + 1) % lbm_events_max;
364 lbm_events_full = false0;
365 mutex_unlock(&lbm_events_mutex);
366 return true1;
367}
368
369bool_Bool lbm_event_queue_is_empty(void) {
370 mutex_lock(&lbm_events_mutex);
371 bool_Bool empty = false0;
372 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
373 empty = true1;
374 }
375 mutex_unlock(&lbm_events_mutex);
376 return empty;
377}
378
379static bool_Bool eval_running = false0;
380static volatile bool_Bool blocking_extension = false0;
381static mutex_t blocking_extension_mutex;
382static bool_Bool blocking_extension_mutex_initialized = false0;
383static lbm_uint blocking_extension_timeout_us = 0;
384static bool_Bool blocking_extension_timeout = false0;
385
386static uint32_t is_atomic = 0;
387
388/* Process queues */
389static eval_context_queue_t blocked = {NULL((void*)0), NULL((void*)0)};
390static eval_context_queue_t queue = {NULL((void*)0), NULL((void*)0)};
391
392/* one mutex for all queue operations */
393mutex_t qmutex;
394bool_Bool qmutex_initialized = false0;
395
396
397// MODES
398static volatile bool_Bool lbm_verbose = false0;
399
400void lbm_toggle_verbose(void) {
401 lbm_verbose = !lbm_verbose;
402}
403
404void lbm_set_verbose(bool_Bool verbose) {
405 lbm_verbose = verbose;
406}
407
408lbm_cid lbm_get_current_cid(void) {
409 if (ctx_running)
410 return ctx_running->id;
411 else
412 return -1;
413}
414
415eval_context_t *lbm_get_current_context(void) {
416 return ctx_running;
417}
418
419/****************************************************/
420/* Utilities used locally in this file */
421
422static lbm_value cons_with_gc(lbm_value head, lbm_value tail, lbm_value remember) {
423#ifdef LBM_ALWAYS_GC
424 lbm_value roots[3] = {head, tail, remember};
425 lbm_gc_mark_roots(roots, 3);
426 gc();
427 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
428 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
429 if (lbm_is_symbol_merror(res)) {
430 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
431 }
432 return res;
433#else
434 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
435 if (lbm_is_symbol_merror(res)) {
436 lbm_value roots[3] = {head, tail, remember};
437 lbm_gc_mark_roots(roots,3);
438 gc();
439 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
440 if (lbm_is_symbol_merror(res)) {
441 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
442 }
443 }
444 return res;
445#endif
446}
447
448static lbm_uint *get_stack_ptr(eval_context_t *ctx, unsigned int n) {
449 if (n <= ctx->K.sp) {
450 lbm_uint index = ctx->K.sp - n;
451 return &ctx->K.data[index];
452 }
453 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
454 return 0; // dead code cannot be reached, but C compiler doesn't realise.
455}
456
457// pop_stack_ptr is safe when no GC is performed and
458// the values of the stack will be dropped.
459static lbm_uint *pop_stack_ptr(eval_context_t *ctx, unsigned int n) {
460 if (n <= ctx->K.sp) {
461 ctx->K.sp -= n;
462 return &ctx->K.data[ctx->K.sp];
463 }
464 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
465 return 0; // dead code cannot be reached, but C compiler doesn't realise.
466}
467
468static inline lbm_uint *stack_reserve(eval_context_t *ctx, unsigned int n) {
469 if (ctx->K.sp + n < ctx->K.size) {
470 lbm_uint *ptr = &ctx->K.data[ctx->K.sp];
471 ctx->K.sp += n;
472 return ptr;
473 }
474 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
475 return 0; // dead code cannot be reached, but C compiler doesn't realise.
476}
477
478static void handle_flash_status(lbm_flash_status s) {
479 if ( s == LBM_FLASH_FULL) {
480 lbm_set_error_reason((char*)lbm_error_str_flash_full);
481 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
482 }
483 if (s == LBM_FLASH_WRITE_ERROR) {
484 lbm_set_error_reason((char*)lbm_error_str_flash_error);
485 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
486 }
487}
488
489static void lift_array_flash(lbm_value flash_cell, bool_Bool bytearray, char *data, lbm_uint num_elt) {
490
491 lbm_array_header_t flash_array_header;
492 flash_array_header.size = num_elt;
493 flash_array_header.data = (lbm_uint*)data;
494 lbm_uint flash_array_header_ptr;
495 handle_flash_status(lbm_write_const_raw((lbm_uint*)&flash_array_header,
496 sizeof(lbm_array_header_t) / sizeof(lbm_uint),
497 &flash_array_header_ptr));
498 handle_flash_status(write_const_car(flash_cell, flash_array_header_ptr));
499 lbm_uint t = bytearray ? ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u) : ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u);
500 handle_flash_status(write_const_cdr(flash_cell, t));
501}
502
503static void get_car_and_cdr(lbm_value a, lbm_value *a_car, lbm_value *a_cdr) {
504 if (lbm_is_ptr(a)) {
19
←
Assuming the condition is false
→
20
←
Taking false branch
→
505 lbm_cons_t *cell = lbm_ref_cell(a);
506 *a_car = cell->car;
507 *a_cdr = cell->cdr;
508 } else if (lbm_is_symbol_nil(a)) {
21
←
Calling 'lbm_is_symbol_nil'
→
23
←
Returning from 'lbm_is_symbol_nil'
→
24
←
Taking false branch
→
509 *a_car = *a_cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
510 } else {
511 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
512 }
513}
25
←
Returning without writing to '*a_cdr'
→
514
515/* car cdr caar cadr replacements that are evaluator safe. */
516static lbm_value get_car(lbm_value a) {
517 if (lbm_is_ptr(a)) {
13
←
Taking true branch
→
518 lbm_cons_t *cell = lbm_ref_cell(a);
519 return cell->car;
14
←
Returning value, which participates in a condition later
→
520 } else if (lbm_is_symbol_nil(a)) {
521 return a;
522 }
523 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
524 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
525}
526
527static lbm_value get_cdr(lbm_value a) {
528 if (lbm_is_ptr(a)) {
529 lbm_cons_t *cell = lbm_ref_cell(a);
530 return cell->cdr;
531 } else if (lbm_is_symbol_nil(a)) {
532 return a;
533 }
534 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
535 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
536}
537
538static lbm_value get_cadr(lbm_value a) {
539 if (lbm_is_ptr(a)) {
540 lbm_cons_t *cell = lbm_ref_cell(a);
541 lbm_value tmp = cell->cdr;
542 if (lbm_is_ptr(tmp)) {
543 return lbm_ref_cell(tmp)->car;
544 } else if (lbm_is_symbol_nil(tmp)) {
545 return tmp;
546 }
547 } else if (lbm_is_symbol_nil(a)) {
548 return a;
549 }
550 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
551 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
552}
553
554static lbm_value allocate_closure(lbm_value params, lbm_value body, lbm_value env) {
555
556#ifdef LBM_ALWAYS_GC
557 gc();
558 if (lbm_heap_num_free() < 4) {
559 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
560 }
561#else
562 if (lbm_heap_num_free() < 4) {
563 gc();
564 if (lbm_heap_num_free() < 4) {
565 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
566 }
567 }
568#endif
569 // The freelist will always contain just plain heap-cells.
570 // So dec_ptr is sufficient.
571 lbm_value res = lbm_heap_state.freelist;
572 if (lbm_type_of(res) == LBM_TYPE_CONS0x10000000u) {
573 lbm_cons_t *heap = lbm_heap_state.heap;
574 lbm_uint ix = lbm_dec_ptr(res);
575 heap[ix].car = ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u);
576 ix = lbm_dec_ptr(heap[ix].cdr);
577 heap[ix].car = params;
578 ix = lbm_dec_ptr(heap[ix].cdr);
579 heap[ix].car = body;
580 ix = lbm_dec_ptr(heap[ix].cdr);
581 heap[ix].car = env;
582 lbm_heap_state.freelist = heap[ix].cdr;
583 heap[ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
584 lbm_heap_state.num_alloc+=4;
585 } else {
586 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
587 }
588 return res;
589}
590
591// Allocate a binding and attach it to a list (if so desired)
592static lbm_value allocate_binding(lbm_value key, lbm_value val, lbm_value the_cdr) {
593 if (lbm_heap_num_free() < 2) {
594 gc();
595 if (lbm_heap_num_free() < 2) {
596 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
597 }
598 }
599 lbm_cons_t* heap = lbm_heap_state.heap;
600 lbm_value binding_cell = lbm_heap_state.freelist;
601 lbm_uint binding_cell_ix = lbm_dec_ptr(binding_cell);
602 lbm_value list_cell = heap[binding_cell_ix].cdr;
603 lbm_uint list_cell_ix = lbm_dec_ptr(list_cell);
604 lbm_heap_state.freelist = heap[list_cell_ix].cdr;
605 lbm_heap_state.num_alloc += 2;
606 heap[binding_cell_ix].car = key;
607 heap[binding_cell_ix].cdr = val;
608 heap[list_cell_ix].car = binding_cell;
609 heap[list_cell_ix].cdr = the_cdr;
610 return list_cell;
611}
612
613#define CLO_PARAMS0 0
614#define CLO_BODY1 1
615#define CLO_ENV2 2
616#define LOOP_BINDS0 0
617#define LOOP_COND1 1
618#define LOOP_BODY2 2
619
620// (a b c) -> [a b c]
621static lbm_value extract_n(lbm_value curr, lbm_value *res, unsigned int n) {
622 for (unsigned int i = 0; i < n; i ++) {
623 if (lbm_is_ptr(curr)) {
624 lbm_cons_t *cell = lbm_ref_cell(curr);
625 res[i] = cell->car;
626 curr = cell->cdr;
627 } else {
628 res[i] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
629 }
630 }
631 return curr; // Rest of list is returned here.
632}
633
634static void call_fundamental(lbm_uint fundamental, lbm_value *args, lbm_uint arg_count, eval_context_t *ctx) {
635 lbm_value res;
636 res = fundamental_table[fundamental](args, arg_count, ctx);
637 if (lbm_is_error(res)) {
638 if (lbm_is_symbol_merror(res)) {
639 gc();
640 res = fundamental_table[fundamental](args, arg_count, ctx);
641 }
642 if (lbm_is_error(res)) {
643 error_at_ctx(res, lbm_enc_sym(FUNDAMENTAL_SYMBOLS_START0x20000 | fundamental));
644 }
645 }
646 lbm_stack_drop(&ctx->K, arg_count+1);
647 ctx->app_cont = true1;
648 ctx->r = res;
649}
650
651// block_current_ctx blocks a context until it is
652// woken up externally or a timeout period of time passes.
653static void block_current_ctx(uint32_t state, lbm_uint sleep_us, bool_Bool do_cont) {
654 ctx_running->timestamp = timestamp_us_callback();
655 ctx_running->sleep_us = sleep_us;
656 ctx_running->state = state;
657 ctx_running->app_cont = do_cont;
658 enqueue_ctx(&blocked, ctx_running);
659 ctx_running = NULL((void*)0);
660}
661
662lbm_flash_status lbm_write_const_array_padded(uint8_t *data, lbm_uint n, lbm_uint *res) {
663 lbm_uint full_words = n / sizeof(lbm_uint);
664 lbm_uint n_mod = n % sizeof(lbm_uint);
665
666 if (n_mod == 0) { // perfect fit.
667 return lbm_write_const_raw((lbm_uint*)data, full_words, res);
668 } else {
669 lbm_uint last_word = 0;
670 memcpy(&last_word, &data[full_words * sizeof(lbm_uint)], n_mod);
671 if (full_words >= 1) {
672 lbm_flash_status s = lbm_write_const_raw((lbm_uint*)data, full_words, res);
673 if ( s == LBM_FLASH_WRITE_OK) {
674 lbm_uint dummy;
675 s = lbm_write_const_raw(&last_word, 1, &dummy);
676 }
677 return s;
678 } else {
679 return lbm_write_const_raw(&last_word, 1, res);
680 }
681 }
682}
683
684/****************************************************/
685/* Error message creation */
686
687#define ERROR_MESSAGE_BUFFER_SIZE_BYTES256 256
688
689void print_environments(char *buf, unsigned int size) {
690
691 lbm_value curr_l = ctx_running->curr_env;
692 printf_callback("\tCurrent local environment:\n");
693 while (lbm_type_of(curr_l) == LBM_TYPE_CONS0x10000000u) {
694 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_l));
695 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_l)));
696 printf_callback("\t%s = %s\n", buf, buf+(size/2));
697 curr_l = lbm_cdr(curr_l);
698 }
699 printf_callback("\n\n");
700 printf_callback("\tCurrent global environment:\n");
701 lbm_value *glob_env = lbm_get_global_env();
702
703 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
704 lbm_value curr_g = glob_env[i];;
705 while (lbm_type_of(curr_g) == LBM_TYPE_CONS0x10000000u) {
706
707 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_g));
708 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_g)));
709 printf_callback("\t%s = %s\n", buf, buf+(size/2));
710 curr_g = lbm_cdr(curr_g);
711 }
712 }
713}
714
715void print_error_message(lbm_value error, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int col, lbm_int row0, lbm_int row1) {
716 if (!printf_callback) return;
717
718 /* try to allocate a lbm_print_value buffer on the lbm_memory */
719 char *buf = lbm_malloc_reserve(ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
720 if (!buf) {
721 printf_callback("Error: Not enough free memory to create a human readable error message\n");
722 return;
723 }
724
725 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, error);
726 printf_callback( "*** Error: %s\n", buf);
727 if (has_at) {
728 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, at);
729 printf_callback("*** In: %s\n",buf);
730 if (lbm_error_has_suspect) {
731 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, lbm_error_suspect);
732 lbm_error_has_suspect = false0;
733 printf_callback("*** At: %s\n", buf);
734 } else {
735 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
736 printf_callback("*** After: %s\n",buf);
737 }
738 } else {
739 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
740 printf_callback("*** Near: %s\n",buf);
741 }
742
743 printf_callback("\n");
744
745 if (lbm_is_symbol(error) &&
746 error == ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u)) {
747 printf_callback("*** Line: %u\n", row);
748 printf_callback("*** Column: %u\n", col);
749 } else if (row0 != -1 || row1 != -1 ) {
750 printf_callback("*** Between rows: (-1 unknown) \n");
751 printf_callback("*** Start: %d\n", (int32_t)row0);
752 printf_callback("*** End: %d\n", (int32_t)row1);
753 }
754
755 printf_callback("\n");
756
757 if (ctx_running->error_reason) {
758 printf_callback("Reason:\n %s\n\n", ctx_running->error_reason);
759 }
760 if (lbm_verbose) {
761 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
762 printf_callback(" In context: %d\n", ctx_running->id);
763 printf_callback(" Current intermediate result: %s\n\n", buf);
764
765 print_environments(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
766 printf_callback("\n\n");
767
768 printf_callback(" Stack:\n");
769 for (unsigned int i = 0; i < ctx_running->K.sp; i ++) {
770 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->K.data[i]);
771 printf_callback(" %s\n", buf);
772 }
773 }
774 lbm_free(buf);
775}
776
777/****************************************************/
778/* Tokenizing and parsing */
779
780bool_Bool create_string_channel(char *str, lbm_value *res) {
781
782 lbm_char_channel_t *chan = NULL((void*)0);
783 lbm_string_channel_state_t *st = NULL((void*)0);
784
785 st = (lbm_string_channel_state_t*)lbm_memory_allocate(sizeof(lbm_string_channel_state_t) / sizeof(lbm_uint) +1);
786 if (st == NULL((void*)0)) {
787 return false0;
788 }
789 chan = (lbm_char_channel_t*)lbm_memory_allocate(sizeof(lbm_char_channel_t) / sizeof(lbm_uint) + 1);
790 if (chan == NULL((void*)0)) {
791 lbm_memory_free((lbm_uint*)st);
792 return false0;
793 }
794
795 lbm_create_string_char_channel(st, chan, str);
796 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
797 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
798 lbm_memory_free((lbm_uint*)st);
799 lbm_memory_free((lbm_uint*)chan);
800 return false0;
801 }
802
803 *res = cell;
804 return true1;
805}
806
807bool_Bool lift_char_channel(lbm_char_channel_t *chan , lbm_value *res) {
808 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
809 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
810 return false0;
811 }
812 *res = cell;
813 return true1;
814}
815
816
817/****************************************************/
818/* Queue functions */
819
820static void queue_iterator_nm(eval_context_queue_t *q, ctx_fun f, void *arg1, void *arg2) {
821 eval_context_t *curr;
822 curr = q->first;
823
824 while (curr != NULL((void*)0)) {
825 f(curr, arg1, arg2);
826 curr = curr->next;
827 }
828}
829
830void lbm_running_iterator(ctx_fun f, void *arg1, void *arg2){
831 mutex_lock(&qmutex);
832 queue_iterator_nm(&queue, f, arg1, arg2);
833 mutex_unlock(&qmutex);
834}
835
836void lbm_blocked_iterator(ctx_fun f, void *arg1, void *arg2){
837 mutex_lock(&qmutex);
838 queue_iterator_nm(&blocked, f, arg1, arg2);
839 mutex_unlock(&qmutex);
840}
841
842static void enqueue_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
843 if (q->last == NULL((void*)0)) {
844 ctx->prev = NULL((void*)0);
845 ctx->next = NULL((void*)0);
846 q->first = ctx;
847 q->last = ctx;
848 } else {
849 ctx->prev = q->last;
850 ctx->next = NULL((void*)0);
851 q->last->next = ctx;
852 q->last = ctx;
853 }
854}
855
856static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx) {
857 mutex_lock(&qmutex);
858 enqueue_ctx_nm(q,ctx);
859 mutex_unlock(&qmutex);
860}
861
862static eval_context_t *lookup_ctx_nm(eval_context_queue_t *q, lbm_cid cid) {
863 eval_context_t *curr;
864 curr = q->first;
865 while (curr != NULL((void*)0)) {
866 if (curr->id == cid) {
867 return curr;
868 }
869 curr = curr->next;
870 }
871 return NULL((void*)0);
872}
873
874static bool_Bool drop_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
875
876 bool_Bool res = false0;
877 if (q->first == NULL((void*)0) || q->last == NULL((void*)0)) {
878 if (!(q->last == NULL((void*)0) && q->first == NULL((void*)0))) {
879 /* error state that should not happen */
880 return res;
881 }
882 /* Queue is empty */
883 return res;
884 }
885
886 eval_context_t *curr = q->first;
887 while (curr) {
888 if (curr->id == ctx->id) {
889 res = true1;
890 eval_context_t *tmp = curr->next;
891 if (curr->prev == NULL((void*)0)) {
892 if (curr->next == NULL((void*)0)) {
893 q->last = NULL((void*)0);
894 q->first = NULL((void*)0);
895 } else {
896 q->first = tmp;
897 tmp->prev = NULL((void*)0);
898 }
899 } else { /* curr->prev != NULL */
900 if (curr->next == NULL((void*)0)) {
901 q->last = curr->prev;
902 q->last->next = NULL((void*)0);
903 } else {
904 curr->prev->next = tmp;
905 tmp->prev = curr->prev;
906 }
907 }
908 break;
909 }
910 curr = curr->next;
911 }
912 return res;
913}
914
915/* End execution of the running context. */
916static void finish_ctx(void) {
917
918 if (!ctx_running) {
919 return;
920 }
921 /* Drop the continuation stack immediately to free up lbm_memory */
922 lbm_stack_free(&ctx_running->K);
923 ctx_done_callback(ctx_running);
924 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->name)) {
925 lbm_free(ctx_running->name);
926 }
927 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->error_reason)) {
928 lbm_memory_free((lbm_uint*)ctx_running->error_reason);
929 }
930 lbm_memory_free((lbm_uint*)ctx_running->mailbox);
931 lbm_memory_free((lbm_uint*)ctx_running);
932 ctx_running = NULL((void*)0);
933}
934
935static void context_exists(eval_context_t *ctx, void *cid, void *b) {
936 if (ctx->id == *(lbm_cid*)cid) {
937 *(bool_Bool*)b = true1;
938 }
939}
940
941bool_Bool lbm_wait_ctx(lbm_cid cid, lbm_uint timeout_ms) {
942
943 bool_Bool exists;
944 uint32_t i = 0;
945
946 do {
947 exists = false0;
948 lbm_blocked_iterator(context_exists, &cid, &exists);
949 lbm_running_iterator(context_exists, &cid, &exists);
950
951 if (ctx_running &&
952 ctx_running->id == cid) {
953 exists = true1;
954 }
955
956 if (exists) {
957 if (usleep_callback) {
958 usleep_callback(1000);
959 }
960 if (timeout_ms > 0) i ++;
961 }
962 } while (exists && i < timeout_ms);
963
964 if (exists) return false0;
965 return true1;
966}
967
968void lbm_set_error_suspect(lbm_value suspect) {
969 lbm_error_suspect = suspect;
970 lbm_error_has_suspect = true1;
971}
972
973void lbm_set_error_reason(char *error_str) {
974 if (ctx_running != NULL((void*)0)) {
975 ctx_running->error_reason = error_str;
976 }
977}
978
979// Not possible to CONS_WITH_GC in error_ctx_base (potential loop)
980static void error_ctx_base(lbm_value err_val, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int column) {
981
982 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
983 if (lbm_heap_num_free() < 3) {
984 gc();
985 }
986
987 if (lbm_heap_num_free() >= 3) {
988 lbm_value msg = lbm_cons(err_val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
989 msg = lbm_cons(lbm_enc_i(ctx_running->id), msg);
990 msg = lbm_cons(ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u), msg);
991 if (!lbm_is_symbol_merror(msg)) {
992 lbm_find_receiver_and_send(ctx_running->parent, msg);
993 goto error_ctx_base_done;
994 }
995 }
996 }
997 if ((ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10) &&
998 (err_val != ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u))) {
999 lbm_uint v;
1000 while (ctx_running->K.sp > 0) {
1001 lbm_pop(&ctx_running->K, &v);
1002 if (v == EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u)) {
1003 lbm_value *sptr = get_stack_ptr(ctx_running, 2);
1004 lbm_set_car(sptr[0], ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
1005 stack_reserve(ctx_running, 1)[0] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1006 ctx_running->app_cont = true1;
1007 ctx_running->r = err_val;
1008 longjmp(error_jmp_buf, 1);
1009 }
1010 }
1011 err_val = ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u);
1012 }
1013 print_error_message(err_val,
1014 has_at,
1015 at,
1016 row,
1017 column,
1018 ctx_running->row0,
1019 ctx_running->row1);
1020 error_ctx_base_done:
1021 ctx_running->r = err_val;
1022 finish_ctx();
1023 longjmp(error_jmp_buf, 1);
1024}
1025
1026static void error_at_ctx(lbm_value err_val, lbm_value at) {
1027 error_ctx_base(err_val, true1, at, 0, 0);
1028}
1029
1030static void error_ctx(lbm_value err_val) {
1031 error_ctx_base(err_val, false0, 0, 0, 0);
1032}
1033
1034static void read_error_ctx(unsigned int row, unsigned int column) {
1035 error_ctx_base(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u), false0, 0, row, column);
1036}
1037
1038void lbm_critical_error(void) {
1039 longjmp(critical_error_jmp_buf, 1);
1040}
1041
1042// successfully finish a context
1043static void ok_ctx(void) {
1044 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
1045 lbm_value msg;
1046 WITH_GC(msg, lbm_heap_allocate_list_init(3,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1047 ENC_SYM_EXIT_OK,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1048 lbm_enc_i(ctx_running->id),(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1049 ctx_running->r))(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
1050 lbm_find_receiver_and_send(ctx_running->parent, msg);
1051 }
1052 finish_ctx();
1053}
1054
1055static eval_context_t *dequeue_ctx_nm(eval_context_queue_t *q) {
1056 if (q->last == NULL((void*)0)) {
1057 return NULL((void*)0);
1058 }
1059 // q->first should only be NULL if q->last is.
1060 eval_context_t *res = q->first;
1061
1062 if (q->first == q->last) { // One thing in queue
1063 q->first = NULL((void*)0);
1064 q->last = NULL((void*)0);
1065 } else {
1066 q->first = q->first->next;
1067 q->first->prev = NULL((void*)0);
1068 }
1069 res->prev = NULL((void*)0);
1070 res->next = NULL((void*)0);
1071 return res;
1072}
1073
1074static void wake_up_ctxs_nm(void) {
1075 lbm_uint t_now;
1076
1077 if (timestamp_us_callback) {
1078 t_now = timestamp_us_callback();
1079 } else {
1080 t_now = 0;
1081 }
1082
1083 eval_context_queue_t *q = &blocked;
1084 eval_context_t *curr = q->first;
1085
1086 while (curr != NULL((void*)0)) {
1087 lbm_uint t_diff;
1088 eval_context_t *next = curr->next;
1089 if (curr->state != LBM_THREAD_STATE_BLOCKED(uint32_t)1) {
1090 if ( curr->timestamp > t_now) {
1091 /* There was an overflow on the counter */
1092#ifndef LBM64
1093 t_diff = (0xFFFFFFFF - curr->timestamp) + t_now;
1094#else
1095 t_diff = (0xFFFFFFFFFFFFFFFF - curr->timestamp) + t_now;
1096#endif
1097 } else {
1098 t_diff = t_now - curr->timestamp;
1099 }
1100
1101 if (t_diff >= curr->sleep_us) {
1102 eval_context_t *wake_ctx = curr;
1103 if (curr == q->last) {
1104 if (curr->prev) {
1105 q->last = curr->prev;
1106 q->last->next = NULL((void*)0);
1107 } else {
1108 q->first = NULL((void*)0);
1109 q->last = NULL((void*)0);
1110 }
1111 } else if (curr->prev == NULL((void*)0)) {
1112 q->first = curr->next;
1113 q->first->prev = NULL((void*)0);
1114 } else {
1115 curr->prev->next = curr->next;
1116 if (curr->next) {
1117 curr->next->prev = curr->prev;
1118 }
1119 }
1120 wake_ctx->next = NULL((void*)0);
1121 wake_ctx->prev = NULL((void*)0);
1122 if (curr->state == LBM_THREAD_STATE_TIMEOUT(uint32_t)2) {
1123 mailbox_add_mail(wake_ctx, ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u));
1124 wake_ctx->r = ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u);
1125 }
1126 wake_ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1127 enqueue_ctx_nm(&queue, wake_ctx);
1128 }
1129 }
1130 curr = next;
1131 }
1132}
1133
1134static void yield_ctx(lbm_uint sleep_us) {
1135 if (timestamp_us_callback) {
1136 ctx_running->timestamp = timestamp_us_callback();
1137 ctx_running->sleep_us = sleep_us;
1138 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1139 } else {
1140 ctx_running->timestamp = 0;
1141 ctx_running->sleep_us = 0;
1142 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1143 }
1144 ctx_running->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1145 ctx_running->app_cont = true1;
1146 enqueue_ctx(&blocked,ctx_running);
1147 ctx_running = NULL((void*)0);
1148}
1149
1150static lbm_cid lbm_create_ctx_parent(lbm_value program, lbm_value env, lbm_uint stack_size, lbm_cid parent, uint32_t context_flags, char *name) {
1151
1152 if (!lbm_is_cons(program)) return -1;
1153
1154 eval_context_t *ctx = NULL((void*)0);
1155
1156 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1157 if (ctx == NULL((void*)0)) {
1158 lbm_uint roots[2] = {program, env};
1159 lbm_gc_mark_roots(roots, 2);
1160 gc();
1161 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1162 }
1163 if (ctx == NULL((void*)0)) return -1;
1164
1165 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1166 lbm_uint roots[2] = {program, env};
1167 lbm_gc_mark_roots(roots, 2);
1168 gc();
1169 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1170 lbm_memory_free((lbm_uint*)ctx);
1171 return -1;
1172 }
1173 }
1174
1175 lbm_value *mailbox = NULL((void*)0);
1176 mailbox = (lbm_value*)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1177 if (mailbox == NULL((void*)0)) {
1178 lbm_value roots[2] = {program, env};
1179 lbm_gc_mark_roots(roots,2);
1180 gc();
1181 mailbox = (lbm_value *)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1182 }
1183 if (mailbox == NULL((void*)0)) {
1184 lbm_stack_free(&ctx->K);
1185 lbm_memory_free((lbm_uint*)ctx);
1186 return -1;
1187 }
1188
1189 // TODO: Limit names to 19 chars + 1 char for 0? (or something similar).
1190 if (name) {
1191 lbm_uint name_len = strlen(name) + 1;
1192 ctx->name = lbm_malloc(strlen(name) + 1);
1193 if (ctx->name == NULL((void*)0)) {
1194 lbm_value roots[2] = {program, env};
1195 lbm_gc_mark_roots(roots, 2);
1196 gc();
1197 ctx->name = lbm_malloc(strlen(name) + 1);
1198 }
1199 if (ctx->name == NULL((void*)0)) {
1200 lbm_stack_free(&ctx->K);
1201 lbm_memory_free((lbm_uint*)mailbox);
1202 lbm_memory_free((lbm_uint*)ctx);
1203 return -1;
1204 }
1205 memcpy(ctx->name, name, name_len+1);
1206 } else {
1207 ctx->name = NULL((void*)0);
1208 }
1209
1210 lbm_int cid = lbm_memory_address_to_ix((lbm_uint*)ctx);
1211
1212 ctx->program = lbm_cdr(program);
1213 ctx->curr_exp = lbm_car(program);
1214 ctx->curr_env = env;
1215 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1216 ctx->error_reason = NULL((void*)0);
1217 ctx->mailbox = mailbox;
1218 ctx->mailbox_size = EVAL_CPS_DEFAULT_MAILBOX_SIZE10;
1219 ctx->flags = context_flags;
1220 ctx->num_mail = 0;
1221 ctx->app_cont = false0;
1222 ctx->timestamp = 0;
1223 ctx->sleep_us = 0;
1224 ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1225 ctx->prev = NULL((void*)0);
1226 ctx->next = NULL((void*)0);
1227
1228 ctx->row0 = -1;
1229 ctx->row1 = -1;
1230
1231 ctx->id = cid;
1232 ctx->parent = parent;
1233
1234 if (!lbm_push(&ctx->K, DONE(((0) << 2) | 0xF8000001u))) {
1235 lbm_memory_free((lbm_uint*)ctx->mailbox);
1236 lbm_stack_free(&ctx->K);
1237 lbm_memory_free((lbm_uint*)ctx);
1238 return -1;
1239 }
1240
1241 enqueue_ctx(&queue,ctx);
1242
1243 return ctx->id;
1244}
1245
1246lbm_cid lbm_create_ctx(lbm_value program, lbm_value env, lbm_uint stack_size, char *name) {
1247 // Creates a parentless context.
1248 return lbm_create_ctx_parent(program,
1249 env,
1250 stack_size,
1251 -1,
1252 EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00,
1253 name);
1254}
1255
1256bool_Bool lbm_mailbox_change_size(eval_context_t *ctx, lbm_uint new_size) {
1257
1258 lbm_value *mailbox = NULL((void*)0);
1259 mailbox = (lbm_value*)lbm_memory_allocate(new_size);
1260 if (mailbox == NULL((void*)0)) {
1261 gc();
1262 mailbox = (lbm_value *)lbm_memory_allocate(new_size);
1263 }
1264 if (mailbox == NULL((void*)0)) {
1265 return false0;
1266 }
1267
1268 for (lbm_uint i = 0; i < ctx->num_mail; i ++ ) {
1269 mailbox[i] = ctx->mailbox[i];
1270 }
1271 lbm_memory_free(ctx->mailbox);
1272 ctx->mailbox = mailbox;
1273 ctx->mailbox_size = (uint32_t)new_size;
1274 return true1;
1275}
1276
1277static void mailbox_remove_mail(eval_context_t *ctx, lbm_uint ix) {
1278
1279 for (lbm_uint i = ix; i < ctx->num_mail-1; i ++) {
1280 ctx->mailbox[i] = ctx->mailbox[i+1];
1281 }
1282 ctx->num_mail --;
1283}
1284
1285static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail) {
1286
1287 if (ctx->num_mail >= ctx->mailbox_size) {
1288 mailbox_remove_mail(ctx, 0);
1289 }
1290
1291 ctx->mailbox[ctx->num_mail] = mail;
1292 ctx->num_mail ++;
1293 return true1;
1294}
1295
1296/* Advance execution to the next expression in the program */
1297static void advance_ctx(eval_context_t *ctx) {
1298 if (lbm_is_cons(ctx->program)) {
1299 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);;
1300 get_car_and_cdr(ctx->program, &ctx->curr_exp, &ctx->program);
1301 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1302 } else {
1303 if (ctx_running == ctx) { // This should always be the case because of odd historical reasons.
1304 ok_ctx();
1305 }
1306 }
1307}
1308
1309bool_Bool lbm_unblock_ctx(lbm_cid cid, lbm_flat_value_t *fv) {
1310 return event_internal(LBM_EVENT_UNBLOCK_CTX, (lbm_uint)cid, (lbm_uint)fv->buf, fv->buf_size);
1311}
1312
1313bool_Bool lbm_unblock_ctx_r(lbm_cid cid) {
1314 mutex_lock(&blocking_extension_mutex);
1315 bool_Bool r = false0;
1316 eval_context_t *found = NULL((void*)0);
1317 mutex_lock(&qmutex);
1318 found = lookup_ctx_nm(&blocked, cid);
1319 if (found) {
1320 drop_ctx_nm(&blocked,found);
1321 enqueue_ctx_nm(&queue,found);
1322 r = true1;
1323 }
1324 mutex_unlock(&qmutex);
1325 mutex_unlock(&blocking_extension_mutex);
1326 return r;
1327}
1328
1329// unblock unboxed is also safe for rmbr:ed things.
1330bool_Bool lbm_unblock_ctx_unboxed(lbm_cid cid, lbm_value unboxed) {
1331 mutex_lock(&blocking_extension_mutex);
1332 bool_Bool r = false0;
1333 eval_context_t *found = NULL((void*)0);
1334 mutex_lock(&qmutex);
1335 found = lookup_ctx_nm(&blocked, cid);
1336 if (found) {
1337 drop_ctx_nm(&blocked,found);
1338 found->r = unboxed;
1339 if (lbm_is_error(unboxed)) {
1340 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
1341 found->app_cont = true1;
1342 }
1343 enqueue_ctx_nm(&queue,found);
1344 r = true1;
1345 }
1346 mutex_unlock(&qmutex);
1347 mutex_unlock(&blocking_extension_mutex);
1348 return r;
1349}
1350
1351static bool_Bool lbm_block_ctx_base(bool_Bool timeout, float t_s) {
1352 mutex_lock(&blocking_extension_mutex);
1353 blocking_extension = true1;
1354 if (timeout) {
1355 blocking_extension_timeout_us = S_TO_US(t_s)(lbm_uint)((t_s) * 1000000);
1356 blocking_extension_timeout = true1;
1357 } else {
1358 blocking_extension_timeout = false0;
1359 }
1360 return true1;
1361}
1362
1363void lbm_block_ctx_from_extension_timeout(float s) {
1364 lbm_block_ctx_base(true1, s);
1365}
1366
1367void lbm_block_ctx_from_extension(void) {
1368 lbm_block_ctx_base(false0, 0);
1369}
1370
1371// todo: May need to pop rmbrs from stack, if present.
1372// Suspect that the letting the discard cont run is really not a problem.
1373// Either way will be quite confusing what happens to allocated things when undoing block.
1374void lbm_undo_block_ctx_from_extension(void) {
1375 blocking_extension = false0;
1376 blocking_extension_timeout_us = 0;
1377 blocking_extension_timeout = false0;
1378 mutex_unlock(&blocking_extension_mutex);
1379}
1380
1381lbm_value lbm_find_receiver_and_send(lbm_cid cid, lbm_value msg) {
1382 mutex_lock(&qmutex);
1383 eval_context_t *found = NULL((void*)0);
1384 bool_Bool found_blocked = false0;
1385
1386 found = lookup_ctx_nm(&blocked, cid);
1387 if (found) found_blocked = true1;
1388
1389 if (found == NULL((void*)0)) {
1390 found = lookup_ctx_nm(&queue, cid);
1391 }
1392
1393 if (found) {
1394 if (!mailbox_add_mail(found, msg)) {
1395 mutex_unlock(&qmutex);
1396 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1397 }
1398
1399 if (found_blocked){
1400 drop_ctx_nm(&blocked,found);
1401 enqueue_ctx_nm(&queue,found);
1402 }
1403 mutex_unlock(&qmutex);
1404 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1405 }
1406
1407 /* check the current context */
1408 if (ctx_running && ctx_running->id == cid) {
1409 if (!mailbox_add_mail(ctx_running, msg)) {
1410 mutex_unlock(&qmutex);
1411 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1412 }
1413 mutex_unlock(&qmutex);
1414 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1415 }
1416 mutex_unlock(&qmutex);
1417 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1418}
1419
1420/* Pattern matching is currently implemented as a recursive
1421 function and make use of stack relative to the size of
1422 expressions that are being matched. */
1423static bool_Bool match(lbm_value p, lbm_value e, lbm_value *env, bool_Bool *gc) {
1424
1425 lbm_value binding;
1426
1427 if (lbm_is_match_binder(p)) {
1428 lbm_value var = get_cadr(p);
1429 lbm_value bindertype = get_car(p);
1430
1431 if (!lbm_is_symbol(var)) return false0;
1432
1433 switch (bindertype) {
1434 case ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u):
1435 if ( var == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) {
1436 return true1;
1437 }
1438 break;
1439 default: /* this should be an error case */
1440 return false0;
1441 }
1442 binding = lbm_cons(var, e);
1443 if ( lbm_type_of(binding) == LBM_TYPE_SYMBOL0x00000000u ) {
1444 *gc = true1;
1445 return false0;
1446 }
1447 *env = lbm_cons(binding, *env);
1448 if ( lbm_type_of(*env) == LBM_TYPE_SYMBOL0x00000000u ) {
1449 *gc = true1;
1450 return false0;
1451 }
1452 return true1;
1453 }
1454
1455 if (lbm_is_symbol(p)) {
1456 if (p == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return true1;
1457 return (p == e);
1458 }
1459 if (lbm_is_cons(p) &&
1460 lbm_is_cons(e) ) {
1461
1462 lbm_value headp, tailp;
1463 lbm_value heade, taile;
1464 get_car_and_cdr(p, &headp, &tailp);
1465 get_car_and_cdr(e, &heade, &taile); // Static analysis warns, but execution does not
1466 // past this point unless head and tail get initialized.
1467 if (!match(headp, heade, env, gc)) {
1468 return false0;
1469 }
1470 return match (tailp, taile, env, gc);
1471 }
1472 return struct_eq(p, e);
1473}
1474
1475// Find match is not very picky about syntax.
1476// A completely malformed recv form is most likely to
1477// just return no_match.
1478static int find_match(lbm_value plist, lbm_value *earr, lbm_uint num, lbm_value *e, lbm_value *env) {
1479
1480 // A pattern list is a list of pattern, expression lists.
1481 // ( (p1 e1) (p2 e2) ... (pn en))
1482 lbm_value curr_p = plist;
1483 int n = 0;
1484 bool_Bool gc = false0;
1485 for (int i = 0; i < (int)num; i ++ ) {
1486 lbm_value curr_e = earr[i];
1487 while (!lbm_is_symbol_nil(curr_p)) {
1488 lbm_value me = get_car(curr_p);
1489 if (match(get_car(me), curr_e, env, &gc)) {
1490 if (gc) return FM_NEED_GC-1;
1491 *e = get_cadr(me);
1492
1493 if (!lbm_is_symbol_nil(get_cadr(get_cdr(me)))) {
1494 return FM_PATTERN_ERROR-3;
1495 }
1496 return n;
1497 }
1498 curr_p = get_cdr(curr_p);
1499 }
1500 curr_p = plist; /* search all patterns against next exp */
1501 n ++;
1502 }
1503
1504 return FM_NO_MATCH-2;
1505}
1506
1507/****************************************************/
1508/* Garbage collection */
1509
1510static void mark_context(eval_context_t *ctx, void *arg1, void *arg2) {
1511 (void) arg1;
1512 (void) arg2;
1513 lbm_value roots[3] = {ctx->curr_exp, ctx->program, ctx->r };
1514 lbm_gc_mark_env(ctx->curr_env);
1515 lbm_gc_mark_roots(roots, 3);
1516 lbm_gc_mark_roots(ctx->mailbox, ctx->num_mail);
1517 lbm_gc_mark_aux(ctx->K.data, ctx->K.sp);
1518}
1519
1520static int gc(void) {
1521 if (ctx_running) {
1522 ctx_running->state = ctx_running->state | LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1523 }
1524
1525 gc_requested = false0;
1526 lbm_gc_state_inc();
1527
1528 // The freelist should generally be NIL when GC runs.
1529 lbm_nil_freelist();
1530 lbm_value *env = lbm_get_global_env();
1531 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
1532 lbm_gc_mark_env(env[i]);
1533 }
1534
1535 mutex_lock(&qmutex); // Lock the queues.
1536 // Any concurrent messing with the queues
1537 // while doing GC cannot possibly be good.
1538 queue_iterator_nm(&queue, mark_context, NULL((void*)0), NULL((void*)0));
1539 queue_iterator_nm(&blocked, mark_context, NULL((void*)0), NULL((void*)0));
1540
1541 if (ctx_running) {
1542 mark_context(ctx_running, NULL((void*)0), NULL((void*)0));
1543 }
1544 mutex_unlock(&qmutex);
1545
1546#ifdef VISUALIZE_HEAP
1547 heap_vis_gen_image();
1548#endif
1549
1550 int r = lbm_gc_sweep_phase();
1551 lbm_heap_new_freelist_length();
1552
1553 if (ctx_running) {
1554 ctx_running->state = ctx_running->state & ~LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1555 }
1556 return r;
1557}
1558
1559int lbm_perform_gc(void) {
1560 return gc();
1561}
1562
1563/****************************************************/
1564/* Evaluation functions */
1565
1566
1567static void eval_symbol(eval_context_t *ctx) {
1568 lbm_uint s = lbm_dec_sym(ctx->curr_exp);
1569 if (s >= RUNTIME_SYMBOLS_START0x40000) {
1570 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1571 if (lbm_env_lookup_b(&res, ctx->curr_exp, ctx->curr_env) ||
1572 lbm_global_env_lookup(&res, ctx->curr_exp)) {
1573 ctx->r = res;
1574 ctx->app_cont = true1;
1575 return;
1576 }
1577 // Dynamic load attempt
1578 // Only symbols of kind RUNTIME can be dynamically loaded.
1579 const char *sym_str = lbm_get_name_by_symbol(s);
1580 const char *code_str = NULL((void*)0);
1581 if (!dynamic_load_callback(sym_str, &code_str)) {
1582 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), ctx->curr_exp);
1583 }
1584 lbm_value *sptr = stack_reserve(ctx, 3);
1585 sptr[0] = ctx->curr_exp;
1586 sptr[1] = ctx->curr_env;
1587 sptr[2] = RESUME(((12) << 2) | 0xF8000001u);
1588
1589 lbm_value chan;
1590 if (!create_string_channel((char *)code_str, &chan)) {
1591 gc();
1592 if (!create_string_channel((char *)code_str, &chan)) {
1593 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1594 }
1595 }
1596
1597 lbm_value loader;
1598 WITH_GC_RMBR_1(loader, lbm_heap_allocate_list_init(2,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1599 ENC_SYM_READ,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1600 chan), chan)(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} };
1601 lbm_value evaluator;
1602 WITH_GC_RMBR_1(evaluator, lbm_heap_allocate_list_init(2,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1603 ENC_SYM_EVAL,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1604 loader), loader)(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } };
1605 ctx->curr_exp = evaluator;
1606 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // dynamics should be evaluable in empty local env
1607 } else {
1608 //special symbols and extensions can be handled the same way.
1609 ctx->r = ctx->curr_exp;
1610 ctx->app_cont = true1;
1611 }
1612}
1613
1614static void eval_quote(eval_context_t *ctx) {
1615 ctx->r = get_cadr(ctx->curr_exp);
1616 ctx->app_cont = true1;
1617}
1618
1619static void eval_selfevaluating(eval_context_t *ctx) {
1620 ctx->r = ctx->curr_exp;
1621 ctx->app_cont = true1;
1622}
1623
1624static void eval_progn(eval_context_t *ctx) {
1625 lbm_value exps = get_cdr(ctx->curr_exp);
1626
1627 if (lbm_is_cons(exps)) {
1628 lbm_uint *sptr = stack_reserve(ctx, 4);
1629 sptr[0] = ctx->curr_env; // env to restore between expressions in progn
1630 sptr[1] = lbm_enc_u(0); // Has env been copied (needed for progn local bindings)
1631 sptr[3] = PROGN_REST(((4) << 2) | 0xF8000001u);
1632 get_car_and_cdr(exps, &ctx->curr_exp, &sptr[2]);
1633 if (lbm_is_symbol(sptr[2])) /* The only symbol it can be is nil */
1634 lbm_stack_drop(&ctx->K, 4);
1635 } else if (lbm_is_symbol_nil(exps)) {
1636 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1637 ctx->app_cont = true1;
1638 } else {
1639 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1640 }
1641}
1642
1643static void eval_atomic(eval_context_t *ctx) {
1644 if (is_atomic) {
1645 lbm_set_error_reason("Atomic blocks cannot be nested!");
1646 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1647 }
1648 stack_reserve(ctx, 1)[0] = EXIT_ATOMIC(((14) << 2) | 0xF8000001u);
1649 is_atomic ++;
1650 eval_progn(ctx);
1651}
1652
1653/* (call-cc (lambda (k) .... )) */
1654static void eval_callcc(eval_context_t *ctx) {
1655 lbm_value cont_array;
1656 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1657 gc();
1658 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1659 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1660 return; // dead return but static analysis doesn't know :)
1661 }
1662 }
1663 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(cont_array);
1664 memcpy(arr->data, ctx->K.data, ctx->K.sp * sizeof(lbm_uint));
1665
1666 lbm_value acont = cons_with_gc(ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u), cont_array, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1667 lbm_value arg_list = cons_with_gc(acont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1668 // Go directly into application evaluation without passing go
1669 lbm_uint *sptr = stack_reserve(ctx, 3);
1670 sptr[0] = ctx->curr_env;
1671 sptr[1] = arg_list;
1672 sptr[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
1673 ctx->curr_exp = get_cadr(ctx->curr_exp);
1674}
1675
1676// (define sym exp)
1677#define KEY1 1
1678#define VAL2 2
1679static void eval_define(eval_context_t *ctx) {
1680 lbm_value parts[3];
1681 lbm_value rest = extract_n(ctx->curr_exp, parts, 3);
1682 lbm_uint *sptr = stack_reserve(ctx, 2);
1683 if (lbm_is_symbol(parts[KEY1]) && lbm_is_symbol_nil(rest)) {
1684 lbm_uint sym_val = lbm_dec_sym(parts[KEY1]);
1685 sptr[0] = parts[KEY1];
1686 if (sym_val >= RUNTIME_SYMBOLS_START0x40000) {
1687 sptr[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
1688 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02) {
1689 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
1690 }
1691 ctx->curr_exp = parts[VAL2];
1692 return;
1693 }
1694 }
1695 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
1696}
1697
1698
1699/* Eval lambda is cheating, a lot! It does this
1700 for performance reasons. The cheats are that
1701 1. When closure is created, a reference to the local env
1702 in which the lambda was evaluated is added to the closure.
1703 Ideally it should have created a list of free variables in the function
1704 and then looked up the values of these creating a new environment.
1705 2. The global env is considered global constant. As there is no copying
1706 of environment bindings into the closure, undefine may break closures.
1707
1708 Correct closure creation is a lot more expensive than what happens here.
1709 However, one can try to write programs in such a way that closures are created
1710 seldomly. If one does that the space-usage benefits of "correct" closures
1711 may outweigh the performance gain of "incorrect" ones.
1712
1713 some obscure programs such as test_setq_local_closure.lisp does not
1714 work properly due to this cheating.
1715 */
1716// (lambda param-list body-exp) -> (closure param-list body-exp env)
1717static void eval_lambda(eval_context_t *ctx) {
1718 lbm_value vals[3];
1719 extract_n(ctx->curr_exp, vals, 3);
1720 ctx->r = allocate_closure(vals[1],vals[2], ctx->curr_env);
1721#ifdef CLEAN_UP_CLOSURES
1722 lbm_uint sym_id = 0;
1723 if (clean_cl_env_symbol) {
1724 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1725 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1726 ctx->curr_exp = app;
1727 } else if (lbm_get_symbol_by_name("clean-cl-env", &sym_id)) {
1728 clean_cl_env_symbol = lbm_enc_sym(sym_id);
1729 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1730 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1731 ctx->curr_exp = app;
1732 } else {
1733 ctx->app_cont = true1;
1734 }
1735#else
1736 ctx->app_cont = true1;
1737#endif
1738}
1739
1740// (if cond-expr then-expr else-expr)
1741static void eval_if(eval_context_t *ctx) {
1742 lbm_value cdr = get_cdr(ctx->curr_exp);
1743 lbm_value *sptr = stack_reserve(ctx, 3);
1744 sptr[0] = get_cdr(cdr);
1745 sptr[1] = ctx->curr_env;
1746 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1747 ctx->curr_exp = get_car(cdr);
1748}
1749
1750// (cond (cond-expr-1 expr-1)
1751// ...
1752// (cond-expr-N expr-N))
1753static void eval_cond(eval_context_t *ctx) {
1754 lbm_value cond1[2];
1755 lbm_value rest_conds = extract_n(ctx->curr_exp, cond1, 2);
1756
1757 // end recursion at (cond )
1758 if (lbm_is_symbol_nil(cond1[1])) {
1759 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1760 ctx->app_cont = true1;
1761 } else {
1762 // Cond is one of the few places where a bit of syntax checking takes place at runtime..
1763 // Maybe dont bother?
1764 lbm_uint len = lbm_list_length(cond1[1]);
1765 if (len != 2) {
1766 lbm_set_error_reason("Incorrect syntax in cond");
1767 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1768 }
1769 lbm_value cond_expr[2];
1770 extract_n(cond1[1], cond_expr, 2);
1771 lbm_value rest;
1772 WITH_GC(rest, lbm_heap_allocate_list_init(2,(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1773 cond_expr[1], // Then branch(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1774 cons_with_gc(ENC_SYM_COND, rest_conds , ENC_SYM_NIL)))(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
1775 lbm_value *sptr = stack_reserve(ctx, 3);
1776 sptr[0] = rest;
1777 sptr[1] = ctx->curr_env;
1778 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1779 ctx->curr_exp = cond_expr[0]; //condition;
1780 }
1781}
1782
1783static void eval_app_cont(eval_context_t *ctx) {
1784 lbm_stack_drop(&ctx->K, 1);
1785 ctx->app_cont = true1;
1786}
1787
1788// Create a named location in an environment to later receive a value.
1789static binding_location_status create_binding_location_internal(lbm_value key, lbm_value *env) {
1790
1791 if (lbm_is_symbol(key) &&
1792 (key == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u) ||
1793 key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)))
1794 return BL_OK;
1795
1796 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) { // default case
1797 lbm_value binding;
1798 lbm_value new_env_tmp;
1799 binding = lbm_cons(key, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1800 new_env_tmp = lbm_cons(binding, *env);
1801 if (lbm_is_symbol(binding) || lbm_is_symbol(new_env_tmp)) {
1802 return BL_NO_MEMORY;
1803 }
1804 *env = new_env_tmp;
1805 } else if (lbm_is_cons(key)) { // deconstruct case
1806 int r = create_binding_location_internal(get_car(key), env);
1807 if (r == BL_OK) {
1808 r = create_binding_location_internal(get_cdr(key), env);
1809 }
1810 return r;
1811 }
1812 return BL_OK;
1813}
1814
1815static void create_binding_location(lbm_value key, lbm_value *env) {
1816
1817 lbm_value env_tmp = *env;
1818 binding_location_status r = create_binding_location_internal(key, &env_tmp);
1819 if (r != BL_OK) {
1820 if (r == BL_NO_MEMORY) {
1821 env_tmp = *env;
1822 lbm_gc_mark_phase(env_tmp);
1823 gc();
1824 r = create_binding_location_internal(key, &env_tmp);
1825 }
1826 switch(r) {
1827 case BL_OK:
1828 break;
1829 case BL_NO_MEMORY:
1830 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1831 break;
1832 case BL_INCORRECT_KEY:
1833 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
1834 break;
1835 }
1836 }
1837 *env = env_tmp;
1838}
1839
1840static void let_bind_values_eval(lbm_value binds, lbm_value exp, lbm_value env, eval_context_t *ctx) {
1841
1842 if (!lbm_is_cons(binds)) {
1843 // binds better be nil or there is a programmer error.
1844 ctx->curr_exp = exp;
1845 return;
1846 }
1847
1848 // Preallocate binding locations.
1849 lbm_value curr = binds;
1850 while (lbm_is_cons(curr)) {
1851 lbm_value new_env_tmp = env;
1852 lbm_value car_curr, cdr_curr;
1853 get_car_and_cdr(curr, &car_curr, &cdr_curr);
1854 lbm_value key = get_car(car_curr);
1855 create_binding_location(key, &new_env_tmp);
1856 env = new_env_tmp;
1857 curr = cdr_curr;
1858 }
1859
1860 lbm_value car_binds;
1861 lbm_value cdr_binds;
1862 get_car_and_cdr(binds, &car_binds, &cdr_binds);
1863 lbm_value key_val[2];
1864 extract_n(car_binds, key_val, 2);
1865
1866 lbm_uint *sptr = stack_reserve(ctx, 5);
1867 sptr[0] = exp;
1868 sptr[1] = cdr_binds;
1869 sptr[2] = env;
1870 sptr[3] = key_val[0];
1871 sptr[4] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
1872 ctx->curr_exp = key_val[1];
1873 ctx->curr_env = env;
1874}
1875
1876// (var x (...)) - local binding inside of an progn
1877// var has to take, place root-level nesting within progn.
1878// (progn ... (var a 10) ...) OK!
1879// (progn ... (something (var a 10)) ... ) NOT OK!
1880/* progn stack
1881 sp-4 : env
1882 sp-3 : 0
1883 sp-2 : rest
1884 sp-1 : PROGN_REST
1885*/
1886static void eval_var(eval_context_t *ctx) {
1887
1888 if (ctx->K.sp >= 4) { // Possibly in progn
1889 lbm_value sv = ctx->K.data[ctx->K.sp - 1];
1890 if (IS_CONTINUATION(sv)(((sv) & 0xF8000001u) == 0xF8000001u) && (sv == PROGN_REST(((4) << 2) | 0xF8000001u))) {
1891 lbm_uint sp = ctx->K.sp;
1892 uint32_t is_copied = lbm_dec_as_u32(ctx->K.data[sp-3]);
1893 if (is_copied == 0) {
1894 lbm_value env;
1895 WITH_GC(env, lbm_env_copy_spine(ctx->K.data[sp-4]))(env) = (lbm_env_copy_spine(ctx->K.data[sp-4])); if (lbm_is_symbol_merror
((env))) { gc(); (env) = (lbm_env_copy_spine(ctx->K.data[sp
-4])); if (lbm_is_symbol_merror((env))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1896 ctx->K.data[sp-3] = lbm_enc_u(1);
1897 ctx->K.data[sp-4] = env;
1898 }
1899 lbm_value new_env = ctx->K.data[sp-4];
1900 lbm_value args = get_cdr(ctx->curr_exp);
1901 lbm_value key = get_car(args);
1902 create_binding_location(key, &new_env);
1903 ctx->K.data[sp-4] = new_env;
1904
1905 lbm_value v_exp = get_cadr(args);
1906 lbm_value *sptr = stack_reserve(ctx, 3);
1907 sptr[0] = new_env;
1908 sptr[1] = key;
1909 sptr[2] = PROGN_VAR(((29) << 2) | 0xF8000001u);
1910 // Activating the new environment before the evaluation of the value to be bound,
1911 // means that other variables with same name will be shadowed already in the value
1912 // body.
1913 // The way closures work, the var-variable needs to be in scope during val evaluation
1914 // for a recursive closure to be possible.
1915 ctx->curr_env = new_env;
1916 ctx->curr_exp = v_exp;
1917 return;
1918 }
1919 }
1920 lbm_set_error_reason((char*)lbm_error_str_var_outside_progn);
1921 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1922}
1923
1924// (setq x (...)) - same as (set 'x (...)) or (setvar 'x (...))
1925static void eval_setq(eval_context_t *ctx) {
1926 lbm_value parts[3];
1927 extract_n(ctx->curr_exp, parts, 3);
1928 lbm_value *sptr = stack_reserve(ctx, 3);
1929 sptr[0] = ctx->curr_env;
1930 sptr[1] = parts[1];
1931 sptr[2] = SETQ(((30) << 2) | 0xF8000001u);
1932 ctx->curr_exp = parts[2];
1933}
1934
1935static void eval_move_to_flash(eval_context_t *ctx) {
1936 lbm_value args = get_cdr(ctx->curr_exp);
1937 lbm_value *sptr = stack_reserve(ctx,2);
1938 sptr[0] = args;
1939 sptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
1940 ctx->app_cont = true1;
1941}
1942
1943// (loop list-of-local-bindings
1944// condition-exp
1945// body-exp)
1946static void eval_loop(eval_context_t *ctx) {
1947 lbm_value env = ctx->curr_env;
1948 lbm_value parts[3];
1949 extract_n(get_cdr(ctx->curr_exp), parts, 3);
1950 lbm_value *sptr = stack_reserve(ctx, 3);
1951 sptr[0] = parts[LOOP_BODY2];
1952 sptr[1] = parts[LOOP_COND1];
1953 sptr[2] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
1954 let_bind_values_eval(parts[LOOP_BINDS0], parts[LOOP_COND1], env, ctx);
1955}
1956
1957/* (trap expression)
1958 *
1959 * suggested use:
1960 * (match (trap expression)
1961 * ((exit-error (? err)) (error-handler err))
1962 * ((exit-ok (? v)) (value-handler v)))
1963 */
1964static void eval_trap(eval_context_t *ctx) {
1965
1966 lbm_value expr = get_cadr(ctx->curr_exp);
1967 lbm_value retval;
1968 WITH_GC(retval, lbm_heap_allocate_list(2))(retval) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((retval))) { gc(); (retval) = (lbm_heap_allocate_list(2)); if
(lbm_is_symbol_merror((retval))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1969 lbm_set_car(retval, ENC_SYM_EXIT_OK(((0x3000B) << 4) | 0x00000000u)); // Assume things will go well.
1970 lbm_uint *sptr = stack_reserve(ctx,3);
1971 sptr[0] = retval;
1972 sptr[1] = ctx->flags;
1973 sptr[2] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1974 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10;
1975 ctx->curr_exp = expr;
1976}
1977
1978// (let list-of-binding s
1979// body-exp)
1980static void eval_let(eval_context_t *ctx) {
1981 lbm_value env = ctx->curr_env;
1982 lbm_value parts[3];
1983 extract_n(ctx->curr_exp, parts, 3);
1984 let_bind_values_eval(parts[1], parts[2], env, ctx);
1985}
1986
1987// (and exp0 ... expN)
1988static void eval_and(eval_context_t *ctx) {
1989 lbm_value rest = get_cdr(ctx->curr_exp);
1990 if (lbm_is_symbol_nil(rest)) {
1991 ctx->app_cont = true1;
1992 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1993 } else {
1994 lbm_value *sptr = stack_reserve(ctx, 3);
1995 sptr[0] = ctx->curr_env;
1996 sptr[1] = get_cdr(rest);
1997 sptr[2] = AND(((6) << 2) | 0xF8000001u);
1998 ctx->curr_exp = get_car(rest);
1999 }
2000}
2001
2002// (or exp0 ... expN)
2003static void eval_or(eval_context_t *ctx) {
2004 lbm_value rest = get_cdr(ctx->curr_exp);
2005 if (lbm_is_symbol_nil(rest)) {
2006 ctx->app_cont = true1;
2007 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2008 } else {
2009 lbm_value *sptr = stack_reserve(ctx, 3);
2010 sptr[0] = ctx->curr_env;
2011 sptr[1] = get_cdr(rest);
2012 sptr[2] = OR(((7) << 2) | 0xF8000001u);
2013 ctx->curr_exp = get_car(rest);
2014 }
2015}
2016
2017// Pattern matching
2018// format:
2019// (match e (pattern body)
2020// (pattern body)
2021// ... )
2022//
2023// There can be an optional pattern guard:
2024// (match e (pattern guard body)
2025// ... )
2026// a guard is a boolean expression.
2027// Guards make match, pattern matching more complicated
2028// than the recv pattern matching and requires staged execution
2029// via the continuation system rather than a while loop over a list.
2030static void eval_match(eval_context_t *ctx) {
2031
2032 lbm_value rest = get_cdr(ctx->curr_exp);
2033 if (lbm_type_of(rest) == LBM_TYPE_SYMBOL0x00000000u &&
2034 rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
2035 // Someone wrote the program (match)
2036 ctx->app_cont = true1;
2037 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2038 } else {
2039 lbm_value cdr_rest;
2040 get_car_and_cdr(rest, &ctx->curr_exp, &cdr_rest);
2041 lbm_value *sptr = stack_reserve(ctx, 3);
2042 sptr[0] = cdr_rest;
2043 sptr[1] = ctx->curr_env;
2044 sptr[2] = MATCH(((9) << 2) | 0xF8000001u);
2045 }
2046}
2047
2048static void receive_base(eval_context_t *ctx, lbm_value pats, float timeout_time, bool_Bool timeout) {
2049 if (ctx->num_mail == 0) {
2050 if (timeout) {
2051 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000), false0);
2052 } else {
2053 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1,0,false0);
2054 }
2055 } else {
2056 lbm_value *msgs = ctx->mailbox;
2057 lbm_uint num = ctx->num_mail;
2058
2059 if (lbm_is_symbol_nil(pats)) {
2060 /* A receive statement without any patterns */
2061 ctx->app_cont = true1;
2062 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2063 } else {
2064 /* The common case */
2065 lbm_value e;
2066 lbm_value new_env = ctx->curr_env;
2067 int n = find_match(pats, msgs, num, &e, &new_env);
2068 if (n == FM_NEED_GC-1) {
2069 gc();
2070 new_env = ctx->curr_env;
2071 n = find_match(pats, msgs, num, &e, &new_env);
2072 if (n == FM_NEED_GC-1) {
2073 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2074 }
2075 }
2076 if (n == FM_PATTERN_ERROR-3) {
2077 lbm_set_error_reason("Incorrect pattern format for recv");
2078 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),pats);
2079 } else if (n >= 0 ) { /* Match */
2080 mailbox_remove_mail(ctx, (lbm_uint)n);
2081 ctx->curr_env = new_env;
2082 ctx->curr_exp = e;
2083 } else { /* No match go back to sleep */
2084 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
2085 if (timeout) {
2086 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2,S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000),false0);
2087 } else {
2088 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,false0);
2089 }
2090 }
2091 }
2092 }
2093 return;
2094}
2095
2096static void eval_receive_timeout(eval_context_t *ctx) {
2097 if (is_atomic) {
2098 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2099 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2100 }
2101 lbm_value timeout_val = get_cadr(ctx->curr_exp);
2102 if (!lbm_is_number(timeout_val)) {
2103 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2104 }
2105 float timeout_time = lbm_dec_as_float(timeout_val);
2106 lbm_value pats = get_cdr(get_cdr(ctx->curr_exp));
2107 receive_base(ctx, pats, timeout_time, true1);
2108}
2109
2110// Receive
2111// (recv (pattern expr)
2112// (pattern expr))
2113static void eval_receive(eval_context_t *ctx) {
2114
2115 if (is_atomic) {
2116 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2117 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
2118 }
2119 lbm_value pats = get_cdr(ctx->curr_exp);
2120 receive_base(ctx, pats, 0, false0);
2121}
2122
2123/*********************************************************/
2124/* Continuation functions */
2125
2126/* cont_set_global_env
2127 sp-1 : Key-symbol
2128 */
2129static void cont_set_global_env(eval_context_t *ctx){
2130
2131 lbm_value key;
2132 lbm_value val = ctx->r;
2133
2134 lbm_pop(&ctx->K, &key);
2135 lbm_uint dec_key = lbm_dec_sym(key);
2136 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
2137 lbm_value *global_env = lbm_get_global_env();
2138 lbm_uint orig_env = global_env[ix_key];
2139 lbm_value new_env;
2140 // A key is a symbol and should not need to be remembered.
2141 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2142
2143 global_env[ix_key] = new_env;
2144 ctx->r = val;
2145
2146 ctx->app_cont = true1;
2147
2148 return;
2149}
2150
2151static void cont_resume(eval_context_t *ctx) {
2152 lbm_pop_2(&ctx->K, &ctx->curr_env, &ctx->curr_exp);
2153}
2154
2155static void cont_progn_rest(eval_context_t *ctx) {
2156 lbm_value *sptr = get_stack_ptr(ctx, 3);
2157
2158 lbm_value rest = sptr[2];
2159 lbm_value env = sptr[0];
2160
2161 lbm_value rest_car, rest_cdr;
2162 get_car_and_cdr(rest, &rest_car, &rest_cdr);
2163 ctx->curr_exp = rest_car;
2164 ctx->curr_env = env;
2165 if (lbm_is_symbol_nil(rest_cdr)) {
2166 // allow for tail recursion
2167 lbm_stack_drop(&ctx->K, 3);
2168 } else {
2169 sptr[2] = rest_cdr;
2170 stack_reserve(ctx, 1)[0] = PROGN_REST(((4) << 2) | 0xF8000001u);
2171 }
2172}
2173
2174static void cont_wait(eval_context_t *ctx) {
2175
2176 lbm_value cid_val;
2177 lbm_pop(&ctx->K, &cid_val);
2178 lbm_cid cid = (lbm_cid)lbm_dec_i(cid_val);
2179
2180 bool_Bool exists = false0;
2181
2182 lbm_blocked_iterator(context_exists, &cid, &exists);
2183 lbm_running_iterator(context_exists, &cid, &exists);
2184
2185 if (ctx_running->id == cid) {
2186 exists = true1;
2187 }
2188
2189 if (exists) {
2190 lbm_value *sptr = stack_reserve(ctx, 2);
2191 sptr[0] = lbm_enc_i(cid);
2192 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2193 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2194 ctx->app_cont = true1;
2195 yield_ctx(50000);
2196 } else {
2197 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2198 ctx->app_cont = true1;
2199 }
2200}
2201
2202static lbm_value perform_setvar(lbm_value key, lbm_value val, lbm_value env) {
2203
2204 lbm_uint s = lbm_dec_sym(key);
2205 if (s >= RUNTIME_SYMBOLS_START0x40000) {
2206 lbm_value new_env = lbm_env_modify_binding(env, key, val);
2207 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2208 lbm_uint ix_key = lbm_dec_sym(key) & GLOBAL_ENV_MASK0x1F;
2209 lbm_value *glob_env = lbm_get_global_env();
2210 new_env = lbm_env_modify_binding(glob_env[ix_key], key, val);
2211 glob_env[ix_key] = new_env;
2212 }
2213 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2214 lbm_set_error_reason((char*)lbm_error_str_variable_not_bound);
2215 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), key);
2216 }
2217 return val;
2218 }
2219 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2220 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // unreachable
2221}
2222
2223static void apply_setvar(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2224 if (nargs == 2 && lbm_is_symbol(args[0])) {
2225 lbm_value res;
2226 WITH_GC(res, perform_setvar(args[0], args[1], ctx->curr_env))(res) = (perform_setvar(args[0], args[1], ctx->curr_env));
if (lbm_is_symbol_merror((res))) { gc(); (res) = (perform_setvar
(args[0], args[1], ctx->curr_env)); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2227 ctx->r = args[1];
2228 lbm_stack_drop(&ctx->K, nargs+1);
2229 ctx->app_cont = true1;
2230 } else {
2231 if (nargs == 2) lbm_set_error_reason((char*)lbm_error_str_incorrect_arg);
2232 else lbm_set_error_reason((char*)lbm_error_str_num_args);
2233 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2234 }
2235}
2236
2237static void apply_read_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, bool_Bool program, bool_Bool incremental) {
2238 if (nargs == 1) {
2239 lbm_value chan = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2240 if (lbm_type_of_functional(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2241 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2242 gc();
2243 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2244 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2245 }
2246 }
2247 } else if (lbm_type_of(args[0]) == LBM_TYPE_CHANNEL0x90000000u) {
2248 chan = args[0];
2249 } else {
2250 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2251 }
2252 lbm_value *sptr = get_stack_ptr(ctx, 2);
2253
2254 // If we are inside a reader, its settings are stored.
2255 sptr[0] = lbm_enc_u(ctx->flags); // flags stored.
2256 sptr[1] = chan;
2257 lbm_value *rptr = stack_reserve(ctx,1);
2258 rptr[0] = READ_DONE(((20) << 2) | 0xF8000001u);
2259
2260 // Each reader starts in a fresh situation
2261 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
2262
2263 if (program) {
2264 if (incremental) {
2265 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2266 lbm_value *rptr1 = stack_reserve(ctx,3);
2267 rptr1[0] = chan;
2268 rptr1[1] = ctx->curr_env;
2269 rptr1[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
2270 } else {
2271 ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2272 lbm_value *rptr1 = stack_reserve(ctx,4);
2273 rptr1[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2274 rptr1[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2275 rptr1[2] = chan;
2276 rptr1[3] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
2277 }
2278 }
2279 rptr = stack_reserve(ctx,3); // reuse of variable rptr
2280 rptr[0] = chan;
2281 rptr[1] = lbm_enc_u(1);
2282 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
2283 ctx->app_cont = true1;
2284 } else {
2285 lbm_set_error_reason((char*)lbm_error_str_num_args);
2286 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2287 }
2288}
2289
2290static void apply_read_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2291 apply_read_base(args,nargs,ctx,true1,false0);
2292}
2293
2294static void apply_read_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2295 apply_read_base(args,nargs,ctx,true1,true1);
2296}
2297
2298static void apply_read(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2299 apply_read_base(args,nargs,ctx,false0,false0);
2300}
2301
2302static void apply_spawn_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, uint32_t context_flags) {
2303
2304 lbm_uint stack_size = EVAL_CPS_DEFAULT_STACK_SIZE256;
2305 lbm_uint closure_pos = 0;
2306 char *name = NULL((void*)0);
2307
2308 if (nargs >= 1 &&
2309 lbm_is_closure(args[0])) {
2310 closure_pos = 0;
2311 } else if (nargs >= 2 &&
2312 lbm_is_number(args[0]) &&
2313 lbm_is_closure(args[1])) {
2314 stack_size = lbm_dec_as_u32(args[0]);
2315 closure_pos = 1;
2316 } else if (nargs >= 2 &&
2317 lbm_is_array_r(args[0]) &&
2318 lbm_is_closure(args[1])) {
2319 name = lbm_dec_str(args[0]);
2320 closure_pos = 1;
2321 }else if (nargs >= 3 &&
2322 lbm_is_array_r(args[0]) &&
2323 lbm_is_number(args[1]) &&
2324 lbm_is_closure(args[2])) {
2325 stack_size = lbm_dec_as_u32(args[1]);
2326 closure_pos = 2;
2327 name = lbm_dec_str(args[0]);
2328 } else {
2329 if (context_flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01)
2330 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN_TRAP(((0x30005) << 4) | 0x00000000u));
2331 else
2332 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN(((0x30004) << 4) | 0x00000000u));
2333 }
2334
2335 lbm_value cl[3];
2336 extract_n(get_cdr(args[closure_pos]), cl, 3);
2337 lbm_value curr_param = cl[CLO_PARAMS0];
2338 lbm_value clo_env = cl[CLO_ENV2];
2339 lbm_uint i = closure_pos + 1;
2340 while (lbm_is_cons(curr_param) && i <= nargs) {
2341 lbm_value entry = cons_with_gc(get_car(curr_param), args[i], clo_env);
2342 lbm_value aug_env = cons_with_gc(entry, clo_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2343 clo_env = aug_env;
2344 curr_param = get_cdr(curr_param);
2345 i ++;
2346 }
2347
2348 lbm_stack_drop(&ctx->K, nargs+1);
2349
2350 lbm_value program = cons_with_gc(cl[CLO_BODY1], ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), clo_env);
2351
2352 lbm_cid cid = lbm_create_ctx_parent(program,
2353 clo_env,
2354 stack_size,
2355 lbm_get_current_cid(),
2356 context_flags,
2357 name);
2358 ctx->r = lbm_enc_i(cid);
2359 ctx->app_cont = true1;
2360}
2361
2362static void apply_spawn(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2363 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00);
2364}
2365
2366static void apply_spawn_trap(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2367 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01);
2368}
2369
2370static void apply_yield(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2371 if (is_atomic) {
2372 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2373 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2374 }
2375 if (nargs == 1 && lbm_is_number(args[0])) {
2376 lbm_uint ts = lbm_dec_as_u32(args[0]);
2377 lbm_stack_drop(&ctx->K, nargs+1);
2378 yield_ctx(ts);
2379 } else {
2380 lbm_set_error_reason((char*)lbm_error_str_no_number);
2381 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2382 }
2383}
2384
2385static void apply_sleep(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2386 if (is_atomic) {
2387 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2388 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2389 }
2390 if (nargs == 1 && lbm_is_number(args[0])) {
2391 lbm_uint ts = (lbm_uint)(1000000.0f * lbm_dec_as_float(args[0]));
2392 lbm_stack_drop(&ctx->K, nargs+1);
2393 yield_ctx(ts);
2394 } else {
2395 lbm_set_error_reason((char*)lbm_error_str_no_number);
2396 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2397 }
2398}
2399
2400static void apply_wait(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2401 if (nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2402 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2403 lbm_value *sptr = get_stack_ptr(ctx, 2);
2404 sptr[0] = lbm_enc_i(cid);
2405 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2406 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2407 ctx->app_cont = true1;
2408 yield_ctx(50000);
2409 } else {
2410 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_WAIT(((0x30007) << 4) | 0x00000000u));
2411 }
2412}
2413
2414/* (eval expr)
2415 (eval env expr) */
2416static void apply_eval(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2417 if ( nargs == 1) {
2418 ctx->curr_exp = args[0];
2419 } else if (nargs == 2) {
2420 ctx->curr_exp = args[1];
2421 ctx->curr_env = args[0];
2422 } else {
2423 lbm_set_error_reason((char*)lbm_error_str_num_args);
2424 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL(((0x30008) << 4) | 0x00000000u));
2425 }
2426 lbm_stack_drop(&ctx->K, nargs+1);
2427}
2428
2429static void apply_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2430 int prg_pos = 0;
2431 if (nargs == 2) {
2432 prg_pos = 1;
2433 ctx->curr_env = args[0];
2434 }
2435 if (nargs == 1 || nargs == 2) {
2436 lbm_value prg = args[prg_pos];
2437 lbm_value app_cont;
2438 lbm_value app_cont_prg;
2439 lbm_value new_prg;
2440 lbm_value prg_copy;
2441
2442 int len = -1;
2443 WITH_GC(prg_copy, lbm_list_copy(&len, prg))(prg_copy) = (lbm_list_copy(&len, prg)); if (lbm_is_symbol_merror
((prg_copy))) { gc(); (prg_copy) = (lbm_list_copy(&len, prg
)); if (lbm_is_symbol_merror((prg_copy))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2444 lbm_stack_drop(&ctx->K, nargs+1);
2445
2446 if (ctx->K.sp > nargs+2) { // if there is a continuation
2447 app_cont = cons_with_gc(ENC_SYM_APP_CONT(((0x111) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2448 app_cont_prg = cons_with_gc(app_cont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2449 new_prg = lbm_list_append(app_cont_prg, ctx->program);
2450 new_prg = lbm_list_append(prg_copy, new_prg);
2451 } else {
2452 new_prg = lbm_list_append(prg_copy, ctx->program);
2453 }
2454 if (!lbm_is_list(new_prg)) {
2455 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2456 }
2457 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);
2458 ctx->program = get_cdr(new_prg);
2459 ctx->curr_exp = get_car(new_prg);
2460 } else {
2461 lbm_set_error_reason((char*)lbm_error_str_num_args);
2462 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2463 }
2464}
2465
2466static void apply_send(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2467 if (nargs == 2) {
2468 if (lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2469 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2470 lbm_value msg = args[1];
2471 lbm_value status = lbm_find_receiver_and_send(cid, msg);
2472 /* return the status */
2473 lbm_stack_drop(&ctx->K, nargs+1);
2474 ctx->r = status;
2475 ctx->app_cont = true1;
2476 } else {
2477 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2478 }
2479 } else {
2480 lbm_set_error_reason((char*)lbm_error_str_num_args);
2481 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2482 }
2483}
2484
2485static void apply_ok(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2486 lbm_value ok_val = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2487 if (nargs >= 1) {
2488 ok_val = args[0];
2489 }
2490 ctx->r = ok_val;
2491 ok_ctx();
2492}
2493
2494static void apply_error(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2495 (void) ctx;
2496 lbm_value err_val = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
2497 if (nargs >= 1) {
2498 err_val = args[0];
2499 }
2500 error_at_ctx(err_val, ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
2501}
2502
2503// (map f arg-list)
2504static void apply_map(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2505 if (nargs == 2 && lbm_is_cons(args[1])) {
2506 lbm_value *sptr = get_stack_ptr(ctx, 3);
2507
2508 lbm_value f = args[0];
2509 lbm_value h = get_car(args[1]);
2510 lbm_value t = get_cdr(args[1]);
2511
2512 lbm_value appli_1;
2513 lbm_value appli;
2514 WITH_GC(appli_1, lbm_heap_allocate_list(2))(appli_1) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli_1))) { gc(); (appli_1) = (lbm_heap_allocate_list(2));
if (lbm_is_symbol_merror((appli_1))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2515 WITH_GC_RMBR_1(appli, lbm_heap_allocate_list(2), appli_1)(appli) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli))) { lbm_gc_mark_phase(appli_1); gc(); (appli) = (lbm_heap_allocate_list
(2)); if (lbm_is_symbol_merror((appli))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2516
2517 lbm_value appli_0 = get_cdr(appli_1);
2518
2519 lbm_set_car_and_cdr(appli_0, h, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2520 lbm_set_car(appli_1, ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u));
2521
2522 lbm_set_car_and_cdr(get_cdr(appli), appli_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2523 lbm_set_car(appli, f);
2524
2525 lbm_value elt = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), appli);
2526 sptr[0] = t; // reuse stack space
2527 sptr[1] = ctx->curr_env;
2528 sptr[2] = elt;
2529 lbm_value *rptr = stack_reserve(ctx,4);
2530 rptr[0] = elt;
2531 rptr[1] = appli;
2532 rptr[2] = appli_0;
2533 rptr[3] = MAP(((26) << 2) | 0xF8000001u);
2534 ctx->curr_exp = appli;
2535 } else if (nargs == 2 && lbm_is_symbol_nil(args[1])) {
2536 lbm_stack_drop(&ctx->K, 3);
2537 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2538 ctx->app_cont = true1;
2539 return;
2540 } else {
2541 lbm_set_error_reason((char*)lbm_error_str_num_args);
2542 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_MAP(((0x3000D) << 4) | 0x00000000u));
2543 }
2544}
2545
2546static void apply_reverse(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2547 if (nargs == 1 && lbm_is_list(args[0])) {
2548 lbm_value curr = args[0];
2549
2550 lbm_value new_list = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2551 while (lbm_is_cons(curr)) {
2552 lbm_value tmp = cons_with_gc(get_car(curr), new_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2553 new_list = tmp;
2554 curr = get_cdr(curr);
2555 }
2556 lbm_stack_drop(&ctx->K, 2);
2557 ctx->r = new_list;
2558 ctx->app_cont = true1;
2559 } else {
2560 lbm_set_error_reason("Reverse requires a list argument");
2561 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_REVERSE(((0x3000E) << 4) | 0x00000000u));
2562 }
2563}
2564
2565static void apply_flatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2566 if (nargs == 1) {
2567
2568 lbm_value v = flatten_value(args[0]);
2569 if ( v == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)) {
2570 gc();
2571 v = flatten_value(args[0]);
2572 }
2573
2574 if (lbm_is_symbol(v)) {
2575 error_at_ctx(v, ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2576 } else {
2577 lbm_stack_drop(&ctx->K, 2);
2578 ctx->r = v;
2579 ctx->app_cont = true1;
2580 }
2581 return;
2582 }
2583 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2584}
2585
2586static void apply_unflatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2587 if(nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2588 lbm_array_header_t *array;
2589 array = (lbm_array_header_t *)get_car(args[0]);
2590
2591 lbm_flat_value_t fv;
2592 fv.buf = (uint8_t*)array->data;
2593 fv.buf_size = array->size;
2594 fv.buf_pos = 0;
2595
2596 lbm_value res;
2597
2598 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2599 if (lbm_unflatten_value(&fv, &res)) {
2600 ctx->r = res;
2601 }
2602 lbm_stack_drop(&ctx->K, 2);
2603 ctx->app_cont = true1;
2604 return;
2605 }
2606 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_UNFLATTEN(((0x30010) << 4) | 0x00000000u));
2607}
2608
2609static void apply_kill(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2610 if (nargs == 2 && lbm_is_number(args[0])) {
2611 lbm_cid cid = lbm_dec_as_i32(args[0]);
2612
2613 if (ctx->id == cid) {
2614 ctx->r = args[1];
2615 finish_ctx();
2616 return;
2617 }
2618 mutex_lock(&qmutex);
2619 eval_context_t *found = NULL((void*)0);
2620 found = lookup_ctx_nm(&blocked, cid);
2621 if (found)
2622 drop_ctx_nm(&blocked, found);
2623 else
2624 found = lookup_ctx_nm(&queue, cid);
2625 if (found)
2626 drop_ctx_nm(&queue, found);
2627
2628 if (found) {
2629 found->K.data[found->K.sp - 1] = KILL(((40) << 2) | 0xF8000001u);
2630 found->r = args[1];
2631 found->app_cont = true1;
2632 enqueue_ctx_nm(&queue,found);
2633 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2634 } else {
2635 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2636 }
2637 lbm_stack_drop(&ctx->K, 3);
2638 ctx->app_cont = true1;
2639 mutex_unlock(&qmutex);
2640 return;
2641 }
2642 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_KILL(((0x30011) << 4) | 0x00000000u));
2643}
2644
2645// (merge comparator list1 list2)
2646static void apply_merge(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2647 if (nargs == 3 && lbm_is_list(args[1]) && lbm_is_list(args[2])) {
2648
2649 if (!lbm_is_closure(args[0])) {
2650 lbm_value closure;
2651 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2652 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2653 lbm_value cl1 = lbm_cdr(closure);
2654 lbm_value par;
2655 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2656 lbm_set_car(cl1, par);
2657 lbm_value cl2 = lbm_cdr(cl1);
2658 lbm_value body;
2659 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2660 lbm_set_car(cl2, body);
2661 lbm_value cl3 = lbm_cdr(cl2);
2662 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2663
2664 // Replace operator on stack with closure and rest of the code is
2665 // compatible.
2666 args[0] = closure;
2667 }
2668
2669 // Copy input lists for functional behaviour at top-level
2670 // merge itself is in-place in the copied lists.
2671 lbm_value a;
2672 lbm_value b;
2673 int len_a = -1;
2674 int len_b = -1;
2675 WITH_GC(a, lbm_list_copy(&len_a, args[1]))(a) = (lbm_list_copy(&len_a, args[1])); if (lbm_is_symbol_merror
((a))) { gc(); (a) = (lbm_list_copy(&len_a, args[1])); if
(lbm_is_symbol_merror((a))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } };
2676 WITH_GC_RMBR_1(b, lbm_list_copy(&len_b, args[2]), a)(b) = (lbm_list_copy(&len_b, args[2])); if (lbm_is_symbol_merror
((b))) { lbm_gc_mark_phase(a); gc(); (b) = (lbm_list_copy(&
len_b, args[2])); if (lbm_is_symbol_merror((b))) { error_ctx(
(((0x23) << 4) | 0x00000000u)); } };
2677
2678 if (len_a == 0) {
2679 ctx->r = b;
2680 lbm_stack_drop(&ctx->K, 4);
2681 ctx->app_cont = true1;
2682 return;
2683 }
2684 if (len_b == 0) {
2685 ctx->r = a;
2686 lbm_stack_drop(&ctx->K, 4);
2687 ctx->app_cont = true1;
2688 return;
2689 }
2690
2691 args[1] = a; // keep safe by replacing the original on stack.
2692 args[2] = b;
2693
2694 lbm_value a_1 = a;
2695 lbm_value a_rest = lbm_cdr(a);
2696 lbm_value b_1 = b;
2697 lbm_value b_rest = lbm_cdr(b);
2698
2699 lbm_value cl[3]; // Comparator closure
2700 extract_n(lbm_cdr(args[0]), cl, 3);
2701 lbm_value cmp_env = cl[CLO_ENV2];
2702 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2703 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2704 lbm_uint len = lbm_list_length(cl[CLO_PARAMS0]);
2705 if (len == 2) {
2706 par1 = get_car(cl[CLO_PARAMS0]);
2707 par2 = get_cadr(cl[CLO_PARAMS0]);
2708 lbm_value new_env0;
2709 lbm_value new_env;
2710 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a_1)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a_1))); if (
lbm_is_symbol_merror((new_env0))) { gc(); (new_env0) = (lbm_env_set
(cmp_env, par1, lbm_car(a_1))); if (lbm_is_symbol_merror((new_env0
))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2711 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b_1)),new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1))); if (
lbm_is_symbol_merror((new_env))) { lbm_gc_mark_phase(new_env0
); gc(); (new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1
))); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2712 cmp_env = new_env;
2713 } else {
2714 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2715 }
2716 lbm_set_cdr(a_1, b_1);
2717 lbm_set_cdr(b_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2718 lbm_value cmp = cl[CLO_BODY1];
2719
2720 lbm_stack_drop(&ctx->K, 4); // TODO: Optimize drop 4 alloc 10 into alloc 6
2721 lbm_uint *sptr = stack_reserve(ctx, 10);
2722 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged list
2723 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged list
2724 sptr[2] = a_1;
2725 sptr[3] = a_rest;
2726 sptr[4] = b_rest;
2727 sptr[5] = cmp;
2728 sptr[6] = cmp_env;
2729 sptr[7] = par1;
2730 sptr[8] = par2;
2731 sptr[9] = MERGE_REST(((43) << 2) | 0xF8000001u);
2732 ctx->curr_exp = cl[CLO_BODY1];
2733 ctx->curr_env = cmp_env;
2734 return;
2735 }
2736 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MERGE(((0x30013) << 4) | 0x00000000u));
2737}
2738
2739// (sort comparator list)
2740static void apply_sort(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2741 if (nargs == 2 && lbm_is_list(args[1])) {
2742
2743 if (!lbm_is_closure(args[0])) {
2744 lbm_value closure;
2745 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2746 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2747 lbm_value cl1 = lbm_cdr(closure);
2748 lbm_value par;
2749 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2750 lbm_set_car(cl1, par);
2751 lbm_value cl2 = lbm_cdr(cl1);
2752 lbm_value body;
2753 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2754 lbm_set_car(cl2, body);
2755 lbm_value cl3 = lbm_cdr(cl2);
2756 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2757
2758 // Replace operator on stack with closure and rest of the code is
2759 // compatible.
2760 args[0] = closure;
2761 }
2762
2763 int len = -1;
2764 lbm_value list_copy;
2765 WITH_GC(list_copy, lbm_list_copy(&len, args[1]))(list_copy) = (lbm_list_copy(&len, args[1])); if (lbm_is_symbol_merror
((list_copy))) { gc(); (list_copy) = (lbm_list_copy(&len,
args[1])); if (lbm_is_symbol_merror((list_copy))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2766 if (len <= 1) {
2767 lbm_stack_drop(&ctx->K, 3);
2768 ctx->r = list_copy;
2769 ctx->app_cont = true1;
2770 return;
2771 }
2772
2773 args[1] = list_copy; // Keep safe, original replaced on stack.
2774
2775 // Take the headmost 2, 1-element sublists.
2776 lbm_value a = list_copy;
2777 lbm_value b = lbm_cdr(a);
2778 lbm_value rest = lbm_cdr(b);
2779 // Do not terminate b. keep rest of list safe from GC in the following
2780 // closure extraction.
2781 //lbm_set_cdr(a, b); // This is void
2782
2783 lbm_value cl[3]; // Comparator closure
2784 extract_n(lbm_cdr(args[0]), cl, 3);
2785 lbm_value cmp_env = cl[CLO_ENV2];
2786 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2787 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2788 lbm_uint cl_len = lbm_list_length(cl[CLO_PARAMS0]);
2789 if (cl_len == 2) {
2790 par1 = get_car(cl[CLO_PARAMS0]);
2791 par2 = get_cadr(cl[CLO_PARAMS0]);
2792 lbm_value new_env0;
2793 lbm_value new_env;
2794 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a))); if (lbm_is_symbol_merror
((new_env0))) { gc(); (new_env0) = (lbm_env_set(cmp_env, par1
, lbm_car(a))); if (lbm_is_symbol_merror((new_env0))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2795 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b)), new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { lbm_gc_mark_phase(new_env0); gc(); (new_env) =
(lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { error_ctx((((0x23) << 4) | 0x00000000u))
; } };
2796 cmp_env = new_env;
2797 } else {
2798 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2799 }
2800 lbm_value cmp = cl[CLO_BODY1];
2801
2802 // Terminate the comparator argument list.
2803 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2804
2805 lbm_stack_drop(&ctx->K, 3); //TODO: optimize drop 3, alloc 20 into alloc 17
2806 lbm_uint *sptr = stack_reserve(ctx, 20);
2807 sptr[0] = cmp;
2808 sptr[1] = cmp_env;
2809 sptr[2] = par1;
2810 sptr[3] = par2;
2811 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged accumulation of sublists
2812 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged accumulation of sublists
2813 sptr[6] = rest;
2814 sptr[7] = lbm_enc_i(1);
2815 sptr[8] = lbm_enc_i(len); //TODO: 28 bit i vs 32 bit i
2816 sptr[9] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
2817 sptr[10] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged sublist
2818 sptr[11] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged sublist
2819 sptr[12] = a;
2820 sptr[13] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no a_rest, 1 element lists in layer 1.
2821 sptr[14] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no b_rest, 1 element lists in layer 1.
2822 sptr[15] = cmp;
2823 sptr[16] = cmp_env;
2824 sptr[17] = par1;
2825 sptr[18] = par2;
2826 sptr[19] = MERGE_REST(((43) << 2) | 0xF8000001u);
2827 ctx->curr_exp = cmp;
2828 ctx->curr_env = cmp_env;
2829 return;
2830 }
2831 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
2832}
2833
2834static void apply_rest_args(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2835 lbm_value res;
2836 if (lbm_env_lookup_b(&res, ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ctx->curr_env)) {
2837 if (nargs == 1 && lbm_is_number(args[0])) {
2838 int32_t ix = lbm_dec_as_i32(args[0]);
2839 res = lbm_index_list(res, ix);
2840 }
2841 ctx->r = res;
2842 } else {
2843 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2844 }
2845 lbm_stack_drop(&ctx->K, nargs+1);
2846 ctx->app_cont = true1;
2847}
2848
2849/* (rotate list-expr dist/dir-expr) */
2850static void apply_rotate(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2851 if (nargs == 2 && lbm_is_list(args[0]) && lbm_is_number(args[1])) {
2852 int len = -1;
2853 lbm_value ls = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2854 WITH_GC(ls, lbm_list_copy(&len, args[0]))(ls) = (lbm_list_copy(&len, args[0])); if (lbm_is_symbol_merror
((ls))) { gc(); (ls) = (lbm_list_copy(&len, args[0])); if
(lbm_is_symbol_merror((ls))) { error_ctx((((0x23) << 4
) | 0x00000000u)); } };
2855 int dist = lbm_dec_as_i32(args[1]);
2856 if (len > 0 && dist != 0) {
2857 int d = dist;
2858 if (dist > 0) {
2859 ls = lbm_list_destructive_reverse(ls);
2860 } else {
2861 d = -dist;
2862 }
2863
2864 lbm_value start = ls;
2865 lbm_value end = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2866 lbm_value curr = start;
2867 while (lbm_is_cons(curr)) {
2868 end = curr;
2869 curr = get_cdr(curr);
2870 }
2871
2872 for (int i = 0; i < d; i ++) {
2873 lbm_value a = start;
2874 start = lbm_cdr(start);
2875 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2876 lbm_set_cdr(end, a);
2877 end = a;
2878 }
2879 ls = start;
2880 if (dist > 0) {
2881 ls = lbm_list_destructive_reverse(ls);
2882 }
2883 }
2884 lbm_stack_drop(&ctx->K, nargs+1);
2885 ctx->app_cont = true1;
2886 ctx->r = ls;
2887 return;
2888 }
2889 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2890}
2891
2892/***************************************************/
2893/* Application lookup table */
2894
2895typedef void (*apply_fun)(lbm_value *, lbm_uint, eval_context_t *);
2896static const apply_fun fun_table[] =
2897 {
2898 apply_setvar,
2899 apply_read,
2900 apply_read_program,
2901 apply_read_eval_program,
2902 apply_spawn,
2903 apply_spawn_trap,
2904 apply_yield,
2905 apply_wait,
2906 apply_eval,
2907 apply_eval_program,
2908 apply_send,
2909 apply_ok,
2910 apply_error,
2911 apply_map,
2912 apply_reverse,
2913 apply_flatten,
2914 apply_unflatten,
2915 apply_kill,
2916 apply_sleep,
2917 apply_merge,
2918 apply_sort,
2919 apply_rest_args,
2920 apply_rotate,
2921 };
2922
2923/***************************************************/
2924/* Application of function that takes arguments */
2925/* passed over the stack. */
2926
2927static void application(eval_context_t *ctx, lbm_value *fun_args, lbm_uint arg_count) {
2928 /* If arriving here, we know that the fun is a symbol.
2929 * and can be a built in operation or an extension.
2930 */
2931 lbm_value fun = fun_args[0];
2932
2933 lbm_uint fun_val = lbm_dec_sym(fun);
2934 lbm_uint fun_kind = SYMBOL_KIND(fun_val)((fun_val) >> 16);
2935
2936 switch (fun_kind) {
2937 case SYMBOL_KIND_EXTENSION1: {
2938 extension_fptr f = extension_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)].fptr;
2939
2940 lbm_value ext_res;
2941 WITH_GC(ext_res, f(&fun_args[1], arg_count))(ext_res) = (f(&fun_args[1], arg_count)); if (lbm_is_symbol_merror
((ext_res))) { gc(); (ext_res) = (f(&fun_args[1], arg_count
)); if (lbm_is_symbol_merror((ext_res))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2942 if (lbm_is_error(ext_res)) { //Error other than merror
2943 error_at_ctx(ext_res, fun);
2944 }
2945 lbm_stack_drop(&ctx->K, arg_count + 1);
2946
2947 ctx->app_cont = true1;
2948 ctx->r = ext_res;
2949
2950 if (blocking_extension) {
2951 blocking_extension = false0;
2952 if (blocking_extension_timeout) {
2953 blocking_extension_timeout = false0;
2954 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, blocking_extension_timeout_us,true1);
2955 } else {
2956 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,true1);
2957 }
2958 mutex_unlock(&blocking_extension_mutex);
2959 }
2960 } break;
2961 case SYMBOL_KIND_FUNDAMENTAL2:
2962 call_fundamental(SYMBOL_IX(fun_val)((fun_val) & 0xFFFF), &fun_args[1], arg_count, ctx);
2963 break;
2964 case SYMBOL_KIND_APPFUN3:
2965 fun_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)](&fun_args[1], arg_count, ctx);
2966 break;
2967 default:
2968 // Symbols that are "special" but not in the way caught above
2969 // ends up here.
2970 lbm_set_error_reason("Symbol does not represent a function");
2971 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),fun_args[0]);
2972 break;
2973 }
2974}
2975
2976static void cont_closure_application_args(eval_context_t *ctx) {
2977 lbm_uint* sptr = get_stack_ptr(ctx, 5);
2978
2979 lbm_value arg_env = (lbm_value)sptr[0];
2980 lbm_value exp = (lbm_value)sptr[1];
2981 lbm_value clo_env = (lbm_value)sptr[2];
2982 lbm_value params = (lbm_value)sptr[3];
2983 lbm_value args = (lbm_value)sptr[4];
2984
2985 lbm_value car_params, cdr_params;
2986 get_car_and_cdr(params, &car_params, &cdr_params);
2987
2988 bool_Bool a_nil = lbm_is_symbol_nil(args);
2989 bool_Bool p_nil = lbm_is_symbol_nil(cdr_params);
2990
2991 lbm_value binder = allocate_binding(car_params, ctx->r, clo_env);
2992
2993 if (!a_nil && !p_nil) {
2994 lbm_value car_args, cdr_args;
2995 get_car_and_cdr(args, &car_args, &cdr_args);
2996 sptr[2] = binder;
2997 sptr[3] = cdr_params;
2998 sptr[4] = cdr_args;
2999 stack_reserve(ctx,1)[0] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
3000 ctx->curr_exp = car_args;
3001 ctx->curr_env = arg_env;
3002 } else if (a_nil && p_nil) {
3003 // Arguments and parameters match up in number
3004 lbm_stack_drop(&ctx->K, 5);
3005 ctx->curr_env = binder;
3006 ctx->curr_exp = exp;
3007 } else if (p_nil) {
3008 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), binder);
3009 sptr[2] = rest_binder;
3010 sptr[3] = get_cdr(args);
3011 sptr[4] = get_car(rest_binder); // last element of rest_args so far
3012 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3013 ctx->curr_exp = get_car(args);
3014 ctx->curr_env = arg_env;
3015 } else {
3016 lbm_set_error_reason((char*)lbm_error_str_num_args);
3017 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
3018 }
3019}
3020
3021
3022static void cont_closure_args_rest(eval_context_t *ctx) {
3023 lbm_uint* sptr = get_stack_ptr(ctx, 5);
3024 lbm_value arg_env = (lbm_value)sptr[0];
3025 lbm_value exp = (lbm_value)sptr[1];
3026 lbm_value clo_env = (lbm_value)sptr[2];
3027 lbm_value args = (lbm_value)sptr[3];
3028 lbm_value last = (lbm_value)sptr[4];
3029 lbm_cons_t* heap = lbm_heap_state.heap;
3030
3031 lbm_value binding = lbm_heap_state.freelist;
3032 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3033 gc();
3034 binding = lbm_heap_state.freelist;
3035 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3036 }
3037 lbm_uint binding_ix = lbm_dec_ptr(binding);
3038 lbm_heap_state.freelist = heap[binding_ix].cdr;
3039 lbm_heap_state.num_alloc += 1;
3040 heap[binding_ix].car = ctx->r;
3041 heap[binding_ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3042
3043
3044 lbm_set_cdr(last, binding);
3045 sptr[4] = binding;
3046
3047 if (args == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3048 lbm_stack_drop(&ctx->K, 5);
3049 ctx->curr_env = clo_env;
3050 ctx->curr_exp = exp;
3051 } else {
3052 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3053 sptr[3] = get_cdr(args);
3054 ctx->curr_exp = get_car(args);
3055 ctx->curr_env = arg_env;
3056 }
3057}
3058
3059static void cont_application_args(eval_context_t *ctx) {
3060 lbm_uint *sptr = get_stack_ptr(ctx, 3);
3061
3062 lbm_value env = sptr[0];
3063 lbm_value rest = sptr[1];
3064 lbm_value count = sptr[2];
3065
3066 ctx->curr_env = env;
3067 sptr[0] = ctx->r; // Function 1st then Arguments
3068 if (lbm_is_cons(rest)) {
3069 lbm_cons_t *cell = lbm_ref_cell(rest);
3070 sptr[1] = env;
3071 sptr[2] = cell->cdr;
3072 lbm_value *rptr = stack_reserve(ctx,2);
3073 rptr[0] = count + (1 << LBM_VAL_SHIFT4);
3074 rptr[1] = APPLICATION_ARGS(((5) << 2) | 0xF8000001u);
3075 ctx->curr_exp = cell->car;
3076 } else {
3077 // No more arguments
3078 lbm_stack_drop(&ctx->K, 2);
3079 lbm_uint nargs = lbm_dec_u(count);
3080 lbm_value *args = get_stack_ptr(ctx, (uint32_t)(nargs + 1));
3081 application(ctx,args, nargs);
3082 }
3083}
3084
3085static void cont_and(eval_context_t *ctx) {
3086 lbm_value env;
3087 lbm_value rest;
3088 lbm_value arg = ctx->r;
3089 lbm_pop_2(&ctx->K, &rest, &env);
3090 if (lbm_is_symbol_nil(arg)) {
3091 ctx->app_cont = true1;
3092 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3093 } else if (lbm_is_symbol_nil(rest)) {
3094 ctx->app_cont = true1;
3095 } else {
3096 lbm_value *sptr = stack_reserve(ctx, 3);
3097 sptr[0] = env;
3098 sptr[1] = get_cdr(rest);
3099 sptr[2] = AND(((6) << 2) | 0xF8000001u);
3100 ctx->curr_env = env;
3101 ctx->curr_exp = get_car(rest);
3102 }
3103}
3104
3105static void cont_or(eval_context_t *ctx) {
3106 lbm_value env;
3107 lbm_value rest;
3108 lbm_value arg = ctx->r;
3109 lbm_pop_2(&ctx->K, &rest, &env);
3110 if (!lbm_is_symbol_nil(arg)) {
3111 ctx->app_cont = true1;
3112 } else if (lbm_is_symbol_nil(rest)) {
3113 ctx->app_cont = true1;
3114 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3115 } else {
3116 lbm_value *sptr = stack_reserve(ctx, 3);
3117 sptr[0] = env;
3118 sptr[1] = get_cdr(rest);
3119 sptr[2] = OR(((7) << 2) | 0xF8000001u);
3120 ctx->curr_exp = get_car(rest);
3121 ctx->curr_env = env;
3122 }
3123}
3124
3125static int fill_binding_location(lbm_value key, lbm_value value, lbm_value env) {
3126 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) {
3127 if (key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return FB_OK0;
3128 lbm_env_modify_binding(env,key,value);
3129 return FB_OK0;
3130 } else if (lbm_is_cons(key) &&
3131 lbm_is_cons(value)) {
3132 int r = fill_binding_location(get_car(key), get_car(value), env);
3133 if (r == FB_OK0) {
3134 r = fill_binding_location(get_cdr(key), get_cdr(value), env);
3135 }
3136 return r;
3137 }
3138 return FB_TYPE_ERROR-1;
3139}
3140
3141static void cont_bind_to_key_rest(eval_context_t *ctx) {
3142
3143 lbm_value *sptr = get_stack_ptr(ctx, 4);
3144
3145 lbm_value rest = sptr[1];
3146 lbm_value env = sptr[2];
3147 lbm_value key = sptr[3];
3148
3149 if (fill_binding_location(key, ctx->r, env) < 0) {
3150 lbm_set_error_reason("Incorrect type of name/key in let-binding");
3151 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
3152 }
3153
3154 if (lbm_is_cons(rest)) {
3155 lbm_value car_rest = get_car(rest);
3156 lbm_value key_val[2];
3157 extract_n(car_rest, key_val, 2);
3158
3159 sptr[1] = get_cdr(rest);
3160 sptr[3] = key_val[0];
3161 stack_reserve(ctx,1)[0] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
3162 ctx->curr_exp = key_val[1];
3163 ctx->curr_env = env;
3164 } else {
3165 // Otherwise evaluate the expression in the populated env
3166 ctx->curr_exp = sptr[0];
3167 ctx->curr_env = env;
3168 lbm_stack_drop(&ctx->K, 4);
3169 }
3170}
3171
3172static void cont_if(eval_context_t *ctx) {
3173
3174 lbm_value arg = ctx->r;
3175
3176 lbm_value *sptr = pop_stack_ptr(ctx, 2);
3177
3178 ctx->curr_env = sptr[1];
3179 if (lbm_is_symbol_nil(arg)) {
3180 ctx->curr_exp = get_cadr(sptr[0]); // else branch
3181 } else {
3182 ctx->curr_exp = get_car(sptr[0]); // then branch
3183 }
3184}
3185
3186static void cont_match(eval_context_t *ctx) {
3187 lbm_value e = ctx->r;
3188 bool_Bool do_gc = false0;
3189
3190 lbm_uint *sptr = get_stack_ptr(ctx, 2);
3191 lbm_value patterns = (lbm_value)sptr[0];
3192 lbm_value orig_env = (lbm_value)sptr[1]; // restore enclosing environment.
3193 lbm_value new_env = orig_env;
3194
3195 if (lbm_is_symbol_nil(patterns)) {
3196 // no more patterns
3197 lbm_stack_drop(&ctx->K, 2);
3198 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
3199 ctx->app_cont = true1;
3200 } else if (lbm_is_cons(patterns)) {
3201 lbm_value match_case = get_car(patterns);
3202 lbm_value pattern = get_car(match_case);
3203 lbm_value n1 = get_cadr(match_case);
3204 lbm_value n2 = get_cadr(get_cdr(match_case));
3205 lbm_value body;
3206 bool_Bool check_guard = false0;
3207 if (lbm_is_symbol_nil(n2)) { // TODO: Not a very robust check.
3208 body = n1;
3209 } else {
3210 body = n2;
3211 check_guard = true1;
3212 }
3213
3214 bool_Bool is_match = match(pattern, e, &new_env, &do_gc);
3215 if (do_gc) {
3216 gc();
3217 do_gc = false0;
3218 new_env = orig_env;
3219 is_match = match(pattern, e, &new_env, &do_gc);
3220 if (do_gc) {
3221 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3222 }
3223 }
3224 if (is_match) {
3225 if (check_guard) {
3226 lbm_value *rptr = stack_reserve(ctx,5);
3227 sptr[0] = get_cdr(patterns);
3228 sptr[1] = ctx->curr_env;
3229 rptr[0] = MATCH(((9) << 2) | 0xF8000001u);
3230 rptr[1] = new_env;
3231 rptr[2] = body;
3232 rptr[3] = e;
3233 rptr[4] = MATCH_GUARD(((27) << 2) | 0xF8000001u);
3234 ctx->curr_env = new_env;
3235 ctx->curr_exp = n1; // The guard
3236 } else {
3237 lbm_stack_drop(&ctx->K, 2);
3238 ctx->curr_env = new_env;
3239 ctx->curr_exp = body;
3240 }
3241 } else {
3242 // set up for checking of next pattern
3243 sptr[0] = get_cdr(patterns);
3244 sptr[1] = orig_env;
3245 stack_reserve(ctx,1)[0] = MATCH(((9) << 2) | 0xF8000001u);
3246 // leave r unaltered
3247 ctx->app_cont = true1;
3248 }
3249 } else {
3250 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MATCH(((0x108) << 4) | 0x00000000u));
3251 }
3252}
3253
3254static void cont_exit_atomic(eval_context_t *ctx) {
3255 is_atomic --;
3256 ctx->app_cont = true1;
3257}
3258
3259static void cont_map(eval_context_t *ctx) {
3260 lbm_value *sptr = get_stack_ptr(ctx, 6);
3261
3262 lbm_value ls = sptr[0];
3263 lbm_value env = sptr[1];
3264 lbm_value t = sptr[3];
3265 lbm_set_car(t, ctx->r); // update car field tailmost position.
3266 if (lbm_is_cons(ls)) {
3267 lbm_value next, rest;
3268 get_car_and_cdr(ls, &next, &rest);
3269 sptr[0] = rest;
3270 stack_reserve(ctx,1)[0] = MAP(((26) << 2) | 0xF8000001u);
3271 lbm_set_car(sptr[5], next); // new arguments
3272
3273 lbm_value elt = cons_with_gc(ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3274 lbm_set_cdr(t, elt);
3275 sptr[3] = elt; // (r1 ... rN . (nil . nil))
3276 ctx->curr_exp = sptr[4];
3277 ctx->curr_env = env;
3278 } else {
3279 ctx->r = sptr[2]; //head of result list
3280 ctx->curr_env = env;
3281 lbm_stack_drop(&ctx->K, 6);
3282 ctx->app_cont = true1;
3283 }
3284}
3285
3286static void cont_match_guard(eval_context_t *ctx) {
3287 if (lbm_is_symbol_nil(ctx->r)) {
3288 lbm_value e;
3289 lbm_pop(&ctx->K, &e);
3290 lbm_stack_drop(&ctx->K, 2);
3291 ctx->r = e;
3292 ctx->app_cont = true1;
3293 } else {
3294 lbm_value body;
3295 lbm_value env;
3296 lbm_stack_drop(&ctx->K, 1);
3297 lbm_pop_2(&ctx->K, &body, &env);
3298 lbm_stack_drop(&ctx->K, 3);
3299 ctx->curr_env = env;
3300 ctx->curr_exp = body;
3301 }
3302}
3303
3304static void cont_terminate(eval_context_t *ctx) {
3305 error_ctx(ctx->r);
3306}
3307
3308static void cont_loop(eval_context_t *ctx) {
3309 lbm_value *sptr = get_stack_ptr(ctx, 2);
3310 stack_reserve(ctx,1)[0] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
3311 ctx->curr_exp = sptr[1];
3312}
3313
3314static void cont_loop_condition(eval_context_t *ctx) {
3315 if (lbm_is_symbol_nil(ctx->r)) {
3316 lbm_stack_drop(&ctx->K, 2);
3317 ctx->app_cont = true1; // A loop returns nil? Makes sense to me... but in general?
3318 return;
3319 }
3320 lbm_value *sptr = get_stack_ptr(ctx, 2);
3321 stack_reserve(ctx,1)[0] = LOOP(((41) << 2) | 0xF8000001u);
3322 ctx->curr_exp = sptr[0];
3323}
3324
3325static void cont_merge_rest(eval_context_t *ctx) {
3326 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3327
3328 // If comparator returns true (result is in ctx->r):
3329 // "a" should be moved to the last element position in merged list.
3330 // A new element from "a_rest" should be moved into comparator argument 1 pos.
3331 // else
3332 // "b" should be moved to last element position in merged list.
3333 // A new element from "b_rest" should be moved into comparator argument 2 pos.
3334 //
3335 // If a_rest or b_rest is NIL:
3336 // we are done, the remaining elements of
3337 // non_nil list should be appended to merged list.
3338 // else
3339 // Set up for a new comparator evaluation and recurse.
3340 lbm_value a = sptr[2];
3341 lbm_value b = lbm_cdr(a);
3342 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate 1 element list
3343
3344 if (ctx->r == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) { // Comparison false
3345
3346 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3347 sptr[0] = b;
3348 sptr[1] = b;
3349 } else {
3350 lbm_set_cdr(sptr[1], b);
3351 sptr[1] = b;
3352 }
3353 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3354 lbm_set_cdr(a, sptr[3]);
3355 lbm_set_cdr(sptr[1], a);
3356 ctx->r = sptr[0];
3357 lbm_stack_drop(&ctx->K, 9);
3358 ctx->app_cont = true1;
3359 return;
3360 } else {
3361 b = sptr[4];
3362 sptr[4] = lbm_cdr(sptr[4]);
3363 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3364 }
3365 } else {
3366 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3367 sptr[0] = a;
3368 sptr[1] = a;
3369 } else {
3370 lbm_set_cdr(sptr[1], a);
3371 sptr[1] = a;
3372 }
3373
3374 if (sptr[3] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3375 lbm_set_cdr(b, sptr[4]);
3376 lbm_set_cdr(sptr[1], b);
3377 ctx->r = sptr[0];
3378 lbm_stack_drop(&ctx->K, 9);
3379 ctx->app_cont = true1;
3380 return;
3381 } else {
3382 a = sptr[3];
3383 sptr[3] = lbm_cdr(sptr[3]);
3384 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3385 }
3386 }
3387 lbm_set_cdr(a, b);
3388 sptr[2] = a;
3389
3390 lbm_value par1 = sptr[7];
3391 lbm_value par2 = sptr[8];
3392 lbm_value cmp_body = sptr[5];
3393 lbm_value cmp_env = sptr[6];
3394 // Environment should be preallocated already at this point
3395 // and the operations below should never need GC.
3396 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3397 lbm_value new_env = lbm_env_set(new_env0, par2, lbm_car(b));
3398 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3399 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3400 }
3401 cmp_env = new_env;
3402
3403 stack_reserve(ctx,1)[0] = MERGE_REST(((43) << 2) | 0xF8000001u);
3404 ctx->curr_exp = cmp_body;
3405 ctx->curr_env = cmp_env;
3406}
3407
3408// merge_layer stack contents
3409// s[sp-9] = cmp
3410// s[sp-8] = cmp_env
3411// s[sp-7] = par1
3412// s[sp-6] = par2
3413// s[sp-5] = acc - first cell
3414// s[sp-4] = acc - last cell
3415// s[sp-3] = rest;
3416// s[sp-2] = layer
3417// s[sp-1] = length or original list
3418//
3419// ctx->r merged sublist
3420static void cont_merge_layer(eval_context_t *ctx) {
3421 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3422 lbm_int layer = lbm_dec_i(sptr[7]);
3423 lbm_int len = lbm_dec_i(sptr[8]);
3424
3425 lbm_value r_curr = ctx->r;
3426 while (lbm_is_cons(r_curr)) {
3427 lbm_value next = lbm_cdr(r_curr);
3428 if (next == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3429 break;
3430 }
3431 r_curr = next;
3432 }
3433
3434 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3435 sptr[4] = ctx->r;
3436 sptr[5] = r_curr;
3437 } else {
3438 lbm_set_cdr(sptr[5], ctx->r); // accumulate merged sublists.
3439 sptr[5] = r_curr;
3440 }
3441
3442 lbm_value layer_rest = sptr[6];
3443 // switch layer or done ?
3444 if (layer_rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3445 if (layer * 2 >= len) {
3446 ctx->r = sptr[4];
3447 ctx->app_cont = true1;
3448 lbm_stack_drop(&ctx->K, 9);
3449 return;
3450 } else {
3451 // Setup for merges of the next layer
3452 layer = layer * 2;
3453 sptr[7] = lbm_enc_i(layer);
3454 layer_rest = sptr[4]; // continue on the accumulation of all sublists.
3455 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3456 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3457 }
3458 }
3459 // merge another sublist based on current layer.
3460 lbm_value a_list = layer_rest;
3461 // build sublist a
3462 lbm_value curr = layer_rest;
3463 for (int i = 0; i < layer-1; i ++) {
3464 if (lbm_is_cons(curr)) {
3465 curr = lbm_cdr(curr);
3466 } else {
3467 break;
3468 }
3469 }
3470 layer_rest = lbm_cdr(curr);
3471 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3472
3473 lbm_value b_list = layer_rest;
3474 // build sublist b
3475 curr = layer_rest;
3476 for (int i = 0; i < layer-1; i ++) {
3477 if (lbm_is_cons(curr)) {
3478 curr = lbm_cdr(curr);
3479 } else {
3480 break;
3481 }
3482 }
3483 layer_rest = lbm_cdr(curr);
3484 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3485
3486 sptr[6] = layer_rest;
3487
3488 if (b_list == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3489 stack_reserve(ctx,1)[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3490 ctx->r = a_list;
3491 ctx->app_cont = true1;
3492 return;
3493 }
3494 // Set up for a merge of sublists.
3495
3496 lbm_value a_rest = lbm_cdr(a_list);
3497 lbm_value b_rest = lbm_cdr(b_list);
3498 lbm_value a = a_list;
3499 lbm_value b = b_list;
3500 lbm_set_cdr(a, b);
3501 // Terminating the b list would be incorrect here
3502 // if there was any chance that the environment update below
3503 // performs GC.
3504 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3505
3506 lbm_value cmp_body = sptr[0];
3507 lbm_value cmp_env = sptr[1];
3508 lbm_value par1 = sptr[2];
3509 lbm_value par2 = sptr[3];
3510 // Environment should be preallocated already at this point
3511 // and the operations below should never need GC.
3512 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3513 lbm_value new_env = lbm_env_set(cmp_env, par2, lbm_car(b));
3514 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3515 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3516 }
3517 cmp_env = new_env;
3518
3519 lbm_uint *merge_cont = stack_reserve(ctx, 11);
3520 merge_cont[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3521 merge_cont[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3522 merge_cont[2] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3523 merge_cont[3] = a;
3524 merge_cont[4] = a_rest;
3525 merge_cont[5] = b_rest;
3526 merge_cont[6] = cmp_body;
3527 merge_cont[7] = cmp_env;
3528 merge_cont[8] = par1;
3529 merge_cont[9] = par2;
3530 merge_cont[10] = MERGE_REST(((43) << 2) | 0xF8000001u);
3531 ctx->curr_exp = cmp_body;
3532 ctx->curr_env = cmp_env;
3533 return;
3534}
3535
3536/****************************************************/
3537/* READER */
3538
3539static void read_finish(lbm_char_channel_t *str, eval_context_t *ctx) {
3540
3541 /* Tokenizer reached "end of file"
3542 The parser could be in a state where it needs
3543 more tokens to correctly finish an expression.
3544
3545 Three cases
3546 1. The program / expression is malformed and the context should die.
3547 2. We are finished reading a program and should close off the
3548 internal representation with a closing parenthesis. Then
3549 apply continuation.
3550 3. We are finished reading an expression and should
3551 apply the continuation.
3552
3553 In case 3, we should find the READ_DONE at sp - 1.
3554 In case 2, we should find the READ_DONE at sp - 5.
3555
3556 */
3557
3558 if (lbm_is_symbol(ctx->r)) {
3559 lbm_uint sym_val = lbm_dec_sym(ctx->r);
3560 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
3561 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
3562 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3563 }
3564 }
3565
3566 if (ctx->K.data[ctx->K.sp-1] == READ_DONE(((20) << 2) | 0xF8000001u) &&
3567 lbm_dec_u(ctx->K.data[ctx->K.sp-3]) == 0) {
3568 /* successfully finished reading an expression (CASE 3) */
3569 ctx->app_cont = true1;
3570 } else if (ctx->K.sp > 4 && ctx->K.data[ctx->K.sp - 4] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3571 lbm_value env;
3572 lbm_value s;
3573 lbm_value sym;
3574 lbm_pop_3(&ctx->K, &sym, &env, &s);
3575 ctx->curr_env = env;
3576 ctx->app_cont = true1; // Program evaluated and result is in ctx->r.
3577 } else if (ctx->K.sp > 5 && ctx->K.data[ctx->K.sp - 5] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3578 /* successfully finished reading a program (CASE 2) */
3579 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3580 ctx->app_cont = true1;
3581 } else {
3582 /* Parsing failed */
3583 if (lbm_channel_row(str) == 1 &&
3584 lbm_channel_column(str) == 1 ){
3585 // eof at empty stream.
3586 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3587 ctx->app_cont = true1;
3588 } else {
3589 lbm_set_error_reason((char*)lbm_error_str_parse_eof);
3590 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3591 }
3592 lbm_channel_reader_close(str);
3593 }
3594}
3595
3596/* cont_read_next_token
3597 sp-2 : Stream
3598 sp-1 : Grab row
3599*/
3600static void cont_read_next_token(eval_context_t *ctx) {
3601 lbm_value *sptr = get_stack_ptr(ctx, 2);
3602 lbm_value stream = sptr[0];
3603 lbm_value grab_row0 = sptr[1];
3604
3605 lbm_char_channel_t *chan = lbm_dec_channel(stream);
3606 if (chan == NULL((void*)0) || chan->state == NULL((void*)0)) {
3607 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3608 }
3609
3610 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3611 lbm_stack_drop(&ctx->K, 2);
3612 read_finish(chan, ctx);
3613 return;
3614 }
3615 /* Eat whitespace and comments */
3616 if (!tok_clean_whitespace(chan)) {
3617 sptr[0] = stream;
3618 sptr[1] = lbm_enc_u(0);
3619 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3620 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3621 return;
3622 }
3623 /* After eating whitespace we may be at end of file/stream */
3624 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3625 lbm_stack_drop(&ctx->K, 2);
3626 read_finish(chan, ctx);
3627 return;
3628 }
3629
3630 if (lbm_dec_u(grab_row0)) {
3631 ctx->row0 = (int32_t)lbm_channel_row(chan);
3632 }
3633
3634 /* Attempt to extract tokens from the character stream */
3635 int n = 0;
3636 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3637 unsigned int string_len = 0;
3638
3639 /*
3640 * SYNTAX
3641 */
3642 uint32_t match;
3643 n = tok_syntax(chan, &match);
3644 if (n > 0) {
3645 if (!lbm_channel_drop(chan, (unsigned int)n)) {
3646 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3647 }
3648 ctx->app_cont = true1;
3649 lbm_uint do_next = 0;
3650 switch(match) {
3651 case TOKOPENPAR1u: {
3652 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3653 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3654 lbm_value *rptr = stack_reserve(ctx,5);
3655 rptr[0] = stream;
3656 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3657 rptr[2] = stream;
3658 rptr[3] = lbm_enc_u(0);
3659 rptr[4] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3660 ctx->r = ENC_SYM_OPENPAR(((0x70) << 4) | 0x00000000u);
3661 } return;
3662 case TOKCLOSEPAR2u: {
3663 lbm_stack_drop(&ctx->K, 2);
3664 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3665 } return;
3666 case TOKOPENBRACK3u: {
3667 sptr[0] = stream;
3668 sptr[1] = READ_START_ARRAY(((24) << 2) | 0xF8000001u);
3669 lbm_value *rptr = stack_reserve(ctx, 3);
3670 rptr[0] = stream;
3671 rptr[1] = lbm_enc_u(0);
3672 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3673 ctx->r = ENC_SYM_OPENBRACK(((0x80) << 4) | 0x00000000u);
3674 } return;
3675 case TOKCLOSEBRACK4u:
3676 lbm_stack_drop(&ctx->K, 2);
3677 ctx->r = ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u);
3678 return;
3679 case TOKDOT5u:
3680 lbm_stack_drop(&ctx->K, 2);
3681 ctx->r = ENC_SYM_DOT(((0x76) << 4) | 0x00000000u);
3682 return;
3683 case TOKDONTCARE6u:
3684 lbm_stack_drop(&ctx->K, 2);
3685 ctx->r = ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u);
3686 return;
3687 case TOKQUOTE7u:
3688 do_next = READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u);
3689 break;
3690 case TOKBACKQUOTE8u: {
3691 sptr[0] = QQ_EXPAND_START(((35) << 2) | 0xF8000001u);
3692 sptr[1] = stream;
3693 lbm_value *rptr = stack_reserve(ctx, 2);
3694 rptr[0] = lbm_enc_u(0);
3695 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3696 ctx->app_cont = true1;
3697 } return;
3698 case TOKCOMMAAT9u:
3699 do_next = READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u);
3700 break;
3701 case TOKCOMMA10u:
3702 do_next = READ_COMMA_RESULT(((23) << 2) | 0xF8000001u);
3703 break;
3704 case TOKMATCHANY11u:
3705 lbm_stack_drop(&ctx->K, 2);
3706 ctx->r = ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u);
3707 return;
3708 case TOKOPENCURL12u: {
3709 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3710 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3711 lbm_value *rptr = stack_reserve(ctx,2);
3712 rptr[0] = stream;
3713 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3714 ctx->r = ENC_SYM_PROGN(((0x102) << 4) | 0x00000000u);
3715 } return;
3716 case TOKCLOSECURL13u:
3717 lbm_stack_drop(&ctx->K, 2);
3718 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3719 return;
3720 case TOKCONSTSTART14u: /* fall through */
3721 case TOKCONSTEND15u:
3722 case TOKCONSTSYMSTR16u: {
3723 if (match == TOKCONSTSTART14u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3724 if (match == TOKCONSTEND15u) ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3725 if (match == TOKCONSTSYMSTR16u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04;
3726 sptr[0] = stream;
3727 sptr[1] = lbm_enc_u(0);
3728 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3729 ctx->app_cont = true1;
3730 } return;
3731 default:
3732 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3733 }
3734 sptr[0] = do_next;
3735 sptr[1] = stream;
3736 lbm_value *rptr = stack_reserve(ctx, 2);
3737 rptr[0] = lbm_enc_u(0);
3738 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3739 ctx->app_cont = true1;
3740 return;
3741 } else if (n < 0) goto retry_token;
3742
3743 /*
3744 * STRING
3745 */
3746 n = tok_string(chan, &string_len);
3747 if (n >= 2) {
3748 lbm_channel_drop(chan, (unsigned int)n);
3749 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3750 gc();
3751 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3752 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3753 return; // dead return but static analysis does not know that.
3754 }
3755 }
3756 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(res);
3757 char *data = (char*)arr->data;
3758 memset(data,0, string_len + 1);
3759 memcpy(data, tokpar_sym_str, string_len);
3760 lbm_stack_drop(&ctx->K, 2);
3761 ctx->r = res;
3762 ctx->app_cont = true1;
3763 return;
3764 } else if (n < 0) goto retry_token;
3765
3766 /*
3767 * FLOAT
3768 */
3769 token_float f_val;
3770 n = tok_double(chan, &f_val);
3771 if (n > 0) {
3772 lbm_channel_drop(chan, (unsigned int) n);
3773 switch(f_val.type) {
3774 case TOKTYPEF32107u:
3775 WITH_GC(res, lbm_enc_float((float)f_val.value))(res) = (lbm_enc_float((float)f_val.value)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (lbm_enc_float((float)f_val.value));
if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
3776 break;
3777 case TOKTYPEF64108u:
3778 res = lbm_enc_double(f_val.value);
3779 break;
3780 default:
3781 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3782 }
3783 lbm_stack_drop(&ctx->K, 2);
3784 ctx->r = res;
3785 ctx->app_cont = true1;
3786 return;
3787 } else if (n < 0) goto retry_token;
3788
3789 /*
3790 * INTEGER
3791 */
3792 token_int int_result;
3793 n = tok_integer(chan, &int_result);
3794 if (n > 0) {
3795 lbm_channel_drop(chan, (unsigned int)n);
3796 switch(int_result.type) {
3797 case TOKTYPEBYTE100u:
3798 res = lbm_enc_char((uint8_t)(int_result.negative ? -int_result.value : int_result.value));
3799 break;
3800 case TOKTYPEI101u:
3801 res = lbm_enc_i((lbm_int)(int_result.negative ? -int_result.value : int_result.value));
3802 break;
3803 case TOKTYPEU102u:
3804 res = lbm_enc_u((lbm_uint)(int_result.negative ? -int_result.value : int_result.value));
3805 break;
3806 case TOKTYPEI32103u:
3807 WITH_GC(res, lbm_enc_i32((int32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i32((int32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i32((int32_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3808 break;
3809 case TOKTYPEU32104u:
3810 WITH_GC(res,lbm_enc_u32((uint32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u32((uint32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u32((uint32_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3811 break;
3812 case TOKTYPEI64105u:
3813 WITH_GC(res,lbm_enc_i64((int64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i64((int64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i64((int64_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3814 break;
3815 case TOKTYPEU64106u:
3816 WITH_GC(res,lbm_enc_u64((uint64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u64((uint64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u64((uint64_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3817 break;
3818 default:
3819 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3820 }
3821 lbm_stack_drop(&ctx->K, 2);
3822 ctx->r = res;
3823 ctx->app_cont = true1;
3824 return;
3825 } else if (n < 0) goto retry_token;
3826
3827 /*
3828 * SYMBOL
3829 */
3830 n = tok_symbol(chan);
3831 if (n > 0) {
3832 lbm_channel_drop(chan, (unsigned int) n);
3833 lbm_uint symbol_id;
3834 if (lbm_get_symbol_by_name(tokpar_sym_str, &symbol_id)) {
3835 res = lbm_enc_sym(symbol_id);
3836 } else {
3837 int r = 0;
3838 if (n > 4 &&
3839 tokpar_sym_str[0] == 'e' &&
3840 tokpar_sym_str[1] == 'x' &&
3841 tokpar_sym_str[2] == 't' &&
3842 tokpar_sym_str[3] == '-') {
3843 lbm_uint ext_id;
3844 lbm_uint ext_name_len = (lbm_uint)n + 1;
3845 char *ext_name = lbm_malloc(ext_name_len);
3846 if (!ext_name) {
3847 gc();
3848 ext_name = lbm_malloc(ext_name_len);
3849 }
3850 if (ext_name) {
3851 memcpy(ext_name, tokpar_sym_str, ext_name_len);
3852 r = lbm_add_extension(ext_name, lbm_extensions_default);
3853 if (!lbm_lookup_extension_id(ext_name, &ext_id)) {
3854 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3855 }
3856 symbol_id = ext_id;
3857 } else {
3858 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3859 }
3860 } else {
3861 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04 &&
3862 ctx->flags & EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08) {
3863 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id, true1); //flash
3864 if (!r) {
3865 lbm_set_error_reason((char*)lbm_error_str_flash_error);
3866 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3867 }
3868 } else {
3869 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3870 if (!r) {
3871 gc();
3872 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3873 }
3874 }
3875 }
3876 if (r) {
3877 res = lbm_enc_sym(symbol_id);
3878 } else {
3879 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3880 }
3881 }
3882 lbm_stack_drop(&ctx->K, 2);
3883 ctx->r = res;
3884 ctx->app_cont = true1;
3885 return;
3886 } else if (n == TOKENIZER_NEED_MORE-1) {
3887 goto retry_token;
3888 } else if (n <= TOKENIZER_STRING_ERROR-2) {
3889 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3890 }
3891
3892 /*
3893 * CHAR
3894 */
3895 char c_val;
3896 n = tok_char(chan, &c_val);
3897 if(n > 0) {
3898 lbm_channel_drop(chan,(unsigned int) n);
3899 lbm_stack_drop(&ctx->K, 2);
3900 ctx->r = lbm_enc_char((uint8_t)c_val);
3901 ctx->app_cont = true1;
3902 return;
3903 }else if (n < 0) goto retry_token;
3904
3905 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3906
3907 retry_token:
3908 if (n == TOKENIZER_NEED_MORE-1) {
3909 sptr[0] = stream;
3910 sptr[1] = lbm_enc_u(0);
3911 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3912 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3913 return;
3914 }
3915 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3916}
3917
3918static void cont_read_start_array(eval_context_t *ctx) {
3919 lbm_value *sptr = get_stack_ptr(ctx, 1);
3920 lbm_value stream = sptr[0];
3921
3922 lbm_char_channel_t *str = lbm_dec_channel(stream);
3923 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
3924 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3925 }
3926
3927 lbm_uint num_free = lbm_memory_longest_free();
3928 lbm_uint initial_size = (lbm_uint)((float)num_free * 0.9);
3929 if (initial_size == 0) {
3930 gc();
3931 num_free = lbm_memory_longest_free();
3932 initial_size = (lbm_uint)((float)num_free * 0.9);
3933 if (initial_size == 0) {
3934 lbm_channel_reader_close(str);
3935 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3936 }
3937 }
3938
3939 if (lbm_is_number(ctx->r)) {
3940 lbm_value array;
3941 initial_size = sizeof(lbm_uint) * initial_size;
3942
3943 if (!lbm_heap_allocate_array(&array, initial_size)) {
3944 lbm_set_error_reason("Out of memory while reading.");
3945 lbm_channel_reader_close(str);
3946 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3947 // NOTE: If array is not created evaluation ends here.
3948 // Static analysis seems unaware.
3949 }
3950
3951 sptr[0] = array;
3952 lbm_value *rptr = stack_reserve(ctx, 4);
3953 rptr[0] = lbm_enc_u(initial_size);
3954 rptr[1] = lbm_enc_u(0);
3955 rptr[2] = stream;
3956 rptr[3] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3957 ctx->app_cont = true1;
3958 } else {
3959 lbm_channel_reader_close(str);
3960 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3961 }
3962}
3963
3964static void cont_read_append_array(eval_context_t *ctx) {
3965 lbm_uint *sptr = get_stack_ptr(ctx, 4);
3966
3967 lbm_value array = sptr[0];
3968 lbm_value size = lbm_dec_as_u32(sptr[1]);
3969 lbm_value ix = lbm_dec_as_u32(sptr[2]);
3970 lbm_value stream = sptr[3];
3971
3972 if (ix >= (size - 1)) {
3973 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3974 }
3975
3976 // get_car can return nil. Whose value is 0!
3977 // So static Analysis is right about this being a potential NULL pointer.
3978 // However, if the array was created correcly to begin with, it should be fine.
3979 lbm_value arr_car = get_car(array);
3980 lbm_array_header_t *arr = (lbm_array_header_t*)arr_car;
3981
3982 if (lbm_is_number(ctx->r)) {
3983 ((uint8_t*)arr->data)[ix] = (uint8_t)lbm_dec_as_u32(ctx->r);
3984
3985 sptr[2] = lbm_enc_u(ix + 1);
3986 lbm_value *rptr = stack_reserve(ctx, 4);
3987 rptr[0] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3988 rptr[1] = stream;
3989 rptr[2] = lbm_enc_u(0);
3990 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3991 ctx->app_cont = true1;
3992 } else if (lbm_is_symbol(ctx->r) && ctx->r == ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u)) {
3993 lbm_uint array_size = ix / sizeof(lbm_uint);
3994
3995 if (ix % sizeof(lbm_uint) != 0) {
3996 array_size = array_size + 1;
3997 }
3998 lbm_memory_shrink((lbm_uint*)arr->data, array_size);
3999 arr->size = ix;
4000 lbm_stack_drop(&ctx->K, 4);
4001 ctx->r = array;
4002 ctx->app_cont = true1;
4003 } else {
4004 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
4005 }
4006}
4007
4008static void cont_read_append_continue(eval_context_t *ctx) {
4009 lbm_value *sptr = get_stack_ptr(ctx, 3);
4010
4011 lbm_value first_cell = sptr[0];
4012 lbm_value last_cell = sptr[1];
4013 lbm_value stream = sptr[2];
4014
4015 lbm_char_channel_t *str = lbm_dec_channel(stream);
4016 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4017 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4018 }
4019
4020 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4021
4022 switch(ctx->r) {
4023 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4024 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4025 lbm_set_cdr(last_cell, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate the list
4026 ctx->r = first_cell;
4027 } else {
4028 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4029 }
4030 lbm_stack_drop(&ctx->K, 3);
4031 /* Skip reading another token and apply the continuation */
4032 ctx->app_cont = true1;
4033 return;
4034 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4035 lbm_value *rptr = stack_reserve(ctx, 4);
4036 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4037 rptr[1] = stream;
4038 rptr[2] = lbm_enc_u(0);
4039 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4040 ctx->app_cont = true1;
4041 } return;
4042 }
4043 }
4044 lbm_value new_cell = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4045 if (lbm_is_symbol_merror(new_cell)) {
4046 lbm_channel_reader_close(str);
4047 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4048 return;
4049 }
4050 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4051 lbm_set_cdr(last_cell, new_cell);
4052 last_cell = new_cell;
4053 } else {
4054 first_cell = last_cell = new_cell;
4055 }
4056 sptr[0] = first_cell;
4057 sptr[1] = last_cell;
4058 sptr[2] = stream; // unchanged.
4059 lbm_value *rptr = stack_reserve(ctx, 4);
4060 rptr[0] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
4061 rptr[1] = stream;
4062 rptr[2] = lbm_enc_u(0);
4063 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4064 ctx->app_cont = true1;
4065}
4066
4067static void cont_read_eval_continue(eval_context_t *ctx) {
4068 lbm_value env;
4069 lbm_value stream;
4070 lbm_pop_2(&ctx->K, &env, &stream);
4071
4072 lbm_char_channel_t *str = lbm_dec_channel(stream);
4073 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4074 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4075 }
4076
4077 ctx->row1 = (lbm_int)str->row(str);
4078
4079 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4080
4081 switch(ctx->r) {
4082 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4083 ctx->app_cont = true1;
4084 return;
4085 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4086 // This case is a bit mysterious.
4087 // A dot, may in reality be an error in this location.
4088 lbm_value *rptr = stack_reserve(ctx, 4);
4089 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4090 rptr[1] = stream;
4091 rptr[2] = lbm_enc_u(0);
4092 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4093 ctx->app_cont = true1;
4094 } return;
4095 }
4096 }
4097
4098 lbm_value *rptr = stack_reserve(ctx, 6);
4099 rptr[0] = stream;
4100 rptr[1] = env;
4101 rptr[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
4102 rptr[3] = stream;
4103 rptr[4] = lbm_enc_u(1);
4104 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4105 rptr[6] = lbm_enc_u(ctx->flags);
4106 rptr[7] = POP_READER_FLAGS(((47) << 2) | 0xF8000001u);
4107 ctx->curr_env = env;
4108 ctx->curr_exp = ctx->r;
4109}
4110
4111static void cont_read_expect_closepar(eval_context_t *ctx) {
4112 lbm_value res;
4113 lbm_value stream;
4114
4115 lbm_pop_2(&ctx->K, &res, &stream);
4116
4117 lbm_char_channel_t *str = lbm_dec_channel(stream);
4118 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4119 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4120 }
4121
4122 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4123 ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u)) {
4124 ctx->r = res;
4125 ctx->app_cont = true1;
4126 } else {
4127 lbm_channel_reader_close(str);
4128 lbm_set_error_reason((char*)lbm_error_str_parse_close);
4129 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4130 }
4131}
4132
4133static void cont_read_dot_terminate(eval_context_t *ctx) {
4134 lbm_value *sptr = get_stack_ptr(ctx, 3);
4135
4136 lbm_value first_cell = sptr[0];
4137 lbm_value last_cell = sptr[1];
4138 lbm_value stream = sptr[2];
4139
4140 lbm_char_channel_t *str = lbm_dec_channel(stream);
4141 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4142 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4143 }
4144
4145 lbm_stack_drop(&ctx->K ,3);
4146
4147 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4148 (ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u) ||
4149 ctx->r == ENC_SYM_DOT(((0x76) << 4) | 0x00000000u))) {
4150 lbm_channel_reader_close(str);
4151 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4152 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4153 } else {
4154 if (lbm_is_cons(last_cell)) {
4155 lbm_set_cdr(last_cell, ctx->r);
4156 ctx->r = first_cell;
4157 lbm_value *rptr = stack_reserve(ctx, 6);
4158 rptr[0] = stream;
4159 rptr[1] = ctx->r;
4160 rptr[2] = READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u);
4161 rptr[3] = stream;
4162 rptr[4] = lbm_enc_u(0);
4163 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4164 ctx->app_cont = true1;
4165 } else {
4166 lbm_channel_reader_close(str);
4167 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4168 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4169 }
4170 }
4171}
4172
4173static void cont_read_done(eval_context_t *ctx) {
4174 lbm_value stream;
4175 lbm_value f_val;
4176 lbm_pop_2(&ctx->K, &stream ,&f_val);
4177
4178 uint32_t flags = lbm_dec_as_u32(f_val);
4179 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4180 ctx->flags |= (flags & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4181
4182 lbm_char_channel_t *str = lbm_dec_channel(stream);
4183 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4184 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4185 }
4186
4187 lbm_channel_reader_close(str);
4188 if (lbm_is_symbol(ctx->r)) {
4189 lbm_uint sym_val = lbm_dec_sym(ctx->r);
4190 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
4191 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
4192 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4193 }
4194 }
4195
4196 ctx->row0 = -1;
4197 ctx->row1 = -1;
4198 ctx->app_cont = true1;
4199}
4200
4201static void cont_read_quote_result(eval_context_t *ctx) {
4202 lbm_value cell;
4203 WITH_GC(cell, lbm_heap_allocate_list_init(2,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4204 ENC_SYM_QUOTE,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4205 ctx->r))(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
};
4206 ctx->r = cell;
4207 ctx->app_cont = true1;
4208}
4209
4210static void cont_read_commaat_result(eval_context_t *ctx) {
4211 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4212 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4213 ctx->r = cell1;
4214 ctx->app_cont = true1;
4215}
4216
4217static void cont_read_comma_result(eval_context_t *ctx) {
4218 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u),ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4219 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4220 ctx->r = cell1;
4221 ctx->app_cont = true1;
4222}
4223
4224static void cont_application_start(eval_context_t *ctx) {
4225
4226 /* sptr[0] = env
4227 * sptr[1] = args
4228 * ctx->r = function
4229 */
4230
4231 if (lbm_is_symbol(ctx->r)) {
1
Calling 'lbm_is_symbol'
→
4
←
Returning from 'lbm_is_symbol'
→
5
←
Taking false branch
→
4232 stack_reserve(ctx,1)[0] = lbm_enc_u(0);
4233 cont_application_args(ctx);
4234 } else if (lbm_is_cons(ctx->r)) {
6
←
Calling 'lbm_is_cons'
→
10
←
Returning from 'lbm_is_cons'
→
11
←
Taking true branch
→
4235 lbm_uint *sptr = get_stack_ptr(ctx, 2);
4236 lbm_value args = (lbm_value)sptr[1];
4237 switch (get_car(ctx->r)) {
12
←
Calling 'get_car'
→
15
←
Returning from 'get_car'
→
16
←
Control jumps to 'case 4336:' at line 4238
→
4238 case ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u): {
4239 lbm_value cl[3];
4240 extract_n(get_cdr(ctx->r), cl, 3);
4241 lbm_value arg_env = (lbm_value)sptr[0];
4242 lbm_value arg0, arg_rest;
17
←
'arg_rest' declared without an initial value
→
4243 get_car_and_cdr(args, &arg0, &arg_rest);
18
←
Calling 'get_car_and_cdr'
→
26
←
Returning from 'get_car_and_cdr'
→
4244 sptr[1] = cl[CLO_BODY1];
4245 bool_Bool a_nil = lbm_is_symbol_nil(args);
27
←
Calling 'lbm_is_symbol_nil'
→
29
←
Returning from 'lbm_is_symbol_nil'
→
4246 bool_Bool p_nil = lbm_is_symbol_nil(cl[CLO_PARAMS0]);
30
←
Calling 'lbm_is_symbol_nil'
→
33
←
Returning from 'lbm_is_symbol_nil'
→
4247 lbm_value *reserved = stack_reserve(ctx, 4);
4248
4249 if (!a_nil
33.1
'a_nil' is false
33.1
'a_nil' is false
 && !p_nil
33.2
'p_nil' is false
33.2
'p_nil' is false
) {
34
←
Taking true branch
→
4250 reserved[0] = cl[CLO_ENV2];
4251 reserved[1] = cl[CLO_PARAMS0];
4252 reserved[2] = arg_rest;
35
←
Assigned value is garbage or undefined
4253 reserved[3] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
4254 ctx->curr_exp = arg0;
4255 ctx->curr_env = arg_env;
4256 } else if (a_nil && p_nil) {
4257 // No params, No args
4258 lbm_stack_drop(&ctx->K, 6);
4259 ctx->curr_exp = cl[CLO_BODY1];
4260 ctx->curr_env = cl[CLO_ENV2];
4261 } else if (p_nil) {
4262 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), cl[CLO_ENV2]);
4263 reserved[0] = rest_binder;
4264 reserved[1] = get_cdr(args);
4265 reserved[2] = get_car(rest_binder);
4266 reserved[3] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
4267 ctx->curr_exp = get_car(args);
4268 ctx->curr_env = arg_env;
4269 } else {
4270 lbm_set_error_reason((char*)lbm_error_str_num_args);
4271 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->r);
4272 }
4273 } break;
4274 case ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u):{
4275 /* Continuation created using call-cc.
4276 * ((SYM_CONT . cont-array) arg0 )
4277 */
4278 lbm_value c = get_cdr(ctx->r); /* should be the continuation array*/
4279
4280 if (!lbm_is_lisp_array_r(c)) {
4281 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4282 }
4283
4284 lbm_uint arg_count = lbm_list_length(args);
4285 lbm_value arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4286 switch (arg_count) {
4287 case 0:
4288 arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4289 break;
4290 case 1:
4291 arg = get_car(args);
4292 break;
4293 default:
4294 lbm_set_error_reason((char*)lbm_error_str_num_args);
4295 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4296 }
4297 lbm_stack_clear(&ctx->K);
4298
4299 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(c);
4300
4301 ctx->K.sp = arr->size / sizeof(lbm_uint);
4302 memcpy(ctx->K.data, arr->data, arr->size);
4303
4304 ctx->curr_exp = arg;
4305 break;
4306 }
4307 case ENC_SYM_MACRO(((0x10D) << 4) | 0x00000000u):{
4308 /*
4309 * Perform macro expansion.
4310 * Macro expansion is really just evaluation in an
4311 * environment augmented with the unevaluated expressions passed
4312 * as arguments.
4313 */
4314 lbm_value env = (lbm_value)sptr[0];
4315
4316 lbm_value curr_param = get_cadr(ctx->r);
4317 lbm_value curr_arg = args;
4318 lbm_value expand_env = env;
4319 while (lbm_is_cons(curr_param) &&
4320 lbm_is_cons(curr_arg)) {
4321 lbm_value car_curr_param, cdr_curr_param;
4322 lbm_value car_curr_arg, cdr_curr_arg;
4323 get_car_and_cdr(curr_param, &car_curr_param, &cdr_curr_param);
4324 get_car_and_cdr(curr_arg, &car_curr_arg, &cdr_curr_arg);
4325
4326 lbm_value entry = cons_with_gc(car_curr_param, car_curr_arg, expand_env);
4327 lbm_value aug_env = cons_with_gc(entry, expand_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4328 expand_env = aug_env;
4329
4330 curr_param = cdr_curr_param;
4331 curr_arg = cdr_curr_arg;
4332 }
4333 /* Two rounds of evaluation is performed.
4334 * First to instantiate the arguments into the macro body.
4335 * Second to evaluate the resulting program.
4336 */
4337 sptr[1] = EVAL_R(((11) << 2) | 0xF8000001u);
4338 lbm_value exp = get_cadr(get_cdr(ctx->r));
4339 ctx->curr_exp = exp;
4340 ctx->curr_env = expand_env;
4341 } break;
4342 default:
4343 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4344 }
4345 } else {
4346 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4347 }
4348}
4349
4350static void cont_eval_r(eval_context_t* ctx) {
4351 lbm_value env;
4352 lbm_pop(&ctx->K, &env);
4353 ctx->curr_exp = ctx->r;
4354 ctx->curr_env = env;
4355}
4356
4357static void cont_progn_var(eval_context_t* ctx) {
4358
4359 lbm_value key;
4360 lbm_value env;
4361
4362 lbm_pop_2(&ctx->K, &key, &env);
4363
4364 if (fill_binding_location(key, ctx->r, env) < 0) {
4365 lbm_set_error_reason("Incorrect type of name/key in let-binding");
4366 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
4367 }
4368
4369 ctx->app_cont = true1;
4370}
4371
4372static void cont_setq(eval_context_t *ctx) {
4373 lbm_value sym;
4374 lbm_value env;
4375 lbm_pop_2(&ctx->K, &sym, &env);
4376 lbm_value res;
4377 WITH_GC(res, perform_setvar(sym, ctx->r, env))(res) = (perform_setvar(sym, ctx->r, env)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (perform_setvar(sym, ctx->r, env)
); if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
4378 ctx->r = res;
4379 ctx->app_cont = true1;
4380}
4381
4382lbm_flash_status request_flash_storage_cell(lbm_value val, lbm_value *res) {
4383
4384 lbm_value flash_cell;
4385 lbm_flash_status s = lbm_allocate_const_cell(&flash_cell);
4386 if (s != LBM_FLASH_WRITE_OK)
4387 return s;
4388 lbm_value new_val = val;
4389 new_val &= ~LBM_PTR_VAL_MASK0x03FFFFFCu; // clear the value part of the ptr
4390 new_val |= (flash_cell & LBM_PTR_VAL_MASK0x03FFFFFCu);
4391 new_val |= LBM_PTR_TO_CONSTANT_BIT0x04000000u;
4392 *res = new_val;
4393 return s;
4394}
4395
4396static void cont_move_to_flash(eval_context_t *ctx) {
4397
4398 lbm_value args;
4399 lbm_pop(&ctx->K, &args);
4400
4401 if (lbm_is_symbol_nil(args)) {
4402 // Done looping over arguments. return true.
4403 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
4404 ctx->app_cont = true1;
4405 return;
4406 }
4407
4408 lbm_value first_arg, rest;
4409 get_car_and_cdr(args, &first_arg, &rest);
4410
4411 lbm_value val;
4412 if (lbm_is_symbol(first_arg) && lbm_global_env_lookup(&val, first_arg)) {
4413 // Prepare to copy the rest of the arguments when done with first.
4414 lbm_value *rptr = stack_reserve(ctx, 2);
4415 rptr[0] = rest;
4416 rptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
4417 if (lbm_is_ptr(val) &&
4418 (!(val & LBM_PTR_TO_CONSTANT_BIT0x04000000u))) {
4419 lbm_value * rptr1 = stack_reserve(ctx, 3);
4420 rptr1[0] = first_arg;
4421 rptr1[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
4422 rptr1[2] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4423 ctx->r = val;
4424 }
4425 ctx->app_cont = true1;
4426 return;
4427 }
4428 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4429}
4430
4431static void cont_move_val_to_flash_dispatch(eval_context_t *ctx) {
4432
4433 lbm_value val = ctx->r;
4434
4435 if (lbm_is_cons(val)) {
4436 lbm_value *rptr = stack_reserve(ctx, 5);
4437 rptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // fst cell of list
4438 rptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last cell of list
4439 rptr[2] = get_cdr(val);
4440 rptr[3] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4441 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4442 ctx->r = get_car(val);
4443 ctx->app_cont = true1;
4444 return;
4445 }
4446
4447 if (lbm_is_ptr(val) && (val & LBM_PTR_TO_CONSTANT_BIT0x04000000u)) {
4448 ctx->r = val;
4449 ctx->app_cont = true1;
4450 return;
4451 }
4452
4453 if (lbm_is_ptr(val)) {
4454 lbm_cons_t *ref = lbm_ref_cell(val);
4455 if (lbm_type_of(ref->cdr) == LBM_TYPE_SYMBOL0x00000000u) {
4456 switch (ref->cdr) {
4457 case ENC_SYM_RAW_I_TYPE(((0x31) << 4) | 0x00000000u): /* fall through */
4458 case ENC_SYM_RAW_U_TYPE(((0x32) << 4) | 0x00000000u):
4459 case ENC_SYM_RAW_F_TYPE(((0x33) << 4) | 0x00000000u): {
4460 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4461 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4462 handle_flash_status(write_const_car(flash_cell, ref->car));
4463 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4464 ctx->r = flash_cell;
4465 } break;
4466 case ENC_SYM_IND_I_TYPE(((0x34) << 4) | 0x00000000u): /* fall through */
4467 case ENC_SYM_IND_U_TYPE(((0x35) << 4) | 0x00000000u):
4468 case ENC_SYM_IND_F_TYPE(((0x36) << 4) | 0x00000000u): {
4469#ifndef LBM64
4470 /* 64 bit values are in lbm mem on 32bit platforms. */
4471 lbm_uint *lbm_mem_ptr = (lbm_uint*)ref->car;
4472 lbm_uint flash_ptr;
4473
4474 handle_flash_status(lbm_write_const_raw(lbm_mem_ptr, 2, &flash_ptr));
4475 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4476 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4477 handle_flash_status(write_const_car(flash_cell, flash_ptr));
4478 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4479 ctx->r = flash_cell;
4480#else
4481 // There are no indirect types in LBM64
4482 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4483#endif
4484 } break;
4485 case ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u): {
4486 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4487 lbm_uint size = arr->size / sizeof(lbm_uint);
4488 lbm_uint flash_addr;
4489 lbm_value *arrdata = (lbm_value *)arr->data;
4490 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4491 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4492 handle_flash_status(lbm_allocate_const_raw(size, &flash_addr));
4493 lift_array_flash(flash_cell,
4494 false0,
4495 (char *)flash_addr,
4496 arr->size);
4497 // Move array contents to flash recursively
4498 lbm_value *rptr = stack_reserve(ctx, 5);
4499 rptr[0] = flash_cell;
4500 rptr[1] = lbm_enc_u(0);
4501 rptr[2] = val;
4502 rptr[3] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4503 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4504 ctx->r = arrdata[0];
4505 ctx->app_cont = true1;
4506 return;
4507 }
4508 case ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u): {
4509 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4510 // arbitrary address: flash_arr.
4511 lbm_uint flash_arr;
4512 handle_flash_status(lbm_write_const_array_padded((uint8_t*)arr->data, arr->size, &flash_arr));
4513 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4514 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4515 lift_array_flash(flash_cell,
4516 true1,
4517 (char *)flash_arr,
4518 arr->size);
4519 ctx->r = flash_cell;
4520 } break;
4521 case ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u): /* fall through */
4522 case ENC_SYM_CUSTOM_TYPE(((0x38) << 4) | 0x00000000u):
4523 lbm_set_error_reason((char *)lbm_error_str_flash_not_possible);
4524 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4525 }
4526 } else {
4527 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4528 }
4529 ctx->app_cont = true1;
4530 return;
4531 }
4532 ctx->r = val;
4533 ctx->app_cont = true1;
4534}
4535
4536static void cont_move_list_to_flash(eval_context_t *ctx) {
4537
4538 // ctx->r holds the value that should go in car
4539
4540 lbm_value *sptr = get_stack_ptr(ctx, 3);
4541
4542 lbm_value fst = sptr[0];
4543 lbm_value lst = sptr[1];
4544 lbm_value val = sptr[2];
4545
4546
4547 lbm_value new_lst = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4548 // Allocate element ptr storage after storing the element to flash.
4549 handle_flash_status(request_flash_storage_cell(lbm_enc_cons_ptr(LBM_PTR_NULL(0x03FFFFFCu >> 2)), &new_lst));
4550
4551 if (lbm_is_symbol_nil(fst)) {
4552 lst = new_lst;
4553 fst = new_lst;
4554 handle_flash_status(write_const_car(lst, ctx->r));
4555 } else {
4556 handle_flash_status(write_const_cdr(lst, new_lst)); // low before high
4557 handle_flash_status(write_const_car(new_lst, ctx->r));
4558 lst = new_lst;
4559 }
4560
4561 if (lbm_is_cons(val)) {
4562 sptr[0] = fst;
4563 sptr[1] = lst;//rest_cell;
4564 sptr[2] = get_cdr(val);
4565 lbm_value *rptr = stack_reserve(ctx, 2);
4566 rptr[0] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4567 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4568 ctx->r = get_car(val);
4569 } else {
4570 sptr[0] = fst;
4571 sptr[1] = lst;
4572 sptr[2] = CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u);
4573 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4574 ctx->r = val;
4575 }
4576 ctx->app_cont = true1;
4577}
4578
4579static void cont_close_list_in_flash(eval_context_t *ctx) {
4580 lbm_value fst;
4581 lbm_value lst;
4582 lbm_pop_2(&ctx->K, &lst, &fst);
4583 lbm_value val = ctx->r;
4584 handle_flash_status(write_const_cdr(lst, val));
4585 ctx->r = fst;
4586 ctx->app_cont = true1;
4587}
4588
4589static void cont_move_array_elts_to_flash(eval_context_t *ctx) {
4590 lbm_value *sptr = get_stack_ptr(ctx, 3);
4591 // sptr[2] = source array in RAM
4592 // sptr[1] = current index
4593 // sptr[0] = target array in flash
4594 lbm_array_header_t *src_arr = (lbm_array_header_t*)get_car(sptr[2]);
4595 lbm_uint size = src_arr->size / sizeof(lbm_uint);
4596 lbm_value *srcdata = (lbm_value *)src_arr->data;
4597
4598 lbm_array_header_t *tgt_arr = (lbm_array_header_t*)get_car(sptr[0]);
4599 lbm_uint *tgtdata = (lbm_value *)tgt_arr->data;
4600 lbm_uint ix = lbm_dec_as_u32(sptr[1]);
4601 handle_flash_status(lbm_const_write(&tgtdata[ix], ctx->r));
4602 if (ix >= size-1) {
4603 ctx->r = sptr[0];
4604 lbm_stack_drop(&ctx->K, 3);
4605 ctx->app_cont = true1;
4606 return;
4607 }
4608 sptr[1] = lbm_enc_u(ix + 1);
4609 lbm_value *rptr = stack_reserve(ctx, 2);
4610 rptr[0] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4611 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4612 ctx->r = srcdata[ix+1];
4613 ctx->app_cont = true1;
4614 return;
4615}
4616
4617static void cont_qq_expand_start(eval_context_t *ctx) {
4618 lbm_value *rptr = stack_reserve(ctx, 2);
4619 rptr[0] = ctx->r;
4620 rptr[1] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4621 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4622 ctx->app_cont = true1;
4623}
4624
4625lbm_value quote_it(lbm_value qquoted) {
4626 if (lbm_is_symbol(qquoted) &&
4627 lbm_is_special(qquoted)) return qquoted;
4628
4629 lbm_value val = cons_with_gc(qquoted, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4630 return cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4631}
4632
4633bool_Bool is_append(lbm_value a) {
4634 return (lbm_is_cons(a) &&
4635 lbm_is_symbol(get_car(a)) &&
4636 (get_car(a) == ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u)));
4637}
4638
4639lbm_value append(lbm_value front, lbm_value back) {
4640 if (lbm_is_symbol_nil(front)) return back;
4641 if (lbm_is_symbol_nil(back)) return front;
4642
4643 if (lbm_is_quoted_list(front) &&
4644 lbm_is_quoted_list(back)) {
4645 lbm_value f = get_cadr(front);
4646 lbm_value b = get_cadr(back);
4647 return quote_it(lbm_list_append(f, b));
4648 }
4649
4650 if (is_append(back) &&
4651 lbm_is_quoted_list(get_cadr(back)) &&
4652 lbm_is_quoted_list(front)) {
4653 lbm_value ql = get_cadr(back);
4654 lbm_value f = get_cadr(front);
4655 lbm_value b = get_cadr(ql);
4656
4657 lbm_value v = lbm_list_append(f, b);
4658 lbm_set_car(get_cdr(ql), v);
4659 return back;
4660 }
4661
4662 if (is_append(back)) {
4663 back = get_cdr(back);
4664 lbm_value new = cons_with_gc(front, back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4665 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), new, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4666 }
4667
4668 lbm_value t0, t1;
4669
4670 t0 = cons_with_gc(back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), front);
4671 t1 = cons_with_gc(front, t0, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4672 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), t1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4673}
4674
4675/* Bawden's qq-expand implementation
4676(define (qq-expand x)
4677 (cond ((tag-comma? x)
4678 (tag-data x))
4679 ((tag-comma-atsign? x)
4680 (error "Illegal"))
4681 ((tag-backquote? x)
4682 (qq-expand
4683 (qq-expand (tag-data x))))
4684 ((pair? x)
4685 `(append
4686 ,(qq-expand-list (car x))
4687 ,(qq-expand (cdr x))))
4688 (else `',x)))
4689 */
4690static void cont_qq_expand(eval_context_t *ctx) {
4691 lbm_value qquoted;
4692 lbm_pop(&ctx->K, &qquoted);
4693
4694 switch(lbm_type_of(qquoted)) {
4695 case LBM_TYPE_CONS0x10000000u: {
4696 lbm_value car_val = get_car(qquoted);
4697 lbm_value cdr_val = get_cdr(qquoted);
4698 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4699 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4700 ctx->r = append(ctx->r, get_car(cdr_val));
4701 ctx->app_cont = true1;
4702 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4703 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4704 error_ctx(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u));
4705 } else {
4706 lbm_value *rptr = stack_reserve(ctx, 6);
4707 rptr[0] = ctx->r;
4708 rptr[1] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4709 rptr[2] = cdr_val;
4710 rptr[3] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4711 rptr[4] = car_val;
4712 rptr[5] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4713 ctx->app_cont = true1;
4714 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4715 }
4716
4717 } break;
4718 default: {
4719 lbm_value res = quote_it(qquoted);
4720 ctx->r = append(ctx->r, res);
4721 ctx->app_cont = true1;
4722 }
4723 }
4724}
4725
4726static void cont_qq_append(eval_context_t *ctx) {
4727 lbm_value head;
4728 lbm_pop(&ctx->K, &head);
4729 ctx->r = append(head, ctx->r);
4730 ctx->app_cont = true1;
4731}
4732
4733/* Bawden's qq-expand-list implementation
4734(define (qq-expand-list x)
4735 (cond ((tag-comma? x)
4736 `(list ,(tag-data x)))
4737 ((tag-comma-atsign? x)
4738 (tag-data x))
4739 ((tag-backquote? x)
4740 (qq-expand-list
4741 (qq-expand (tag-data x))))
4742 ((pair? x)
4743 `(list
4744 (append
4745 ,(qq-expand-list (car x))
4746 ,(qq-expand (cdr x)))))
4747 (else `'(,x))))
4748*/
4749
4750static void cont_qq_expand_list(eval_context_t* ctx) {
4751 lbm_value l;
4752 lbm_pop(&ctx->K, &l);
4753
4754 ctx->app_cont = true1;
4755 switch(lbm_type_of(l)) {
4756 case LBM_TYPE_CONS0x10000000u: {
4757 lbm_value car_val = get_car(l);
4758 lbm_value cdr_val = get_cdr(l);
4759 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4760 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4761 lbm_value tl = cons_with_gc(get_car(cdr_val), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4762 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4763 ctx->r = append(ctx->r, tmp);
4764 return;
4765 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4766 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4767 ctx->r = get_car(cdr_val);
4768 return;
4769 } else {
4770 lbm_value *rptr = stack_reserve(ctx, 7);
4771 rptr[0] = QQ_LIST(((39) << 2) | 0xF8000001u);
4772 rptr[1] = ctx->r;
4773 rptr[2] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4774 rptr[3] = cdr_val;
4775 rptr[4] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4776 rptr[5] = car_val;
4777 rptr[6] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4778 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4779 }
4780
4781 } break;
4782 default: {
4783 lbm_value a_list = cons_with_gc(l, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4784 lbm_value tl = cons_with_gc(a_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4785 lbm_value tmp = cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4786 ctx->r = append(ctx->r, tmp);
4787 }
4788 }
4789}
4790
4791static void cont_qq_list(eval_context_t *ctx) {
4792 lbm_value val = ctx->r;
4793 lbm_value apnd_app = cons_with_gc(val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4794 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), apnd_app, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4795 ctx->r = tmp;
4796 ctx->app_cont = true1;
4797}
4798
4799static void cont_kill(eval_context_t *ctx) {
4800 (void) ctx;
4801 finish_ctx();
4802}
4803
4804static void cont_pop_reader_flags(eval_context_t *ctx) {
4805 lbm_value flags;
4806 lbm_pop(&ctx->K, &flags);
4807 ctx->flags = ctx->flags & ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4808 ctx->flags |= (lbm_dec_as_u32(flags) & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4809 // r is unchanged.
4810 ctx->app_cont = true1;
4811}
4812
4813static void cont_exception_handler(eval_context_t *ctx) {
4814 lbm_value *sptr = pop_stack_ptr(ctx, 2);
4815 lbm_value retval = sptr[0];
4816 lbm_value flags = sptr[1];
4817 lbm_set_car(get_cdr(retval), ctx->r);
4818 ctx->flags = flags;
4819 ctx->r = retval;
4820 ctx->app_cont = true1;
4821}
4822
4823/*********************************************************/
4824/* Continuations table */
4825typedef void (*cont_fun)(eval_context_t *);
4826
4827static const cont_fun continuations[NUM_CONTINUATIONS49] =
4828 { advance_ctx, // CONT_DONE
4829 cont_set_global_env,
4830 cont_bind_to_key_rest,
4831 cont_if,
4832 cont_progn_rest,
4833 cont_application_args,
4834 cont_and,
4835 cont_or,
4836 cont_wait,
4837 cont_match,
4838 cont_application_start,
4839 cont_eval_r,
4840 cont_resume,
4841 cont_closure_application_args,
4842 cont_exit_atomic,
4843 cont_read_next_token,
4844 cont_read_append_continue,
4845 cont_read_eval_continue,
4846 cont_read_expect_closepar,
4847 cont_read_dot_terminate,
4848 cont_read_done,
4849 cont_read_quote_result,
4850 cont_read_commaat_result,
4851 cont_read_comma_result,
4852 cont_read_start_array,
4853 cont_read_append_array,
4854 cont_map,
4855 cont_match_guard,
4856 cont_terminate,
4857 cont_progn_var,
4858 cont_setq,
4859 cont_move_to_flash,
4860 cont_move_val_to_flash_dispatch,
4861 cont_move_list_to_flash,
4862 cont_close_list_in_flash,
4863 cont_qq_expand_start,
4864 cont_qq_expand,
4865 cont_qq_append,
4866 cont_qq_expand_list,
4867 cont_qq_list,
4868 cont_kill,
4869 cont_loop,
4870 cont_loop_condition,
4871 cont_merge_rest,
4872 cont_merge_layer,
4873 cont_closure_args_rest,
4874 cont_move_array_elts_to_flash,
4875 cont_pop_reader_flags,
4876 cont_exception_handler
4877 };
4878
4879/*********************************************************/
4880/* Evaluators lookup table (special forms) */
4881typedef void (*evaluator_fun)(eval_context_t *);
4882
4883static const evaluator_fun evaluators[] =
4884 {
4885 eval_quote,
4886 eval_define,
4887 eval_progn,
4888 eval_lambda,
4889 eval_if,
4890 eval_let,
4891 eval_and,
4892 eval_or,
4893 eval_match,
4894 eval_receive,
4895 eval_receive_timeout,
4896 eval_callcc,
4897 eval_atomic,
4898 eval_selfevaluating, // macro
4899 eval_selfevaluating, // cont
4900 eval_selfevaluating, // closure
4901 eval_cond,
4902 eval_app_cont,
4903 eval_var,
4904 eval_setq,
4905 eval_move_to_flash,
4906 eval_loop,
4907 eval_trap
4908 };
4909
4910
4911/*********************************************************/
4912/* Evaluator step function */
4913
4914static void evaluation_step(void){
4915 eval_context_t *ctx = ctx_running;
4916#ifdef VISUALIZE_HEAP
4917 heap_vis_gen_image();
4918#endif
4919
4920 if (ctx->app_cont) {
4921 lbm_value k;
4922 lbm_pop(&ctx->K, &k);
4923 ctx->app_cont = false0;
4924
4925 lbm_uint decoded_k = DEC_CONTINUATION(k)(((k) & ~0xF8000001u) >> 2);
4926
4927 if (decoded_k < NUM_CONTINUATIONS49) {
4928 continuations[decoded_k](ctx);
4929 } else {
4930 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4931 }
4932 return;
4933 }
4934
4935 if (lbm_is_symbol(ctx->curr_exp)) {
4936 eval_symbol(ctx);
4937 return;
4938 }
4939 if (lbm_is_cons(ctx->curr_exp)) {
4940 lbm_cons_t *cell = lbm_ref_cell(ctx->curr_exp);
4941 lbm_value h = cell->car;
4942 if (lbm_is_symbol(h) && ((h & ENC_SPECIAL_FORMS_MASK0xFFFFF000) == ENC_SPECIAL_FORMS_BIT0x00001000)) {
4943 lbm_uint eval_index = lbm_dec_sym(h) & SPECIAL_FORMS_INDEX_MASK0x000000FF;
4944 evaluators[eval_index](ctx);
4945 return;
4946 }
4947 /*
4948 * At this point head can be anything. It should evaluate
4949 * into a form that can be applied (closure, symbol, ...) though.
4950 */
4951 lbm_value *reserved = stack_reserve(ctx, 3);
4952 reserved[0] = ctx->curr_env;
4953 reserved[1] = cell->cdr;
4954 reserved[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
4955 ctx->curr_exp = h; // evaluate the function
4956 return;
4957 }
4958
4959 eval_selfevaluating(ctx);
4960 return;
4961}
4962
4963void lbm_pause_eval(void ) {
4964 eval_cps_next_state_arg = 0;
4965 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4966 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4967}
4968
4969void lbm_pause_eval_with_gc(uint32_t num_free) {
4970 eval_cps_next_state_arg = num_free;
4971 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4972 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4973}
4974
4975void lbm_continue_eval(void) {
4976 eval_cps_next_state = EVAL_CPS_STATE_RUNNING2;
4977 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4978}
4979
4980void lbm_kill_eval(void) {
4981 eval_cps_next_state = EVAL_CPS_STATE_KILL4;
4982 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4983}
4984
4985uint32_t lbm_get_eval_state(void) {
4986 return eval_cps_run_state;
4987}
4988
4989// Will wake up thread that is sleeping as well.
4990// Not sure this is good behavior.
4991static void handle_event_unblock_ctx(lbm_cid cid, lbm_value v) {
4992 eval_context_t *found = NULL((void*)0);
4993 mutex_lock(&qmutex);
4994
4995 found = lookup_ctx_nm(&blocked, cid);
4996 if (found) {
4997 drop_ctx_nm(&blocked,found);
4998 if (lbm_is_error(v)) {
4999 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
5000 found->app_cont = true1;
5001 }
5002 found->r = v;
5003 enqueue_ctx_nm(&queue,found);
5004 }
5005 mutex_unlock(&qmutex);
5006}
5007
5008static void handle_event_define(lbm_value key, lbm_value val) {
5009 lbm_uint dec_key = lbm_dec_sym(key);
5010 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
5011 lbm_value *global_env = lbm_get_global_env();
5012 lbm_uint orig_env = global_env[ix_key];
5013 lbm_value new_env;
5014 // A key is a symbol and should not need to be remembered.
5015 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
5016
5017 global_env[ix_key] = new_env;
5018}
5019
5020static lbm_value get_event_value(lbm_event_t *e) {
5021 lbm_value v;
5022 if (e->buf_len > 0) {
5023 lbm_flat_value_t fv;
5024 fv.buf = (uint8_t*)e->buf_ptr;
5025 fv.buf_size = e->buf_len;
5026 fv.buf_pos = 0;
5027 if (!lbm_unflatten_value(&fv, &v)) {
5028 lbm_set_flags(LBM_FLAG_HANDLER_EVENT_DELIVERY_FAILED(1 << 1));
5029 v = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
5030 }
5031 // Free the flat value buffer. GC is unaware of its existence.
5032 lbm_free(fv.buf);
5033 } else {
5034 v = (lbm_value)e->buf_ptr;
5035 }
5036 return v;
5037}
5038
5039static void process_events(void) {
5040
5041 if (!lbm_events) return;
5042 lbm_event_t e;
5043
5044 while (lbm_event_pop(&e)) {
5045
5046 lbm_value event_val = get_event_value(&e);
5047 switch(e.type) {
5048 case LBM_EVENT_UNBLOCK_CTX:
5049 handle_event_unblock_ctx((lbm_cid)e.parameter, event_val);
5050 break;
5051 case LBM_EVENT_DEFINE:
5052 handle_event_define((lbm_value)e.parameter, event_val);
5053 break;
5054 case LBM_EVENT_FOR_HANDLER:
5055 if (lbm_event_handler_pid >= 0) {
5056 lbm_find_receiver_and_send(lbm_event_handler_pid, event_val);
5057 }
5058 break;
5059 }
5060 }
5061}
5062
5063/* eval_cps_run can be paused
5064 I think it would be better use a mailbox for
5065 communication between other threads and the run_eval
5066 but for now a set of variables will be used. */
5067void lbm_run_eval(void){
5068
5069 if (setjmp(critical_error_jmp_buf)_setjmp (critical_error_jmp_buf) > 0) {
5070 printf_callback("GC stack overflow!\n");
5071 critical_error_callback();
5072 // terminate evaluation thread.
5073 return;
5074 }
5075
5076 setjmp(error_jmp_buf)_setjmp (error_jmp_buf);
5077
5078 while (eval_running) {
5079 if (eval_cps_state_changed || eval_cps_run_state == EVAL_CPS_STATE_PAUSED1) {
5080 eval_cps_state_changed = false0;
5081 switch (eval_cps_next_state) {
5082 case EVAL_CPS_STATE_PAUSED1:
5083 if (eval_cps_run_state != EVAL_CPS_STATE_PAUSED1) {
5084 if (lbm_heap_num_free() < eval_cps_next_state_arg) {
5085 gc();
5086 }
5087 eval_cps_next_state_arg = 0;
5088 }
5089 eval_cps_run_state = EVAL_CPS_STATE_PAUSED1;
5090 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5091 continue; /* jump back to start of eval_running loop */
5092 case EVAL_CPS_STATE_KILL4:
5093 eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
5094 eval_running = false0;
5095 continue;
5096 default: // running state
5097 eval_cps_run_state = eval_cps_next_state;
5098 break;
5099 }
5100 }
5101 while (true1) {
5102 if (eval_steps_quota && ctx_running) {
5103 eval_steps_quota--;
5104 evaluation_step();
5105 } else {
5106 if (eval_cps_state_changed) break;
5107 eval_steps_quota = eval_steps_refill;
5108 if (is_atomic) {
5109 if (!ctx_running) {
5110 lbm_set_flags(LBM_FLAG_ATOMIC_MALFUNCTION(1 << 0));
5111 is_atomic = 0;
5112 }
5113 } else {
5114 if (gc_requested) {
5115 gc();
5116 }
5117 process_events();
5118 mutex_lock(&qmutex);
5119 if (ctx_running) {
5120 enqueue_ctx_nm(&queue, ctx_running);
5121 ctx_running = NULL((void*)0);
5122 }
5123 wake_up_ctxs_nm();
5124 ctx_running = dequeue_ctx_nm(&queue);
5125 mutex_unlock(&qmutex);
5126 if (!ctx_running) {
5127 lbm_system_sleeping = true1;
5128 //Fixed sleep interval to poll events regularly.
5129 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5130 lbm_system_sleeping = false0;
5131 }
5132 }
5133 }
5134 }
5135 }
5136}
5137
5138lbm_cid lbm_eval_program(lbm_value lisp) {
5139 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), 256, NULL((void*)0));
5140}
5141
5142lbm_cid lbm_eval_program_ext(lbm_value lisp, unsigned int stack_size) {
5143 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), stack_size, NULL((void*)0));
5144}
5145
5146int lbm_eval_init() {
5147 if (!qmutex_initialized) {
5148 mutex_init(&qmutex);
5149 qmutex_initialized = true1;
5150 }
5151 if (!lbm_events_mutex_initialized) {
5152 mutex_init(&lbm_events_mutex);
5153 lbm_events_mutex_initialized = true1;
5154 }
5155 if (!blocking_extension_mutex_initialized) {
5156 mutex_init(&blocking_extension_mutex);
5157 blocking_extension_mutex_initialized = true1;
5158 }
5159
5160 mutex_lock(&qmutex);
5161 mutex_lock(&lbm_events_mutex);
5162
5163 blocked.first = NULL((void*)0);
5164 blocked.last = NULL((void*)0);
5165 queue.first = NULL((void*)0);
5166 queue.last = NULL((void*)0);
5167 ctx_running = NULL((void*)0);
5168
5169 eval_cps_run_state = EVAL_CPS_STATE_RUNNING2;
5170
5171 mutex_unlock(&lbm_events_mutex);
5172 mutex_unlock(&qmutex);
5173
5174 if (!lbm_init_env()) return 0;
5175 eval_running = true1;
5176 return 1;
5177}
5178
5179bool_Bool lbm_eval_init_events(unsigned int num_events) {
5180
5181 mutex_lock(&lbm_events_mutex);
5182 lbm_events = (lbm_event_t*)lbm_malloc(num_events * sizeof(lbm_event_t));
5183 bool_Bool r = false0;
5184 if (lbm_events) {
5185 lbm_events_max = num_events;
5186 lbm_events_head = 0;
5187 lbm_events_tail = 0;
5188 lbm_events_full = false0;
5189 lbm_event_handler_pid = -1;
5190 r = true1;
5191 }
5192 mutex_unlock(&lbm_events_mutex);
5193 return r;
5194}
+
+
←

./include/heap.h

+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1
2/*
3 Copyright 2018, 2024 Joel Svensson svenssonjoel@yahoo.se
4
5 This program is free software: you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation, either version 3 of the License, or
8 (at your option) any later version.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
14
15 You should have received a copy of the GNU General Public License
16 along with this program. If not, see <http://www.gnu.org/licenses/>.
17*/
18/** \file heap.h */
19
20#ifndef HEAP_H_
21#define HEAP_H_
22
23#include <string.h>
24#include <stdarg.h>
25
26#include "lbm_types.h"
27#include "symrepr.h"
28#include "stack.h"
29#include "lbm_memory.h"
30#include "lbm_defines.h"
31#include "lbm_channel.h"
32
33#ifdef __cplusplus
34extern "C" {
35#endif
36
37/*
38Planning for a more space efficient heap representation.
39TODO: Need to find a good reference to read up on this.
40 - List based heap
41 - Easy to implement and somewhat efficient
42
430000 0000 Size Free bits
44003F FFFF 4MB 10
45007F FFFF 8MB 9
4600FF FFFF 16MB 8
4701FF FFFF 32MB 7
4803FF FFFF 64MB 6 * Kind of heap size I am looking for
4907FF FFFF 128MB 5
500FFF FFFF 256MB 4
511FFF FFFF 512MB 3
52
53
54--- May 9 2021 ---
55Actually now I am much more interested in way smaller memories ;)
56
570000 0000 Size Free bits
580000 0FFF 4KB 20 |
590000 1FFF 8KB 19 |
600000 3FFF 16KB 18 |
610000 7FFF 32KB 17 |
620000 FFFF 64KB 16 |
630001 FFFF 128KB 15 |
640003 FFFF 256KB 14 | - This range is very interesting.
650007 FFFF 512KB 13
66000F FFFF 1MB 12
67001F FFFF 2MB 11
68003F FFFF 4MB 10
69007F FFFF 8MB 9
7000FF FFFF 16MB 8
7101FF FFFF 32MB 7
7203FF FFFF 64MB 6
7307FF FFFF 128MB 5
740FFF FFFF 256MB 4
751FFF FFFF 512MB 3
76
77Those are the kind of platforms that are fun... so a bunch of
78wasted bits in heap pointers if we run on small MCUs.
79
80-----------------
81
82it is also the case that not all addresses will be used if all "cells" are
83of the same size, 8 bytes...
84
85value 0: 0000 0000
86value 1: 0000 0008
87value 3: 0000 0010
88value 4: 0000 0018
89
90Means bits 0,1,2 will always be empty in a valid address.
91
92Cons cells also need to be have room for 2 pointers. So each ted cell from
93memory should be 8bytes.
94
95Things that needs to be represented within these bits:
96
97 - GC MARK one per cell
98 - TYPE: type of CAR and type of cons
99
100Types I would want:
101 - Full 32bit integer. Does not leave room for identification of type
102 - Float values. Same problem
103
104
105Free bits in pointers 64MB heap:
10631 30 29 28 27 26 2 1 0
1070 0 0 0 0 0 XX XXXX XXXX XXXX XXXX XXXX X 0 0 0
108
109
110Information needed for each cell:
111 Meaning | bits total | bits per car | bits per cdr
112 GC mark | 2 | 1 | 1 - only one of them will be used (the other is wasted)
113 Type | 2x | x | x
114 Ptr/!ptr | 2 | 1 | 1
115
116
117Types (unboxed):
118 - Symbols
119 - 28bit integer ( will need signed shift right functionality )
120 - 28bit unsigned integer
121 - Character
122
123If four types is all that should be possible (unboxed). then 2 bits are needed to differentiate.
1242 + 1 + 1 = 4 => 28bits for data.
125
126bit 0: ptr/!ptr
127bit 1: gc
128bit 2-3: type (if not ptr)
129bit 3 - 24 ptr (if ptr)
130bit 4 - 31 value (if value)
131
132An unboxed value can occupy a car or cdr field in a cons cell.
133
134types (boxed) extra information in pointer to cell can contain information
135 - 32 bit integer
136 - 32 bit unsigned integer
137 - 32 bit float
138
139boxed representation:
140 [ptr| cdr]
141 |
142 [Value | Aux + GC_MARK]
143
144Kinds of pointers:
145 - Pointer to cons cell.
146 - Pointer to unboxed value (fixnums not in a list, I hope this is so rare that it can be removed )
147 - integer
148 - unsigned integer
149 - symbol
150 - float
151 - Pointer to boxed value.
152 - 32 bit integer
153 - 32 bit unsigned integer
154 - 32 bit float
155 - (Maybe something else ? Vectors/strings allocated in memory not occupied by heap?)
156 - vector of int
157 - vector of uint
158 - vector of float
159 - vector of double
160 - String
161
16213 pointer"types" -> needs 4 bits
163for 64MB heap there are 6 free bits. So with this scheme going to 128MB or 256MB heap
164is also possible
165
166 a pointer to some off heap vector/string could be represented by
167
168 [ptr | cdr]
169 |
170 [full pointer | Aux + GC_MARK]
171 |
172 [VECTOR]
173
174Aux bits could be used for storing vector size. Up to 30bits should be available there
175>> This is problematic. Now the information that something is a vector is split up
176>> between 2 cons cells. This means GC needs both of these intact to be able to make
177>> proper decision.
178>> Will try to resolve this by adding some special symbols. But these must be symbols
179>> that cannot occur normally in programs. Then an array could be:
180
181 [Full pointer | ARRAY_SYM + GC_MARK]
182 |
183 [VECTOR]
184
185>> Boxed values same treatment as above.
186>> TODO: Could this be simpler?
187
188[ VALUE | TYPE_SYM + GC_MARK]
189
190
1910000 00XX XXXX XXXX XXXX XXXX XXXX X000 : 0x03FF FFF8
1921111 AA00 0000 0000 0000 0000 0000 0000 : 0xFC00 0000 (AA bits left unused for now, future heap growth?)
193 */
194
195typedef enum {
196 LBM_FLASH_WRITE_OK,
197 LBM_FLASH_FULL,
198 LBM_FLASH_WRITE_ERROR
199} lbm_flash_status;
200
201/** Struct representing a heap cons-cell.
202 *
203 */
204typedef struct {
205 lbm_value car;
206 lbm_value cdr;
207} lbm_cons_t;
208
209/**
210 * Heap state
211 */
212typedef struct {
213 lbm_cons_t *heap;
214 lbm_value freelist; // list of free cons cells.
215 lbm_stack_t gc_stack;
216
217 lbm_uint heap_size; // In number of cells.
218 lbm_uint heap_bytes; // In bytes.
219
220 lbm_uint num_alloc; // Number of cells allocated.
221 lbm_uint num_alloc_arrays; // Number of arrays allocated.
222
223 lbm_uint gc_num; // Number of times gc has been performed.
224 lbm_uint gc_marked; // Number of cells marked by mark phase.
225 lbm_uint gc_recovered; // Number of cells recovered by sweep phase.
226 lbm_uint gc_recovered_arrays;// Number of arrays recovered by sweep.
227 lbm_uint gc_least_free; // The smallest length of the freelist.
228 lbm_uint gc_last_free; // Number of elements on the freelist
229 // after most recent GC.
230} lbm_heap_state_t;
231
232extern lbm_heap_state_t lbm_heap_state;
233
234typedef bool_Bool (*const_heap_write_fun)(lbm_uint ix, lbm_uint w);
235
236typedef struct {
237 lbm_uint *heap;
238 lbm_uint next; // next free index.
239 lbm_uint size; // in lbm_uint words. (cons-cells = words / 2)
240} lbm_const_heap_t;
241
242/**
243 * The header portion of an array stored in array and symbol memory.
244 * An array is always a byte array. use the array-extensions for
245 * storing and reading larger values from arrays.
246 */
247typedef struct {
248 lbm_uint size; /// Number of elements
249 lbm_uint *data; /// pointer to lbm_memory array or C array.
250} lbm_array_header_t;
251
252typedef struct {
253 lbm_uint size;
254 lbm_uint *data;
255 uint32_t index; // Limits arrays to max 2^32-1 elements.
256} lbm_array_header_extended_t;
257
258/** Lock GC mutex
259 * Locks a mutex during GC marking when using the pointer reversal algorithm.
260 * Does nothing when using stack based GC mark.
261 */
262void lbm_gc_lock(void);
263/* Unlock GC mutex
264 */
265void lbm_gc_unlock(void);
266
267/** Initialize heap storage.
268 * \param addr Pointer to an array of lbm_cons_t elements. This array must at least be aligned 4.
269 * \param num_cells Number of lbm_cons_t elements in the array.
270 * \param gc_stack_size Size of the gc_stack in number of words.
271 * \return 1 on success or 0 for failure.
272 */
273int lbm_heap_init(lbm_cons_t *addr, lbm_uint num_cells,
274 lbm_uint gc_stack_size);
275
276/** Add GC time statistics to heap_stats
277 *
278 * \param dur Duration as reported by the timestamp callback.
279 */
280void lbm_heap_new_gc_time(lbm_uint dur);
281/** Add a new free_list length to the heap_stats.
282 * Calculates a new freelist length and updates
283 * the GC statistics.
284 */
285void lbm_heap_new_freelist_length(void);
286/** Check how many lbm_cons_t cells are on the free-list
287 *
288 * \return Number of free lbm_cons_t cells.
289 */
290lbm_uint lbm_heap_num_free(void);
291/** Check how many lbm_cons_t cells are allocated.
292 *
293 * \return Number of lbm_cons_t cells that are currently allocated.
294 */
295lbm_uint lbm_heap_num_allocated(void);
296/** Size of the heap in number of lbm_cons_t cells.
297 *
298 * \return Size of the heap in number of lbm_cons_t cells.
299 */
300lbm_uint lbm_heap_size(void);
301/** Size of the heap in bytes.
302 *
303 * \return Size of heap in bytes.
304 */
305lbm_uint lbm_heap_size_bytes(void);
306/** Allocate an lbm_cons_t cell from the heap.
307 *
308 * \param type A type that can be encoded onto the cell (most often LBM_PTR_TYPE_CONS).
309 * \param car Value to write into car position of allocated cell.
310 * \param cdr Value to write into cdr position of allocated cell.
311 * \return An lbm_value referring to a cons_cell or enc_sym(SYM_MERROR) in case the heap is full.
312 */
313lbm_value lbm_heap_allocate_cell(lbm_type type, lbm_value car, lbm_value cdr);
314/** Allocate a list of n heap-cells.
315 * \param n The number of heap-cells to allocate.
316 * \return A list of heap-cells of Memory error if unable to allocate.
317 */
318lbm_value lbm_heap_allocate_list(lbm_uint n);
319/** Allocate a list of n heap-cells and initialize the values.
320 * \pram ls The result list is passed through this ptr.
321 * \param n The length of list to allocate.
322 * \param valist The values in a va_list to initialize the list with.
323 * \return True of False depending on success of allocation.
324 */
325lbm_value lbm_heap_allocate_list_init_va(unsigned int n, va_list valist);
326/** Allocate a list of n heap-cells and initialize the values.
327 * \param n The length of list to allocate.
328 * \param ... The values to initialize the list with.
329 * \return allocated list or error symbol.
330 */
331lbm_value lbm_heap_allocate_list_init(unsigned int n, ...);
332/** Decode an lbm_value representing a string into a C string
333 *
334 * \param val Value
335 * \return allocated list or error symbol
336 */
337char *lbm_dec_str(lbm_value val);
338/** Decode an lbm_value representing a char channel into an lbm_char_channel_t pointer.
339 *
340 * \param val Value
341 * \return A pointer to an lbm_char_channel_t or NULL if the value does not encode a channel.
342 */
343lbm_char_channel_t *lbm_dec_channel(lbm_value val);
344/** Decode an lbm_value representing a custom type into a lbm_uint value.
345 *
346 * \param val Value.
347 * \return The custom type payload.
348 */
349lbm_uint lbm_dec_custom(lbm_value val);
350/** Decode a numerical value as if it is char
351 *
352 * \param val Value to decode
353 * \return The value encoded in val casted to a char. Returns 0 if val does not encode a number.
354 */
355uint8_t lbm_dec_as_char(lbm_value a);
356/** Decode a numerical value as if it is unsigned
357 *
358 * \param val Value to decode
359 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
360 */
361uint32_t lbm_dec_as_u32(lbm_value val);
362/** Decode a numerical value as a signed integer.
363 *
364 * \param val Value to decode
365 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
366 */
367int32_t lbm_dec_as_i32(lbm_value val);
368/** Decode a numerical value as a float.
369 *
370 * \param val Value to decode.
371 * \return The value encoded in val casted to a float. Returns 0 if val does not encode a number.
372 */
373float lbm_dec_as_float(lbm_value val);
374/** Decode a numerical value as if it is a 64bit unsigned
375 *
376 * \param val Value to decode
377 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
378 */
379uint64_t lbm_dec_as_u64(lbm_value val);
380/** Decode a numerical value as a 64bit signed integer.
381 *
382 * \param val Value to decode
383 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
384 */
385int64_t lbm_dec_as_i64(lbm_value val);
386/** Decode a numerical value as a float.
387 *
388 * \param val Value to decode.
389 * \return The value encoded in val casted to a float. Returns 0 if val does not encode a number.
390 */
391double lbm_dec_as_double(lbm_value val);
392
393/** Decode a numerical value into the architecture defined unsigned integer type.
394 *
395 * \param val Value to decode
396 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
397 */
398lbm_uint lbm_dec_as_uint(lbm_value val);
399
400/** Decode a numerical value into the architecture defined signed integer type.
401 *
402 * \param val Value to decode
403 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
404 */
405lbm_int lbm_dec_as_int(lbm_value val);
406
407lbm_uint lbm_dec_raw(lbm_value v);
408/** Allocates an lbm_cons_t cell from the heap and populates it.
409 *
410 * \param car The value to put in the car field of the allocated lbm_cons_t.
411 * \param cdr The value to put in the cdr field of the allocated lbm_cons_t.
412 * \return A value referencing the lbm_cons_t or enc_sym(SYM_MERROR) if heap is full.
413 */
414lbm_value lbm_cons(lbm_value car, lbm_value cdr);
415
416/** Accesses the car field of an lbm_cons_t.
417 *
418 * \param cons Value
419 * \return The car field of the lbm_cons_t if cons is a reference to a heap cell.
420 * If cons is nil, the return value is nil. If the value
421 * is not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
422 */
423lbm_value lbm_car(lbm_value cons);
424/** Accesses the car field the car field of an lbm_cons_t.
425 *
426 * \param cons Value
427 * \return The car of car field or nil.
428 */
429lbm_value lbm_caar(lbm_value c);
430/** Accesses the car of the cdr of an cons cell
431 *
432 * \param c Value
433 * \return the cdr field or type error.
434 */
435lbm_value lbm_cadr(lbm_value c);
436/** Accesses the cdr field of an lbm_cons_t.
437 *
438 * \param cons Value
439 * \return The cdr field of the lbm_cons_t if cons is a reference to a heap cell.
440 * If cons is nil, the return value is nil. If the value
441 * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
442 */
443lbm_value lbm_cdr(lbm_value cons);
444/** Accesses the cdr of an cdr field of an lbm_cons_t.
445 *
446 * \param cons Value
447 * \return The cdr of the cdr field of the lbm_cons_t if cons is a reference to a heap cell.
448 * If cons is nil, the return value is nil. If the value
449 * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
450 */
451lbm_value lbm_cddr(lbm_value c);
452/** Update the value stored in the car field of a heap cell.
453 *
454 * \param c Value referring to a heap cell.
455 * \param v Value to replace the car field with.
456 * \return 1 on success and 0 if the c value does not refer to a heap cell.
457 */
458int lbm_set_car(lbm_value c, lbm_value v);
459/** Update the value stored in the cdr field of a heap cell.
460 *
461 * \param c Value referring to a heap cell.
462 * \param v Value to replace the cdr field with.
463 * \return 1 on success and 0 if the c value does not refer to a heap cell.
464 */
465int lbm_set_cdr(lbm_value c, lbm_value v);
466/** Update the value stored in the car and cdr fields of a heap cell.
467 *
468 * \param c Value referring to a heap cell.
469 * \param car_val Value to replace the car field with.
470 * \param cdr_val Value to replace the cdr field with.
471 * \return 1 on success and 0 if the c value does not refer to a heap cell.
472 */
473int lbm_set_car_and_cdr(lbm_value c, lbm_value car_val, lbm_value cdr_val);
474// List functions
475/** Calculate the length of a proper list
476 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
477 * may lead to the function not terminating.
478 *
479 * \param c A list
480 * \return The length of the list. Unless the value is a cyclic structure on the heap, this function will terminate.
481 */
482lbm_uint lbm_list_length(lbm_value c);
483
484/** Calculate the length of a proper list and evaluate a predicate for each element.
485 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
486 * may lead to the function not terminating.
487 *
488 * \param c A list
489 * \param pres Boolean result of predicate, false if predicate is false for any of the elements in the list, otherwise true.
490 * \param pred Predicate to evaluate for each element of the list.
491 */
492unsigned int lbm_list_length_pred(lbm_value c, bool_Bool *pres, bool_Bool (*pred)(lbm_value));
493/** Reverse a proper list
494 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
495 * may lead to the function not terminating.
496 *
497 * \param list A list
498 * \return The list reversed or enc_sym(SYM_MERROR) if heap is full.
499 */
500lbm_value lbm_list_reverse(lbm_value list);
501/** Reverse a proper list destroying the original.
502 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
503 * may lead to the function not terminating.
504 *
505 * \param list A list
506 * \return The list reversed
507 */
508lbm_value lbm_list_destructive_reverse(lbm_value list);
509/** Copy a list
510 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
511 * may lead to the function not terminating.
512 *
513 * \param m Number of elements to copy or -1 for all. If 1, m will be updated with the length of the list
514 * \param list A list.
515 * \return Reversed list or enc_sym(SYM_MERROR) if heap is full.
516 */
517lbm_value lbm_list_copy(int *m, lbm_value list);
518
519/** A destructive append of two lists
520 *
521 * \param list1 A list
522 * \param list2 A list
523 * \return list1 with list2 appended at the end.
524 */
525lbm_value lbm_list_append(lbm_value list1, lbm_value list2);
526
527/** Drop values from the head of a list.
528 * \param n Number of values to drop.
529 * \param ls List to drop values from.
530 * \return The list with the n first elements removed.
531 */
532lbm_value lbm_list_drop(unsigned int n, lbm_value ls);
533/** Index into a list.
534 * \param l List to index into.
535 * \param n Position to read out of the list.
536 * \return Value at position n of l or nil if out of bounds.
537 */
538lbm_value lbm_index_list(lbm_value l, int32_t n);
539
540// State and statistics
541/** Get a copy of the heap statistics structure.
542 *
543 * \param A pointer to an lbm_heap_state_t to populate
544 * with the current statistics.
545 */
546void lbm_get_heap_state(lbm_heap_state_t *);
547/** Get the maximum stack level of the GC stack
548 * \return maximum value the gc stack sp reached so far.
549 */
550lbm_uint lbm_get_gc_stack_max(void);
551/** Get the size of the GC stack.
552 * \return the size of the gc stack.
553 */
554lbm_uint lbm_get_gc_stack_size(void);
555// Garbage collection
556/** Increment the counter that is counting the number of times GC ran
557 *
558 */
559void lbm_gc_state_inc(void);
560/** Set the freelist to NIL. Means that no memory will be available
561 * until after a garbage collection.
562 */
563void lbm_nil_freelist(void);
564/** Mark all heap cells reachable from an environment.
565 * \param environment.
566 */
567void lbm_gc_mark_env(lbm_value);
568/** Mark heap cells reachable from the lbm_value v.
569 * \param root
570 */
571void lbm_gc_mark_phase(lbm_value root);
572/** Performs lbm_gc_mark_phase on all the values of an array.
573 * This function is similar to lbm_gc_mark_roots but performs
574 * extra checks to not traverse into non-standard values.
575 * TODO: Check if this function is really needed.
576 * \param data Array of roots to traverse from.
577 * \param n Number of elements in roots-array.
578 */
579void lbm_gc_mark_aux(lbm_uint *data, lbm_uint n);
580/** Performs lbm_gc_mark_phase on all the values in the roots array.
581 * \param roots pointer to array of roots.
582 * \param num_roots size of array of roots.
583 */
584void lbm_gc_mark_roots(lbm_uint *roots, lbm_uint num_roots);
585/** Sweep up all non marked heap cells and place them on the free list.
586 *
587 * \return 1
588 */
589int lbm_gc_sweep_phase(void);
590
591// Array functionality
592/** Allocate an bytearray in symbols and arrays memory (lispbm_memory.h)
593 * and create a heap cell that refers to this bytearray.
594 * \param res The resulting lbm_value is returned through this argument.
595 * \param size Array size in number of 32 bit words.
596 * \return 1 for success of 0 for failure.
597 */
598int lbm_heap_allocate_array(lbm_value *res, lbm_uint size);
599/** Allocate an array in symbols and arrays memory (lispbm_memory.h)
600 * and create a heap cell that refers to this array.
601 * \param res The resulting lbm_value is returned through this argument.
602 * \param size Array size in number of 32 bit words.
603 * \return 1 for success of 0 for failure.
604 */
605int lbm_heap_allocate_lisp_array(lbm_value *res, lbm_uint size);
606/** Convert a C array into an lbm array. If the C array is allocated in LBM MEMORY
607 * the lifetime of the array will be managed by GC.
608 * \param res lbm_value result pointer for storage of the result array.
609 * \param data C array.
610 * \param type The type tag to assign to the resulting LBM array.
611 * \param num_elt Number of elements in the array.
612 * \return 1 for success and 0 for failure.
613 */
614int lbm_lift_array(lbm_value *value, char *data, lbm_uint num_elt);
615/** Get the size of an array value.
616 * \param arr lbm_value array to get size of.
617 * \return -1 for failure or length of array.
618 */
619lbm_int lbm_heap_array_get_size(lbm_value arr);
620/** Get a pointer to the data of an array for read only purposes.
621 * \param arr lbm_value array to get pointer from.
622 * \return NULL or valid pointer.
623 */
624const uint8_t *lbm_heap_array_get_data_ro(lbm_value arr);
625/** Get a pointer to the data of an array for read/write purposes.
626 * \param arr lbm_value array to get pointer from.
627 * \return NULL or valid pointer.
628 */
629uint8_t *lbm_heap_array_get_data_rw(lbm_value arr);
630/** Explicitly free an array.
631 * This function needs to be used with care and knowledge.
632 * \param arr Array value.
633 */
634int lbm_heap_explicit_free_array(lbm_value arr);
635/** Query the size in bytes of an lbm_type.
636 * \param t Type
637 * \return Size in bytes of type or 0 if the type represents a composite.
638 */
639lbm_uint lbm_size_of(lbm_type t);
640
641int lbm_const_heap_init(const_heap_write_fun w_fun,
642 lbm_const_heap_t *heap,
643 lbm_uint *addr,
644 lbm_uint num_words);
645
646lbm_flash_status lbm_allocate_const_cell(lbm_value *res);
647lbm_flash_status lbm_write_const_raw(lbm_uint *data, lbm_uint n, lbm_uint *res);
648lbm_flash_status lbm_allocate_const_raw(lbm_uint nwords, lbm_uint *res);
649lbm_flash_status write_const_cdr(lbm_value cell, lbm_value val);
650lbm_flash_status write_const_car(lbm_value cell, lbm_value val);
651lbm_flash_status lbm_const_write(lbm_uint *tgt, lbm_uint val);
652lbm_uint lbm_flash_memory_usage(void);
653
654/** Query the type information of a value.
655 *
656 * \param x Value to check the type of.
657 * \return The type information.
658 */
659static inline lbm_type lbm_type_of(lbm_value x) {
660 return (x & LBM_PTR_BIT0x00000001u) ? (x & LBM_PTR_TYPE_MASK0xFC000000u) : (x & LBM_VAL_TYPE_MASK0x0000000Cu);
661}
662
663// type-of check that is safe in functional code
664static inline lbm_type lbm_type_of_functional(lbm_value x) {
665 return (x & LBM_PTR_BIT0x00000001u) ?
666 (x & (LBM_PTR_TO_CONSTANT_MASK~0x04000000u & LBM_PTR_TYPE_MASK0xFC000000u)) :
667 (x & LBM_VAL_TYPE_MASK0x0000000Cu);
668}
669
670static inline lbm_value lbm_enc_cons_ptr(lbm_uint x) {
671 return ((x << LBM_ADDRESS_SHIFT2) | LBM_TYPE_CONS0x10000000u | LBM_PTR_BIT0x00000001u);
672}
673
674static inline lbm_uint lbm_dec_ptr(lbm_value p) {
675 return ((LBM_PTR_VAL_MASK0x03FFFFFCu & p) >> LBM_ADDRESS_SHIFT2);
676}
677
678extern lbm_cons_t *lbm_heaps[2];
679
680static inline lbm_uint lbm_dec_cons_cell_ptr(lbm_value p) {
681 lbm_uint h = (p & LBM_PTR_TO_CONSTANT_BIT0x04000000u) >> LBM_PTR_TO_CONSTANT_SHIFT26;
682 return lbm_dec_ptr(p) >> h;
683}
684
685static inline lbm_cons_t *lbm_dec_heap(lbm_value p) {
686 lbm_uint h = (p & LBM_PTR_TO_CONSTANT_BIT0x04000000u) >> LBM_PTR_TO_CONSTANT_SHIFT26;
687 return lbm_heaps[h];
688}
689
690static inline lbm_value lbm_set_ptr_type(lbm_value p, lbm_type t) {
691 return ((LBM_PTR_VAL_MASK0x03FFFFFCu & p) | t | LBM_PTR_BIT0x00000001u);
692}
693
694static inline lbm_value lbm_enc_sym(lbm_uint s) {
695 return (s << LBM_VAL_SHIFT4) | LBM_TYPE_SYMBOL0x00000000u;
696}
697
698static inline lbm_value lbm_enc_i(lbm_int x) {
699 return ((lbm_uint)x << LBM_VAL_SHIFT4) | LBM_TYPE_I0x00000008u;
700}
701
702static inline lbm_value lbm_enc_u(lbm_uint x) {
703 return (x << LBM_VAL_SHIFT4) | LBM_TYPE_U0x0000000Cu;
704}
705
706/** Encode 32 bit integer into an lbm_value.
707 * \param x Value to encode.
708 * \return result encoded value.
709 */
710extern lbm_value lbm_enc_i32(int32_t x);
711
712/** Encode 32 bit unsigned integer into an lbm_value.
713 * \param x Value to encode.
714 * \return result encoded value.
715 */
716extern lbm_value lbm_enc_u32(uint32_t x);
717
718/** Encode a float into an lbm_value.
719 * \param x float value to encode.
720 * \return result encoded value.
721 */
722extern lbm_value lbm_enc_float(float x);
723
724/** Encode a 64 bit integer into an lbm_value.
725 * \param x 64 bit integer to encode.
726 * \return result encoded value.
727 */
728extern lbm_value lbm_enc_i64(int64_t x);
729
730/** Encode a 64 bit unsigned integer into an lbm_value.
731 * \param x 64 bit unsigned integer to encode.
732 * \return result encoded value.
733 */
734extern lbm_value lbm_enc_u64(uint64_t x);
735
736/** Encode a double into an lbm_value.
737 * \param x double to encode.
738 * \return result encoded value.
739 */
740extern lbm_value lbm_enc_double(double x);
741
742static inline lbm_value lbm_enc_char(uint8_t x) {
743 return ((lbm_uint)x << LBM_VAL_SHIFT4) | LBM_TYPE_CHAR0x00000004u;
744}
745
746static inline lbm_int lbm_dec_i(lbm_value x) {
747 return (lbm_int)x >> LBM_VAL_SHIFT4;
748}
749
750static inline lbm_uint lbm_dec_u(lbm_value x) {
751 return x >> LBM_VAL_SHIFT4;
752}
753
754static inline uint8_t lbm_dec_char(lbm_value x) {
755 return (uint8_t)(x >> LBM_VAL_SHIFT4);
756}
757
758static inline lbm_uint lbm_dec_sym(lbm_value x) {
759 return x >> LBM_VAL_SHIFT4;
760}
761
762/** Decode an lbm_value representing a float.
763 * \param x Value to decode.
764 * \return decoded float.
765 */
766extern float lbm_dec_float(lbm_value x);
767
768/** Decode an lbm_value representing a double.
769 * \param x Value to decode.
770 * \return decoded float.
771 */
772extern double lbm_dec_double(lbm_value x);
773
774
775static inline uint32_t lbm_dec_u32(lbm_value x) {
776#ifndef LBM64
777 return (uint32_t)lbm_car(x);
778#else
779 return (uint32_t)(x >> LBM_VAL_SHIFT4);
780#endif
781}
782
783/** Decode an lbm_value representing a 64 bit unsigned integer.
784 * \param x Value to decode.
785 * \return decoded uint64_t.
786 */
787extern uint64_t lbm_dec_u64(lbm_value x);
788
789static inline int32_t lbm_dec_i32(lbm_value x) {
790#ifndef LBM64
791 return (int32_t)lbm_car(x);
792#else
793 return (int32_t)(x >> LBM_VAL_SHIFT4);
794#endif
795}
796
797/** Decode an lbm_value representing a 64 bit integer.
798 * \param x Value to decode.
799 * \return decoded int64_t.
800 */
801extern int64_t lbm_dec_i64(lbm_value x);
802
803/**
804 * Check if a value is a heap pointer
805 * \param x Value to check
806 * \return true if x is a pointer to a heap cell, false otherwise.
807 */
808static inline bool_Bool lbm_is_ptr(lbm_value x) {
809 return (x & LBM_PTR_BIT0x00000001u);
810}
811
812/**
813 * Check if a value is a Read/Writeable cons cell
814 * \param x Value to check
815 * \return true if x is a Read/Writeable cons cell, false otherwise.
816 */
817static inline bool_Bool lbm_is_cons_rw(lbm_value x) {
818 return (lbm_type_of(x) == LBM_TYPE_CONS0x10000000u);
819}
820
821/**
822 * Check if a value is a Readable cons cell
823 * \param x Value to check
824 * \return true if x is a readable cons cell, false otherwise.
825 */
826static inline bool_Bool lbm_is_cons(lbm_value x) {
827 return lbm_is_ptr(x) && ((x & LBM_CONS_TYPE_MASK0xF0000000u) == LBM_TYPE_CONS0x10000000u);
7
←
Assuming the condition is true
→
8
←
Assuming the condition is true
→
9
←
Returning the value 1, which participates in a condition later
→
828}
829
830/** Check if a value represents a number
831 * \param x Value to check.
832 * \return true is x represents a number and false otherwise.
833 */
834static inline bool_Bool lbm_is_number(lbm_value x) {
835 return
836 (x & LBM_PTR_BIT0x00000001u) ?
837 ((x & LBM_NUMBER_MASK0x08000000u) == LBM_NUMBER_MASK0x08000000u) :
838 (x & LBM_VAL_TYPE_MASK0x0000000Cu);
839}
840
841/** Check if value is an array that can be READ
842 * \param x Value to check.
843 * \return true if x represents a readable array and false otherwise.
844 */
845static inline bool_Bool lbm_is_array_r(lbm_value x) {
846 lbm_type t = lbm_type_of(x);
847 return ((t & LBM_PTR_TO_CONSTANT_MASK~0x04000000u) == LBM_TYPE_ARRAY0x80000000u);
848}
849
850static inline bool_Bool lbm_is_array_rw(lbm_value x) {
851 return( (lbm_type_of(x) == LBM_TYPE_ARRAY0x80000000u) && !(x & LBM_PTR_TO_CONSTANT_BIT0x04000000u));
852}
853
854static inline bool_Bool lbm_is_lisp_array_r(lbm_value x) {
855 lbm_type t = lbm_type_of(x);
856 return ((t & LBM_PTR_TO_CONSTANT_MASK~0x04000000u) == LBM_TYPE_LISPARRAY0xB0000000u);
857}
858
859static inline bool_Bool lbm_is_lisp_array_rw(lbm_value x) {
860 return( (lbm_type_of(x) == LBM_TYPE_LISPARRAY0xB0000000u) && !(x & LBM_PTR_TO_CONSTANT_BIT0x04000000u));
861}
862
863
864static inline bool_Bool lbm_is_channel(lbm_value x) {
865 return (lbm_type_of(x) == LBM_TYPE_CHANNEL0x90000000u &&
866 lbm_type_of(lbm_cdr(x)) == LBM_TYPE_SYMBOL0x00000000u &&
867 lbm_cdr(x) == ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
868}
869static inline bool_Bool lbm_is_char(lbm_value x) {
870 return (lbm_type_of(x) == LBM_TYPE_CHAR0x00000004u);
871}
872
873static inline bool_Bool lbm_is_special(lbm_value symrep) {
874 return ((lbm_type_of(symrep) == LBM_TYPE_SYMBOL0x00000000u) &&
875 (lbm_dec_sym(symrep) < SPECIAL_SYMBOLS_END0xFFFF));
876}
877
878static inline bool_Bool lbm_is_closure(lbm_value exp) {
879 return ((lbm_is_cons(exp)) &&
880 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
881 (lbm_car(exp) == ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u)));
882}
883
884static inline bool_Bool lbm_is_continuation(lbm_value exp) {
885 return ((lbm_type_of(exp) == LBM_TYPE_CONS0x10000000u) &&
886 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
887 (lbm_car(exp) == ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u)));
888}
889
890static inline bool_Bool lbm_is_macro(lbm_value exp) {
891 return ((lbm_type_of(exp) == LBM_TYPE_CONS0x10000000u) &&
892 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
893 (lbm_car(exp) == ENC_SYM_MACRO(((0x10D) << 4) | 0x00000000u)));
894}
895
896static inline bool_Bool lbm_is_match_binder(lbm_value exp) {
897 return (lbm_is_cons(exp) &&
898 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
899 (lbm_car(exp) == ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u)));
900}
901
902static inline bool_Bool lbm_is_comma_qualified_symbol(lbm_value exp) {
903 return (lbm_is_cons(exp) &&
904 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
905 (lbm_car(exp) == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) &&
906 (lbm_type_of(lbm_cadr(exp)) == LBM_TYPE_SYMBOL0x00000000u));
907}
908
909static inline bool_Bool lbm_is_symbol(lbm_value exp) {
910 return !(exp & LBM_LOW_RESERVED_BITS0x0000000Fu);
2
←
Assuming the condition is false
→
3
←
Returning zero, which participates in a condition later
→
911}
912
913static inline bool_Bool lbm_is_symbol_nil(lbm_value exp) {
914 return !exp
27.1
'exp' is not equal to 0, which participates in a condition later
27.1
'exp' is not equal to 0, which participates in a condition later
;
22
←
Assuming 'exp' is not equal to 0, which participates in a condition later
→
28
←
Returning zero, which participates in a condition later
→
31
←
Assuming 'exp' is not equal to 0, which participates in a condition later
→
32
←
Returning zero, which participates in a condition later
→
915}
916
917static inline bool_Bool lbm_is_symbol_true(lbm_value exp) {
918 return (lbm_is_symbol(exp) && exp == ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u));
919}
920
921static inline bool_Bool lbm_is_symbol_eval(lbm_value exp) {
922 return (lbm_is_symbol(exp) && exp == ENC_SYM_EVAL(((0x30008) << 4) | 0x00000000u));
923}
924
925static inline bool_Bool lbm_is_symbol_merror(lbm_value exp) {
926 return lbm_is_symbol(exp) && (exp == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
927}
928
929static inline bool_Bool lbm_is_list(lbm_value x) {
930 return (lbm_is_cons(x) || lbm_is_symbol_nil(x));
931}
932
933static inline bool_Bool lbm_is_list_rw(lbm_value x) {
934 return (lbm_is_cons_rw(x) || lbm_is_symbol_nil(x));
935}
936
937static inline bool_Bool lbm_is_quoted_list(lbm_value x) {
938 return (lbm_is_cons(x) &&
939 lbm_is_symbol(lbm_car(x)) &&
940 (lbm_car(x) == ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u)) &&
941 lbm_is_cons(lbm_cdr(x)) &&
942 lbm_is_cons(lbm_cadr(x)));
943}
944
945#ifndef LBM64
946#define ERROR_SYMBOL_MASK0xFFFFFFF0 0xFFFFFFF0
947#else
948#define ERROR_SYMBOL_MASK0xFFFFFFF0 0xFFFFFFFFFFFFFFF0
949#endif
950
951/* all error signaling symbols are in the range 0x20 - 0x2F */
952static inline bool_Bool lbm_is_error(lbm_value v){
953 return (lbm_is_symbol(v) &&
954 ((lbm_dec_sym(v) & ERROR_SYMBOL_MASK0xFFFFFFF0) == 0x20));
955}
956
957// ref_cell: returns a reference to the cell addressed by bits 3 - 26
958// Assumes user has checked that is_ptr was set
959static inline lbm_cons_t* lbm_ref_cell(lbm_value addr) {
960 return &lbm_dec_heap(addr)[lbm_dec_cons_cell_ptr(addr)];
961 //return &lbm_heap_state.heap[lbm_dec_ptr(addr)];
962}
963
964
965// lbm_uint a = lbm_heaps[0];
966// lbm_uint b = lbm_heaps[1];
967// lbm_uint i = (addr & LBM_PTR_TO_CONSTANT_BIT) >> LBM_PTR_TO_CONSTANT_SHIFT) - 1;
968// lbm_uint h = (a & i) | (b & ~i);
969
970#ifdef __cplusplus
971}
972#endif
973#endif
diff --git a/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-a60707.html b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-a60707.html new file mode 100644 index 00000000..8fd3fa16 --- /dev/null +++ b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-a60707.html @@ -0,0 +1,5548 @@ + + + +src/eval_cps.c + + + + + + + + + + + + + + + + + + + + + + + + + + +

Bug Summary

+ + + + +
File:eval_cps.c
Warning:line 2163, column 17
Assigned value is garbage or undefined
+ +

Annotated Source Code

+

Press '?' + to see keyboard shortcuts

+ + +
clang -cc1 -triple i386-pc-linux-gnu -analyze -disable-free -disable-llvm-verifier -discard-value-names -main-file-name eval_cps.c -analyzer-store=region -analyzer-opt-analyze-nested-blocks -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -mrelocation-model static -mthread-model posix -mframe-pointer=none -fmath-errno -fno-rounding-math -masm-verbose -mconstructor-aliases -target-cpu i686 -dwarf-column-info -fno-split-dwarf-inlining -debugger-tuning=gdb -resource-dir /usr/lib/llvm-10/lib/clang/10.0.0 -I ./include -I ./include/extensions -I platform/linux/include -D _PRELUDE -internal-isystem /usr/local/include -internal-isystem /usr/lib/llvm-10/lib/clang/10.0.0/include -internal-externc-isystem /usr/include/i386-linux-gnu -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -std=c99 -fdebug-compilation-dir /home/joels/Current/lispbm -ferror-limit 19 -fmessage-length 0 -fgnuc-version=4.2.1 -fobjc-runtime=gcc -fdiagnostics-show-option -vectorize-loops -vectorize-slp -analyzer-output=html -faddrsig -o /home/joels/Current/lispbm/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1 -x c src/eval_cps.c +
+ + + +
+ + +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1/*
2 Copyright 2018, 2020 - 2024 Joel Svensson svenssonjoel@yahoo.se
3
4 This program is free software: you can redistribute it and/or modify
5 it under the terms of the GNU General Public License as published by
6 the Free Software Foundation, either version 3 of the License, or
7 (at your option) any later version.
8
9 This program is distributed in the hope that it will be useful,
10 but WITHOUT ANY WARRANTY; without even the implied warranty of
11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 GNU General Public License for more details.
13
14 You should have received a copy of the GNU General Public License
15 along with this program. If not, see <http://www.gnu.org/licenses/>.
16*/
17
18#include <lbm_memory.h>
19#include <lbm_types.h>
20#include "symrepr.h"
21#include "heap.h"
22#include "env.h"
23#include "eval_cps.h"
24#include "stack.h"
25#include "fundamental.h"
26#include "extensions.h"
27#include "tokpar.h"
28#include "lbm_channel.h"
29#include "print.h"
30#include "platform_mutex.h"
31#include "lbm_flat_value.h"
32#include "lbm_flags.h"
33
34#ifdef VISUALIZE_HEAP
35#include "heap_vis.h"
36#endif
37
38#include <setjmp.h>
39#include <stdarg.h>
40
41static jmp_buf error_jmp_buf;
42static jmp_buf critical_error_jmp_buf;
43
44#define S_TO_US(X)(lbm_uint)((X) * 1000000) (lbm_uint)((X) * 1000000)
45
46#define DEC_CONTINUATION(x)(((x) & ~0xF8000001u) >> 2) (((x) & ~LBM_CONTINUATION_INTERNAL0xF8000001u) >> LBM_ADDRESS_SHIFT2)
47#define IS_CONTINUATION(x)(((x) & 0xF8000001u) == 0xF8000001u) (((x) & LBM_CONTINUATION_INTERNAL0xF8000001u) == LBM_CONTINUATION_INTERNAL0xF8000001u)
48#define CONTINUATION(x)(((x) << 2) | 0xF8000001u) (((x) << LBM_ADDRESS_SHIFT2) | LBM_CONTINUATION_INTERNAL0xF8000001u)
49
50#define DONE(((0) << 2) | 0xF8000001u) CONTINUATION(0)(((0) << 2) | 0xF8000001u)
51#define SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u) CONTINUATION(1)(((1) << 2) | 0xF8000001u)
52#define BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u) CONTINUATION(2)(((2) << 2) | 0xF8000001u)
53#define IF(((3) << 2) | 0xF8000001u) CONTINUATION(3)(((3) << 2) | 0xF8000001u)
54#define PROGN_REST(((4) << 2) | 0xF8000001u) CONTINUATION(4)(((4) << 2) | 0xF8000001u)
55#define APPLICATION_ARGS(((5) << 2) | 0xF8000001u) CONTINUATION(5)(((5) << 2) | 0xF8000001u)
56#define AND(((6) << 2) | 0xF8000001u) CONTINUATION(6)(((6) << 2) | 0xF8000001u)
57#define OR(((7) << 2) | 0xF8000001u) CONTINUATION(7)(((7) << 2) | 0xF8000001u)
58#define WAIT(((8) << 2) | 0xF8000001u) CONTINUATION(8)(((8) << 2) | 0xF8000001u)
59#define MATCH(((9) << 2) | 0xF8000001u) CONTINUATION(9)(((9) << 2) | 0xF8000001u)
60#define APPLICATION_START(((10) << 2) | 0xF8000001u) CONTINUATION(10)(((10) << 2) | 0xF8000001u)
61#define EVAL_R(((11) << 2) | 0xF8000001u) CONTINUATION(11)(((11) << 2) | 0xF8000001u)
62#define RESUME(((12) << 2) | 0xF8000001u) CONTINUATION(12)(((12) << 2) | 0xF8000001u)
63#define CLOSURE_ARGS(((13) << 2) | 0xF8000001u) CONTINUATION(13)(((13) << 2) | 0xF8000001u)
64#define EXIT_ATOMIC(((14) << 2) | 0xF8000001u) CONTINUATION(14)(((14) << 2) | 0xF8000001u)
65#define READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u) CONTINUATION(15)(((15) << 2) | 0xF8000001u)
66#define READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u) CONTINUATION(16)(((16) << 2) | 0xF8000001u)
67#define READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u) CONTINUATION(17)(((17) << 2) | 0xF8000001u)
68#define READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u) CONTINUATION(18)(((18) << 2) | 0xF8000001u)
69#define READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u) CONTINUATION(19)(((19) << 2) | 0xF8000001u)
70#define READ_DONE(((20) << 2) | 0xF8000001u) CONTINUATION(20)(((20) << 2) | 0xF8000001u)
71#define READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u) CONTINUATION(21)(((21) << 2) | 0xF8000001u)
72#define READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u) CONTINUATION(22)(((22) << 2) | 0xF8000001u)
73#define READ_COMMA_RESULT(((23) << 2) | 0xF8000001u) CONTINUATION(23)(((23) << 2) | 0xF8000001u)
74#define READ_START_ARRAY(((24) << 2) | 0xF8000001u) CONTINUATION(24)(((24) << 2) | 0xF8000001u)
75#define READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u) CONTINUATION(25)(((25) << 2) | 0xF8000001u)
76#define MAP(((26) << 2) | 0xF8000001u) CONTINUATION(26)(((26) << 2) | 0xF8000001u)
77#define MATCH_GUARD(((27) << 2) | 0xF8000001u) CONTINUATION(27)(((27) << 2) | 0xF8000001u)
78#define TERMINATE(((28) << 2) | 0xF8000001u) CONTINUATION(28)(((28) << 2) | 0xF8000001u)
79#define PROGN_VAR(((29) << 2) | 0xF8000001u) CONTINUATION(29)(((29) << 2) | 0xF8000001u)
80#define SETQ(((30) << 2) | 0xF8000001u) CONTINUATION(30)(((30) << 2) | 0xF8000001u)
81#define MOVE_TO_FLASH(((31) << 2) | 0xF8000001u) CONTINUATION(31)(((31) << 2) | 0xF8000001u)
82#define MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u) CONTINUATION(32)(((32) << 2) | 0xF8000001u)
83#define MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u) CONTINUATION(33)(((33) << 2) | 0xF8000001u)
84#define CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u) CONTINUATION(34)(((34) << 2) | 0xF8000001u)
85#define QQ_EXPAND_START(((35) << 2) | 0xF8000001u) CONTINUATION(35)(((35) << 2) | 0xF8000001u)
86#define QQ_EXPAND(((36) << 2) | 0xF8000001u) CONTINUATION(36)(((36) << 2) | 0xF8000001u)
87#define QQ_APPEND(((37) << 2) | 0xF8000001u) CONTINUATION(37)(((37) << 2) | 0xF8000001u)
88#define QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u) CONTINUATION(38)(((38) << 2) | 0xF8000001u)
89#define QQ_LIST(((39) << 2) | 0xF8000001u) CONTINUATION(39)(((39) << 2) | 0xF8000001u)
90#define KILL(((40) << 2) | 0xF8000001u) CONTINUATION(40)(((40) << 2) | 0xF8000001u)
91#define LOOP(((41) << 2) | 0xF8000001u) CONTINUATION(41)(((41) << 2) | 0xF8000001u)
92#define LOOP_CONDITION(((42) << 2) | 0xF8000001u) CONTINUATION(42)(((42) << 2) | 0xF8000001u)
93#define MERGE_REST(((43) << 2) | 0xF8000001u) CONTINUATION(43)(((43) << 2) | 0xF8000001u)
94#define MERGE_LAYER(((44) << 2) | 0xF8000001u) CONTINUATION(44)(((44) << 2) | 0xF8000001u)
95#define CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u) CONTINUATION(45)(((45) << 2) | 0xF8000001u)
96#define MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u) CONTINUATION(46)(((46) << 2) | 0xF8000001u)
97#define POP_READER_FLAGS(((47) << 2) | 0xF8000001u) CONTINUATION(47)(((47) << 2) | 0xF8000001u)
98#define EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u) CONTINUATION(48)(((48) << 2) | 0xF8000001u)
99#define NUM_CONTINUATIONS49 49
100
101#define FM_NEED_GC-1 -1
102#define FM_NO_MATCH-2 -2
103#define FM_PATTERN_ERROR-3 -3
104
105typedef enum {
106 BL_OK = 0,
107 BL_NO_MEMORY,
108 BL_INCORRECT_KEY
109} binding_location_status;
110
111#define FB_OK0 0
112#define FB_TYPE_ERROR-1 -1
113
114const char* lbm_error_str_parse_eof = "End of parse stream.";
115const char* lbm_error_str_parse_dot = "Incorrect usage of '.'.";
116const char* lbm_error_str_parse_close = "Expected closing parenthesis.";
117const char* lbm_error_str_num_args = "Incorrect number of arguments.";
118const char* lbm_error_str_forbidden_in_atomic = "Operation is forbidden in an atomic block.";
119const char* lbm_error_str_no_number = "Argument(s) must be a number.";
120const char* lbm_error_str_not_a_boolean = "Argument must be t or nil (true or false).";
121const char* lbm_error_str_incorrect_arg = "Incorrect argument.";
122const char* lbm_error_str_var_outside_progn = "Usage of var outside of progn.";
123const char* lbm_error_str_flash_not_possible = "Value cannot be written to flash.";
124const char* lbm_error_str_flash_error = "Error writing to flash.";
125const char* lbm_error_str_flash_full = "Flash memory is full.";
126const char* lbm_error_str_variable_not_bound = "Variable not bound.";
127
128static lbm_value lbm_error_suspect;
129static bool_Bool lbm_error_has_suspect = false0;
130#ifdef LBM_ALWAYS_GC
131
132#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
133 gc(); \
134 (y) = (x); \
135 if (lbm_is_symbol_merror((y))) { \
136 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
137 }
138
139#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
140 lbm_gc_mark_phase(r); \
141 gc(); \
142 (y) = (x); \
143 if (lbm_is_symbol_merror((y))) { \
144 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
145 }
146
147#else
148
149#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
150 (y) = (x); \
151 if (lbm_is_symbol_merror((y))) { \
152 gc(); \
153 (y) = (x); \
154 if (lbm_is_symbol_merror((y))) { \
155 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
156 } \
157 /* continue executing statements below */ \
158 }
159#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
160 (y) = (x); \
161 if (lbm_is_symbol_merror((y))) { \
162 lbm_gc_mark_phase(r); \
163 gc(); \
164 (y) = (x); \
165 if (lbm_is_symbol_merror((y))) { \
166 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
167 } \
168 /* continue executing statements below */ \
169 }
170
171#endif
172
173typedef struct {
174 eval_context_t *first;
175 eval_context_t *last;
176} eval_context_queue_t;
177
178#ifdef CLEAN_UP_CLOSURES
179static lbm_value clean_cl_env_symbol = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
180#endif
181
182static int gc(void);
183static void error_ctx(lbm_value);
184static void error_at_ctx(lbm_value err_val, lbm_value at);
185static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx);
186static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail);
187
188// The currently executing context.
189eval_context_t *ctx_running = NULL((void*)0);
190volatile bool_Bool lbm_system_sleeping = false0;
191
192static volatile bool_Bool gc_requested = false0;
193void lbm_request_gc(void) {
194 gc_requested = true1;
195}
196
197/*
198 On ChibiOs the CH_CFG_ST_FREQUENCY setting in chconf.h sets the
199 resolution of the timer used for sleep operations. If this is set
200 to 10KHz the resolution is 100us.
201
202 The CH_CFG_ST_TIMEDELTA specifies the minimum number of ticks that
203 can be safely specified in a timeout directive (wonder if that
204 means sleep-period). The timedelta is set to 2.
205
206 If I have understood these correctly it means that the minimum
207 sleep duration possible is 2 * 100us = 200us.
208*/
209
210#define EVAL_CPS_DEFAULT_STACK_SIZE256 256
211#define EVAL_CPS_MIN_SLEEP200 200
212#define EVAL_STEPS_QUOTA10 10
213
214static volatile uint32_t eval_steps_refill = EVAL_STEPS_QUOTA10;
215static uint32_t eval_steps_quota = EVAL_STEPS_QUOTA10;
216
217void lbm_set_eval_step_quota(uint32_t quota) {
218 eval_steps_refill = quota;
219}
220
221static uint32_t eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
222static volatile uint32_t eval_cps_next_state = EVAL_CPS_STATE_NONE0;
223static volatile uint32_t eval_cps_next_state_arg = 0;
224static volatile bool_Bool eval_cps_state_changed = false0;
225
226static void usleep_nonsense(uint32_t us) {
227 (void) us;
228}
229
230static bool_Bool dynamic_load_nonsense(const char *sym, const char **code) {
231 (void) sym;
232 (void) code;
233 return false0;
234}
235
236static uint32_t timestamp_nonsense(void) {
237 return 0;
238}
239
240static int printf_nonsense(const char *fmt, ...) {
241 (void) fmt;
242 return 0;
243}
244
245static void ctx_done_nonsense(eval_context_t *ctx) {
246 (void) ctx;
247}
248
249static void critical_nonsense(void) {
250 return;
251}
252
253static void (*critical_error_callback)(void) = critical_nonsense;
254static void (*usleep_callback)(uint32_t) = usleep_nonsense;
255static uint32_t (*timestamp_us_callback)(void) = timestamp_nonsense;
256static void (*ctx_done_callback)(eval_context_t *) = ctx_done_nonsense;
257static int (*printf_callback)(const char *, ...) = printf_nonsense;
258static bool_Bool (*dynamic_load_callback)(const char *, const char **) = dynamic_load_nonsense;
259
260void lbm_set_critical_error_callback(void (*fptr)(void)) {
261 if (fptr == NULL((void*)0)) critical_error_callback = critical_nonsense;
262 else critical_error_callback = fptr;
263}
264
265void lbm_set_usleep_callback(void (*fptr)(uint32_t)) {
266 if (fptr == NULL((void*)0)) usleep_callback = usleep_nonsense;
267 else usleep_callback = fptr;
268}
269
270void lbm_set_timestamp_us_callback(uint32_t (*fptr)(void)) {
271 if (fptr == NULL((void*)0)) timestamp_us_callback = timestamp_nonsense;
272 else timestamp_us_callback = fptr;
273}
274
275void lbm_set_ctx_done_callback(void (*fptr)(eval_context_t *)) {
276 if (fptr == NULL((void*)0)) ctx_done_callback = ctx_done_nonsense;
277 else ctx_done_callback = fptr;
278}
279
280void lbm_set_printf_callback(int (*fptr)(const char*, ...)){
281 if (fptr == NULL((void*)0)) printf_callback = printf_nonsense;
282 else printf_callback = fptr;
283}
284
285void lbm_set_dynamic_load_callback(bool_Bool (*fptr)(const char *, const char **)) {
286 if (fptr == NULL((void*)0)) dynamic_load_callback = dynamic_load_nonsense;
287 else dynamic_load_callback = fptr;
288}
289
290static volatile lbm_event_t *lbm_events = NULL((void*)0);
291static unsigned int lbm_events_head = 0;
292static unsigned int lbm_events_tail = 0;
293static unsigned int lbm_events_max = 0;
294static bool_Bool lbm_events_full = false0;
295static mutex_t lbm_events_mutex;
296static bool_Bool lbm_events_mutex_initialized = false0;
297static volatile lbm_cid lbm_event_handler_pid = -1;
298
299lbm_cid lbm_get_event_handler_pid(void) {
300 return lbm_event_handler_pid;
301}
302
303void lbm_set_event_handler_pid(lbm_cid pid) {
304 lbm_event_handler_pid = pid;
305}
306
307bool_Bool lbm_event_handler_exists(void) {
308 return(lbm_event_handler_pid > 0);
309}
310
311
312static bool_Bool event_internal(lbm_event_type_t event_type, lbm_uint parameter, lbm_uint buf_ptr, lbm_uint buf_len) {
313 bool_Bool r = false0;
314 if (lbm_events) {
315 mutex_lock(&lbm_events_mutex);
316 if (!lbm_events_full) {
317 lbm_event_t event;
318 event.type = event_type;
319 event.parameter = parameter;
320 event.buf_ptr = buf_ptr;
321 event.buf_len = buf_len;
322 lbm_events[lbm_events_head] = event;
323 lbm_events_head = (lbm_events_head + 1) % lbm_events_max;
324 lbm_events_full = lbm_events_head == lbm_events_tail;
325 r = true1;
326 }
327 mutex_unlock(&lbm_events_mutex);
328 }
329 return r;
330}
331
332bool_Bool lbm_event_define(lbm_value key, lbm_flat_value_t *fv) {
333 return event_internal(LBM_EVENT_DEFINE, key, (lbm_uint)fv->buf, fv->buf_size);
334}
335
336bool_Bool lbm_event_unboxed(lbm_value unboxed) {
337 lbm_uint t = lbm_type_of(unboxed);
338 if (t == LBM_TYPE_SYMBOL0x00000000u ||
339 t == LBM_TYPE_I0x00000008u ||
340 t == LBM_TYPE_U0x0000000Cu ||
341 t == LBM_TYPE_CHAR0x00000004u) {
342 if (lbm_event_handler_pid > 0) {
343 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)unboxed, 0);
344 }
345 }
346 return false0;
347}
348
349bool_Bool lbm_event(lbm_flat_value_t *fv) {
350 if (lbm_event_handler_pid > 0) {
351 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)fv->buf, fv->buf_size);
352 }
353 return false0;
354}
355
356static bool_Bool lbm_event_pop(lbm_event_t *event) {
357 mutex_lock(&lbm_events_mutex);
358 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
359 mutex_unlock(&lbm_events_mutex);
360 return false0;
361 }
362 *event = lbm_events[lbm_events_tail];
363 lbm_events_tail = (lbm_events_tail + 1) % lbm_events_max;
364 lbm_events_full = false0;
365 mutex_unlock(&lbm_events_mutex);
366 return true1;
367}
368
369bool_Bool lbm_event_queue_is_empty(void) {
370 mutex_lock(&lbm_events_mutex);
371 bool_Bool empty = false0;
372 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
373 empty = true1;
374 }
375 mutex_unlock(&lbm_events_mutex);
376 return empty;
377}
378
379static bool_Bool eval_running = false0;
380static volatile bool_Bool blocking_extension = false0;
381static mutex_t blocking_extension_mutex;
382static bool_Bool blocking_extension_mutex_initialized = false0;
383static lbm_uint blocking_extension_timeout_us = 0;
384static bool_Bool blocking_extension_timeout = false0;
385
386static uint32_t is_atomic = 0;
387
388/* Process queues */
389static eval_context_queue_t blocked = {NULL((void*)0), NULL((void*)0)};
390static eval_context_queue_t queue = {NULL((void*)0), NULL((void*)0)};
391
392/* one mutex for all queue operations */
393mutex_t qmutex;
394bool_Bool qmutex_initialized = false0;
395
396
397// MODES
398static volatile bool_Bool lbm_verbose = false0;
399
400void lbm_toggle_verbose(void) {
401 lbm_verbose = !lbm_verbose;
402}
403
404void lbm_set_verbose(bool_Bool verbose) {
405 lbm_verbose = verbose;
406}
407
408lbm_cid lbm_get_current_cid(void) {
409 if (ctx_running)
410 return ctx_running->id;
411 else
412 return -1;
413}
414
415eval_context_t *lbm_get_current_context(void) {
416 return ctx_running;
417}
418
419/****************************************************/
420/* Utilities used locally in this file */
421
422static lbm_value cons_with_gc(lbm_value head, lbm_value tail, lbm_value remember) {
423#ifdef LBM_ALWAYS_GC
424 lbm_value roots[3] = {head, tail, remember};
425 lbm_gc_mark_roots(roots, 3);
426 gc();
427 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
428 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
429 if (lbm_is_symbol_merror(res)) {
430 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
431 }
432 return res;
433#else
434 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
435 if (lbm_is_symbol_merror(res)) {
436 lbm_value roots[3] = {head, tail, remember};
437 lbm_gc_mark_roots(roots,3);
438 gc();
439 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
440 if (lbm_is_symbol_merror(res)) {
441 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
442 }
443 }
444 return res;
445#endif
446}
447
448static lbm_uint *get_stack_ptr(eval_context_t *ctx, unsigned int n) {
449 if (n <= ctx->K.sp) {
450 lbm_uint index = ctx->K.sp - n;
451 return &ctx->K.data[index];
452 }
453 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
454 return 0; // dead code cannot be reached, but C compiler doesn't realise.
455}
456
457// pop_stack_ptr is safe when no GC is performed and
458// the values of the stack will be dropped.
459static lbm_uint *pop_stack_ptr(eval_context_t *ctx, unsigned int n) {
460 if (n <= ctx->K.sp) {
461 ctx->K.sp -= n;
462 return &ctx->K.data[ctx->K.sp];
463 }
464 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
465 return 0; // dead code cannot be reached, but C compiler doesn't realise.
466}
467
468static inline lbm_uint *stack_reserve(eval_context_t *ctx, unsigned int n) {
469 if (ctx->K.sp + n < ctx->K.size) {
470 lbm_uint *ptr = &ctx->K.data[ctx->K.sp];
471 ctx->K.sp += n;
472 return ptr;
473 }
474 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
475 return 0; // dead code cannot be reached, but C compiler doesn't realise.
476}
477
478static void handle_flash_status(lbm_flash_status s) {
479 if ( s == LBM_FLASH_FULL) {
480 lbm_set_error_reason((char*)lbm_error_str_flash_full);
481 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
482 }
483 if (s == LBM_FLASH_WRITE_ERROR) {
484 lbm_set_error_reason((char*)lbm_error_str_flash_error);
485 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
486 }
487}
488
489static void lift_array_flash(lbm_value flash_cell, bool_Bool bytearray, char *data, lbm_uint num_elt) {
490
491 lbm_array_header_t flash_array_header;
492 flash_array_header.size = num_elt;
493 flash_array_header.data = (lbm_uint*)data;
494 lbm_uint flash_array_header_ptr;
495 handle_flash_status(lbm_write_const_raw((lbm_uint*)&flash_array_header,
496 sizeof(lbm_array_header_t) / sizeof(lbm_uint),
497 &flash_array_header_ptr));
498 handle_flash_status(write_const_car(flash_cell, flash_array_header_ptr));
499 lbm_uint t = bytearray ? ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u) : ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u);
500 handle_flash_status(write_const_cdr(flash_cell, t));
501}
502
503static void get_car_and_cdr(lbm_value a, lbm_value *a_car, lbm_value *a_cdr) {
504 if (lbm_is_ptr(a)) {
3
←
Assuming the condition is false
→
4
←
Taking false branch
→
505 lbm_cons_t *cell = lbm_ref_cell(a);
506 *a_car = cell->car;
507 *a_cdr = cell->cdr;
508 } else if (lbm_is_symbol_nil(a)) {
5
←
Taking false branch
→
509 *a_car = *a_cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
510 } else {
511 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
512 }
513}
6
←
Returning without writing to '*a_car'
→
514
515/* car cdr caar cadr replacements that are evaluator safe. */
516static lbm_value get_car(lbm_value a) {
517 if (lbm_is_ptr(a)) {
518 lbm_cons_t *cell = lbm_ref_cell(a);
519 return cell->car;
520 } else if (lbm_is_symbol_nil(a)) {
521 return a;
522 }
523 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
524 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
525}
526
527static lbm_value get_cdr(lbm_value a) {
528 if (lbm_is_ptr(a)) {
529 lbm_cons_t *cell = lbm_ref_cell(a);
530 return cell->cdr;
531 } else if (lbm_is_symbol_nil(a)) {
532 return a;
533 }
534 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
535 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
536}
537
538static lbm_value get_cadr(lbm_value a) {
539 if (lbm_is_ptr(a)) {
540 lbm_cons_t *cell = lbm_ref_cell(a);
541 lbm_value tmp = cell->cdr;
542 if (lbm_is_ptr(tmp)) {
543 return lbm_ref_cell(tmp)->car;
544 } else if (lbm_is_symbol_nil(tmp)) {
545 return tmp;
546 }
547 } else if (lbm_is_symbol_nil(a)) {
548 return a;
549 }
550 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
551 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
552}
553
554static lbm_value allocate_closure(lbm_value params, lbm_value body, lbm_value env) {
555
556#ifdef LBM_ALWAYS_GC
557 gc();
558 if (lbm_heap_num_free() < 4) {
559 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
560 }
561#else
562 if (lbm_heap_num_free() < 4) {
563 gc();
564 if (lbm_heap_num_free() < 4) {
565 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
566 }
567 }
568#endif
569 // The freelist will always contain just plain heap-cells.
570 // So dec_ptr is sufficient.
571 lbm_value res = lbm_heap_state.freelist;
572 if (lbm_type_of(res) == LBM_TYPE_CONS0x10000000u) {
573 lbm_cons_t *heap = lbm_heap_state.heap;
574 lbm_uint ix = lbm_dec_ptr(res);
575 heap[ix].car = ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u);
576 ix = lbm_dec_ptr(heap[ix].cdr);
577 heap[ix].car = params;
578 ix = lbm_dec_ptr(heap[ix].cdr);
579 heap[ix].car = body;
580 ix = lbm_dec_ptr(heap[ix].cdr);
581 heap[ix].car = env;
582 lbm_heap_state.freelist = heap[ix].cdr;
583 heap[ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
584 lbm_heap_state.num_alloc+=4;
585 } else {
586 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
587 }
588 return res;
589}
590
591// Allocate a binding and attach it to a list (if so desired)
592static lbm_value allocate_binding(lbm_value key, lbm_value val, lbm_value the_cdr) {
593 if (lbm_heap_num_free() < 2) {
594 gc();
595 if (lbm_heap_num_free() < 2) {
596 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
597 }
598 }
599 lbm_cons_t* heap = lbm_heap_state.heap;
600 lbm_value binding_cell = lbm_heap_state.freelist;
601 lbm_uint binding_cell_ix = lbm_dec_ptr(binding_cell);
602 lbm_value list_cell = heap[binding_cell_ix].cdr;
603 lbm_uint list_cell_ix = lbm_dec_ptr(list_cell);
604 lbm_heap_state.freelist = heap[list_cell_ix].cdr;
605 lbm_heap_state.num_alloc += 2;
606 heap[binding_cell_ix].car = key;
607 heap[binding_cell_ix].cdr = val;
608 heap[list_cell_ix].car = binding_cell;
609 heap[list_cell_ix].cdr = the_cdr;
610 return list_cell;
611}
612
613#define CLO_PARAMS0 0
614#define CLO_BODY1 1
615#define CLO_ENV2 2
616#define LOOP_BINDS0 0
617#define LOOP_COND1 1
618#define LOOP_BODY2 2
619
620// (a b c) -> [a b c]
621static lbm_value extract_n(lbm_value curr, lbm_value *res, unsigned int n) {
622 for (unsigned int i = 0; i < n; i ++) {
623 if (lbm_is_ptr(curr)) {
624 lbm_cons_t *cell = lbm_ref_cell(curr);
625 res[i] = cell->car;
626 curr = cell->cdr;
627 } else {
628 res[i] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
629 }
630 }
631 return curr; // Rest of list is returned here.
632}
633
634static void call_fundamental(lbm_uint fundamental, lbm_value *args, lbm_uint arg_count, eval_context_t *ctx) {
635 lbm_value res;
636 res = fundamental_table[fundamental](args, arg_count, ctx);
637 if (lbm_is_error(res)) {
638 if (lbm_is_symbol_merror(res)) {
639 gc();
640 res = fundamental_table[fundamental](args, arg_count, ctx);
641 }
642 if (lbm_is_error(res)) {
643 error_at_ctx(res, lbm_enc_sym(FUNDAMENTAL_SYMBOLS_START0x20000 | fundamental));
644 }
645 }
646 lbm_stack_drop(&ctx->K, arg_count+1);
647 ctx->app_cont = true1;
648 ctx->r = res;
649}
650
651// block_current_ctx blocks a context until it is
652// woken up externally or a timeout period of time passes.
653static void block_current_ctx(uint32_t state, lbm_uint sleep_us, bool_Bool do_cont) {
654 ctx_running->timestamp = timestamp_us_callback();
655 ctx_running->sleep_us = sleep_us;
656 ctx_running->state = state;
657 ctx_running->app_cont = do_cont;
658 enqueue_ctx(&blocked, ctx_running);
659 ctx_running = NULL((void*)0);
660}
661
662lbm_flash_status lbm_write_const_array_padded(uint8_t *data, lbm_uint n, lbm_uint *res) {
663 lbm_uint full_words = n / sizeof(lbm_uint);
664 lbm_uint n_mod = n % sizeof(lbm_uint);
665
666 if (n_mod == 0) { // perfect fit.
667 return lbm_write_const_raw((lbm_uint*)data, full_words, res);
668 } else {
669 lbm_uint last_word = 0;
670 memcpy(&last_word, &data[full_words * sizeof(lbm_uint)], n_mod);
671 if (full_words >= 1) {
672 lbm_flash_status s = lbm_write_const_raw((lbm_uint*)data, full_words, res);
673 if ( s == LBM_FLASH_WRITE_OK) {
674 lbm_uint dummy;
675 s = lbm_write_const_raw(&last_word, 1, &dummy);
676 }
677 return s;
678 } else {
679 return lbm_write_const_raw(&last_word, 1, res);
680 }
681 }
682}
683
684/****************************************************/
685/* Error message creation */
686
687#define ERROR_MESSAGE_BUFFER_SIZE_BYTES256 256
688
689void print_environments(char *buf, unsigned int size) {
690
691 lbm_value curr_l = ctx_running->curr_env;
692 printf_callback("\tCurrent local environment:\n");
693 while (lbm_type_of(curr_l) == LBM_TYPE_CONS0x10000000u) {
694 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_l));
695 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_l)));
696 printf_callback("\t%s = %s\n", buf, buf+(size/2));
697 curr_l = lbm_cdr(curr_l);
698 }
699 printf_callback("\n\n");
700 printf_callback("\tCurrent global environment:\n");
701 lbm_value *glob_env = lbm_get_global_env();
702
703 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
704 lbm_value curr_g = glob_env[i];;
705 while (lbm_type_of(curr_g) == LBM_TYPE_CONS0x10000000u) {
706
707 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_g));
708 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_g)));
709 printf_callback("\t%s = %s\n", buf, buf+(size/2));
710 curr_g = lbm_cdr(curr_g);
711 }
712 }
713}
714
715void print_error_message(lbm_value error, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int col, lbm_int row0, lbm_int row1) {
716 if (!printf_callback) return;
717
718 /* try to allocate a lbm_print_value buffer on the lbm_memory */
719 char *buf = lbm_malloc_reserve(ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
720 if (!buf) {
721 printf_callback("Error: Not enough free memory to create a human readable error message\n");
722 return;
723 }
724
725 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, error);
726 printf_callback( "*** Error: %s\n", buf);
727 if (has_at) {
728 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, at);
729 printf_callback("*** In: %s\n",buf);
730 if (lbm_error_has_suspect) {
731 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, lbm_error_suspect);
732 lbm_error_has_suspect = false0;
733 printf_callback("*** At: %s\n", buf);
734 } else {
735 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
736 printf_callback("*** After: %s\n",buf);
737 }
738 } else {
739 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
740 printf_callback("*** Near: %s\n",buf);
741 }
742
743 printf_callback("\n");
744
745 if (lbm_is_symbol(error) &&
746 error == ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u)) {
747 printf_callback("*** Line: %u\n", row);
748 printf_callback("*** Column: %u\n", col);
749 } else if (row0 != -1 || row1 != -1 ) {
750 printf_callback("*** Between rows: (-1 unknown) \n");
751 printf_callback("*** Start: %d\n", (int32_t)row0);
752 printf_callback("*** End: %d\n", (int32_t)row1);
753 }
754
755 printf_callback("\n");
756
757 if (ctx_running->error_reason) {
758 printf_callback("Reason:\n %s\n\n", ctx_running->error_reason);
759 }
760 if (lbm_verbose) {
761 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
762 printf_callback(" In context: %d\n", ctx_running->id);
763 printf_callback(" Current intermediate result: %s\n\n", buf);
764
765 print_environments(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
766 printf_callback("\n\n");
767
768 printf_callback(" Stack:\n");
769 for (unsigned int i = 0; i < ctx_running->K.sp; i ++) {
770 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->K.data[i]);
771 printf_callback(" %s\n", buf);
772 }
773 }
774 lbm_free(buf);
775}
776
777/****************************************************/
778/* Tokenizing and parsing */
779
780bool_Bool create_string_channel(char *str, lbm_value *res) {
781
782 lbm_char_channel_t *chan = NULL((void*)0);
783 lbm_string_channel_state_t *st = NULL((void*)0);
784
785 st = (lbm_string_channel_state_t*)lbm_memory_allocate(sizeof(lbm_string_channel_state_t) / sizeof(lbm_uint) +1);
786 if (st == NULL((void*)0)) {
787 return false0;
788 }
789 chan = (lbm_char_channel_t*)lbm_memory_allocate(sizeof(lbm_char_channel_t) / sizeof(lbm_uint) + 1);
790 if (chan == NULL((void*)0)) {
791 lbm_memory_free((lbm_uint*)st);
792 return false0;
793 }
794
795 lbm_create_string_char_channel(st, chan, str);
796 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
797 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
798 lbm_memory_free((lbm_uint*)st);
799 lbm_memory_free((lbm_uint*)chan);
800 return false0;
801 }
802
803 *res = cell;
804 return true1;
805}
806
807bool_Bool lift_char_channel(lbm_char_channel_t *chan , lbm_value *res) {
808 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
809 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
810 return false0;
811 }
812 *res = cell;
813 return true1;
814}
815
816
817/****************************************************/
818/* Queue functions */
819
820static void queue_iterator_nm(eval_context_queue_t *q, ctx_fun f, void *arg1, void *arg2) {
821 eval_context_t *curr;
822 curr = q->first;
823
824 while (curr != NULL((void*)0)) {
825 f(curr, arg1, arg2);
826 curr = curr->next;
827 }
828}
829
830void lbm_running_iterator(ctx_fun f, void *arg1, void *arg2){
831 mutex_lock(&qmutex);
832 queue_iterator_nm(&queue, f, arg1, arg2);
833 mutex_unlock(&qmutex);
834}
835
836void lbm_blocked_iterator(ctx_fun f, void *arg1, void *arg2){
837 mutex_lock(&qmutex);
838 queue_iterator_nm(&blocked, f, arg1, arg2);
839 mutex_unlock(&qmutex);
840}
841
842static void enqueue_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
843 if (q->last == NULL((void*)0)) {
844 ctx->prev = NULL((void*)0);
845 ctx->next = NULL((void*)0);
846 q->first = ctx;
847 q->last = ctx;
848 } else {
849 ctx->prev = q->last;
850 ctx->next = NULL((void*)0);
851 q->last->next = ctx;
852 q->last = ctx;
853 }
854}
855
856static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx) {
857 mutex_lock(&qmutex);
858 enqueue_ctx_nm(q,ctx);
859 mutex_unlock(&qmutex);
860}
861
862static eval_context_t *lookup_ctx_nm(eval_context_queue_t *q, lbm_cid cid) {
863 eval_context_t *curr;
864 curr = q->first;
865 while (curr != NULL((void*)0)) {
866 if (curr->id == cid) {
867 return curr;
868 }
869 curr = curr->next;
870 }
871 return NULL((void*)0);
872}
873
874static bool_Bool drop_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
875
876 bool_Bool res = false0;
877 if (q->first == NULL((void*)0) || q->last == NULL((void*)0)) {
878 if (!(q->last == NULL((void*)0) && q->first == NULL((void*)0))) {
879 /* error state that should not happen */
880 return res;
881 }
882 /* Queue is empty */
883 return res;
884 }
885
886 eval_context_t *curr = q->first;
887 while (curr) {
888 if (curr->id == ctx->id) {
889 res = true1;
890 eval_context_t *tmp = curr->next;
891 if (curr->prev == NULL((void*)0)) {
892 if (curr->next == NULL((void*)0)) {
893 q->last = NULL((void*)0);
894 q->first = NULL((void*)0);
895 } else {
896 q->first = tmp;
897 tmp->prev = NULL((void*)0);
898 }
899 } else { /* curr->prev != NULL */
900 if (curr->next == NULL((void*)0)) {
901 q->last = curr->prev;
902 q->last->next = NULL((void*)0);
903 } else {
904 curr->prev->next = tmp;
905 tmp->prev = curr->prev;
906 }
907 }
908 break;
909 }
910 curr = curr->next;
911 }
912 return res;
913}
914
915/* End execution of the running context. */
916static void finish_ctx(void) {
917
918 if (!ctx_running) {
919 return;
920 }
921 /* Drop the continuation stack immediately to free up lbm_memory */
922 lbm_stack_free(&ctx_running->K);
923 ctx_done_callback(ctx_running);
924 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->name)) {
925 lbm_free(ctx_running->name);
926 }
927 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->error_reason)) {
928 lbm_memory_free((lbm_uint*)ctx_running->error_reason);
929 }
930 lbm_memory_free((lbm_uint*)ctx_running->mailbox);
931 lbm_memory_free((lbm_uint*)ctx_running);
932 ctx_running = NULL((void*)0);
933}
934
935static void context_exists(eval_context_t *ctx, void *cid, void *b) {
936 if (ctx->id == *(lbm_cid*)cid) {
937 *(bool_Bool*)b = true1;
938 }
939}
940
941bool_Bool lbm_wait_ctx(lbm_cid cid, lbm_uint timeout_ms) {
942
943 bool_Bool exists;
944 uint32_t i = 0;
945
946 do {
947 exists = false0;
948 lbm_blocked_iterator(context_exists, &cid, &exists);
949 lbm_running_iterator(context_exists, &cid, &exists);
950
951 if (ctx_running &&
952 ctx_running->id == cid) {
953 exists = true1;
954 }
955
956 if (exists) {
957 if (usleep_callback) {
958 usleep_callback(1000);
959 }
960 if (timeout_ms > 0) i ++;
961 }
962 } while (exists && i < timeout_ms);
963
964 if (exists) return false0;
965 return true1;
966}
967
968void lbm_set_error_suspect(lbm_value suspect) {
969 lbm_error_suspect = suspect;
970 lbm_error_has_suspect = true1;
971}
972
973void lbm_set_error_reason(char *error_str) {
974 if (ctx_running != NULL((void*)0)) {
975 ctx_running->error_reason = error_str;
976 }
977}
978
979// Not possible to CONS_WITH_GC in error_ctx_base (potential loop)
980static void error_ctx_base(lbm_value err_val, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int column) {
981
982 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
983 if (lbm_heap_num_free() < 3) {
984 gc();
985 }
986
987 if (lbm_heap_num_free() >= 3) {
988 lbm_value msg = lbm_cons(err_val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
989 msg = lbm_cons(lbm_enc_i(ctx_running->id), msg);
990 msg = lbm_cons(ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u), msg);
991 if (!lbm_is_symbol_merror(msg)) {
992 lbm_find_receiver_and_send(ctx_running->parent, msg);
993 goto error_ctx_base_done;
994 }
995 }
996 }
997 if ((ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10) &&
998 (err_val != ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u))) {
999 lbm_uint v;
1000 while (ctx_running->K.sp > 0) {
1001 lbm_pop(&ctx_running->K, &v);
1002 if (v == EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u)) {
1003 lbm_value *sptr = get_stack_ptr(ctx_running, 2);
1004 lbm_set_car(sptr[0], ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
1005 stack_reserve(ctx_running, 1)[0] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1006 ctx_running->app_cont = true1;
1007 ctx_running->r = err_val;
1008 longjmp(error_jmp_buf, 1);
1009 }
1010 }
1011 err_val = ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u);
1012 }
1013 print_error_message(err_val,
1014 has_at,
1015 at,
1016 row,
1017 column,
1018 ctx_running->row0,
1019 ctx_running->row1);
1020 error_ctx_base_done:
1021 ctx_running->r = err_val;
1022 finish_ctx();
1023 longjmp(error_jmp_buf, 1);
1024}
1025
1026static void error_at_ctx(lbm_value err_val, lbm_value at) {
1027 error_ctx_base(err_val, true1, at, 0, 0);
1028}
1029
1030static void error_ctx(lbm_value err_val) {
1031 error_ctx_base(err_val, false0, 0, 0, 0);
1032}
1033
1034static void read_error_ctx(unsigned int row, unsigned int column) {
1035 error_ctx_base(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u), false0, 0, row, column);
1036}
1037
1038void lbm_critical_error(void) {
1039 longjmp(critical_error_jmp_buf, 1);
1040}
1041
1042// successfully finish a context
1043static void ok_ctx(void) {
1044 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
1045 lbm_value msg;
1046 WITH_GC(msg, lbm_heap_allocate_list_init(3,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1047 ENC_SYM_EXIT_OK,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1048 lbm_enc_i(ctx_running->id),(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1049 ctx_running->r))(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
1050 lbm_find_receiver_and_send(ctx_running->parent, msg);
1051 }
1052 finish_ctx();
1053}
1054
1055static eval_context_t *dequeue_ctx_nm(eval_context_queue_t *q) {
1056 if (q->last == NULL((void*)0)) {
1057 return NULL((void*)0);
1058 }
1059 // q->first should only be NULL if q->last is.
1060 eval_context_t *res = q->first;
1061
1062 if (q->first == q->last) { // One thing in queue
1063 q->first = NULL((void*)0);
1064 q->last = NULL((void*)0);
1065 } else {
1066 q->first = q->first->next;
1067 q->first->prev = NULL((void*)0);
1068 }
1069 res->prev = NULL((void*)0);
1070 res->next = NULL((void*)0);
1071 return res;
1072}
1073
1074static void wake_up_ctxs_nm(void) {
1075 lbm_uint t_now;
1076
1077 if (timestamp_us_callback) {
1078 t_now = timestamp_us_callback();
1079 } else {
1080 t_now = 0;
1081 }
1082
1083 eval_context_queue_t *q = &blocked;
1084 eval_context_t *curr = q->first;
1085
1086 while (curr != NULL((void*)0)) {
1087 lbm_uint t_diff;
1088 eval_context_t *next = curr->next;
1089 if (curr->state != LBM_THREAD_STATE_BLOCKED(uint32_t)1) {
1090 if ( curr->timestamp > t_now) {
1091 /* There was an overflow on the counter */
1092#ifndef LBM64
1093 t_diff = (0xFFFFFFFF - curr->timestamp) + t_now;
1094#else
1095 t_diff = (0xFFFFFFFFFFFFFFFF - curr->timestamp) + t_now;
1096#endif
1097 } else {
1098 t_diff = t_now - curr->timestamp;
1099 }
1100
1101 if (t_diff >= curr->sleep_us) {
1102 eval_context_t *wake_ctx = curr;
1103 if (curr == q->last) {
1104 if (curr->prev) {
1105 q->last = curr->prev;
1106 q->last->next = NULL((void*)0);
1107 } else {
1108 q->first = NULL((void*)0);
1109 q->last = NULL((void*)0);
1110 }
1111 } else if (curr->prev == NULL((void*)0)) {
1112 q->first = curr->next;
1113 q->first->prev = NULL((void*)0);
1114 } else {
1115 curr->prev->next = curr->next;
1116 if (curr->next) {
1117 curr->next->prev = curr->prev;
1118 }
1119 }
1120 wake_ctx->next = NULL((void*)0);
1121 wake_ctx->prev = NULL((void*)0);
1122 if (curr->state == LBM_THREAD_STATE_TIMEOUT(uint32_t)2) {
1123 mailbox_add_mail(wake_ctx, ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u));
1124 wake_ctx->r = ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u);
1125 }
1126 wake_ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1127 enqueue_ctx_nm(&queue, wake_ctx);
1128 }
1129 }
1130 curr = next;
1131 }
1132}
1133
1134static void yield_ctx(lbm_uint sleep_us) {
1135 if (timestamp_us_callback) {
1136 ctx_running->timestamp = timestamp_us_callback();
1137 ctx_running->sleep_us = sleep_us;
1138 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1139 } else {
1140 ctx_running->timestamp = 0;
1141 ctx_running->sleep_us = 0;
1142 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1143 }
1144 ctx_running->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1145 ctx_running->app_cont = true1;
1146 enqueue_ctx(&blocked,ctx_running);
1147 ctx_running = NULL((void*)0);
1148}
1149
1150static lbm_cid lbm_create_ctx_parent(lbm_value program, lbm_value env, lbm_uint stack_size, lbm_cid parent, uint32_t context_flags, char *name) {
1151
1152 if (!lbm_is_cons(program)) return -1;
1153
1154 eval_context_t *ctx = NULL((void*)0);
1155
1156 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1157 if (ctx == NULL((void*)0)) {
1158 lbm_uint roots[2] = {program, env};
1159 lbm_gc_mark_roots(roots, 2);
1160 gc();
1161 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1162 }
1163 if (ctx == NULL((void*)0)) return -1;
1164
1165 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1166 lbm_uint roots[2] = {program, env};
1167 lbm_gc_mark_roots(roots, 2);
1168 gc();
1169 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1170 lbm_memory_free((lbm_uint*)ctx);
1171 return -1;
1172 }
1173 }
1174
1175 lbm_value *mailbox = NULL((void*)0);
1176 mailbox = (lbm_value*)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1177 if (mailbox == NULL((void*)0)) {
1178 lbm_value roots[2] = {program, env};
1179 lbm_gc_mark_roots(roots,2);
1180 gc();
1181 mailbox = (lbm_value *)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1182 }
1183 if (mailbox == NULL((void*)0)) {
1184 lbm_stack_free(&ctx->K);
1185 lbm_memory_free((lbm_uint*)ctx);
1186 return -1;
1187 }
1188
1189 // TODO: Limit names to 19 chars + 1 char for 0? (or something similar).
1190 if (name) {
1191 lbm_uint name_len = strlen(name) + 1;
1192 ctx->name = lbm_malloc(strlen(name) + 1);
1193 if (ctx->name == NULL((void*)0)) {
1194 lbm_value roots[2] = {program, env};
1195 lbm_gc_mark_roots(roots, 2);
1196 gc();
1197 ctx->name = lbm_malloc(strlen(name) + 1);
1198 }
1199 if (ctx->name == NULL((void*)0)) {
1200 lbm_stack_free(&ctx->K);
1201 lbm_memory_free((lbm_uint*)mailbox);
1202 lbm_memory_free((lbm_uint*)ctx);
1203 return -1;
1204 }
1205 memcpy(ctx->name, name, name_len+1);
1206 } else {
1207 ctx->name = NULL((void*)0);
1208 }
1209
1210 lbm_int cid = lbm_memory_address_to_ix((lbm_uint*)ctx);
1211
1212 ctx->program = lbm_cdr(program);
1213 ctx->curr_exp = lbm_car(program);
1214 ctx->curr_env = env;
1215 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1216 ctx->error_reason = NULL((void*)0);
1217 ctx->mailbox = mailbox;
1218 ctx->mailbox_size = EVAL_CPS_DEFAULT_MAILBOX_SIZE10;
1219 ctx->flags = context_flags;
1220 ctx->num_mail = 0;
1221 ctx->app_cont = false0;
1222 ctx->timestamp = 0;
1223 ctx->sleep_us = 0;
1224 ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1225 ctx->prev = NULL((void*)0);
1226 ctx->next = NULL((void*)0);
1227
1228 ctx->row0 = -1;
1229 ctx->row1 = -1;
1230
1231 ctx->id = cid;
1232 ctx->parent = parent;
1233
1234 if (!lbm_push(&ctx->K, DONE(((0) << 2) | 0xF8000001u))) {
1235 lbm_memory_free((lbm_uint*)ctx->mailbox);
1236 lbm_stack_free(&ctx->K);
1237 lbm_memory_free((lbm_uint*)ctx);
1238 return -1;
1239 }
1240
1241 enqueue_ctx(&queue,ctx);
1242
1243 return ctx->id;
1244}
1245
1246lbm_cid lbm_create_ctx(lbm_value program, lbm_value env, lbm_uint stack_size, char *name) {
1247 // Creates a parentless context.
1248 return lbm_create_ctx_parent(program,
1249 env,
1250 stack_size,
1251 -1,
1252 EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00,
1253 name);
1254}
1255
1256bool_Bool lbm_mailbox_change_size(eval_context_t *ctx, lbm_uint new_size) {
1257
1258 lbm_value *mailbox = NULL((void*)0);
1259 mailbox = (lbm_value*)lbm_memory_allocate(new_size);
1260 if (mailbox == NULL((void*)0)) {
1261 gc();
1262 mailbox = (lbm_value *)lbm_memory_allocate(new_size);
1263 }
1264 if (mailbox == NULL((void*)0)) {
1265 return false0;
1266 }
1267
1268 for (lbm_uint i = 0; i < ctx->num_mail; i ++ ) {
1269 mailbox[i] = ctx->mailbox[i];
1270 }
1271 lbm_memory_free(ctx->mailbox);
1272 ctx->mailbox = mailbox;
1273 ctx->mailbox_size = (uint32_t)new_size;
1274 return true1;
1275}
1276
1277static void mailbox_remove_mail(eval_context_t *ctx, lbm_uint ix) {
1278
1279 for (lbm_uint i = ix; i < ctx->num_mail-1; i ++) {
1280 ctx->mailbox[i] = ctx->mailbox[i+1];
1281 }
1282 ctx->num_mail --;
1283}
1284
1285static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail) {
1286
1287 if (ctx->num_mail >= ctx->mailbox_size) {
1288 mailbox_remove_mail(ctx, 0);
1289 }
1290
1291 ctx->mailbox[ctx->num_mail] = mail;
1292 ctx->num_mail ++;
1293 return true1;
1294}
1295
1296/* Advance execution to the next expression in the program */
1297static void advance_ctx(eval_context_t *ctx) {
1298 if (lbm_is_cons(ctx->program)) {
1299 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);;
1300 get_car_and_cdr(ctx->program, &ctx->curr_exp, &ctx->program);
1301 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1302 } else {
1303 if (ctx_running == ctx) { // This should always be the case because of odd historical reasons.
1304 ok_ctx();
1305 }
1306 }
1307}
1308
1309bool_Bool lbm_unblock_ctx(lbm_cid cid, lbm_flat_value_t *fv) {
1310 return event_internal(LBM_EVENT_UNBLOCK_CTX, (lbm_uint)cid, (lbm_uint)fv->buf, fv->buf_size);
1311}
1312
1313bool_Bool lbm_unblock_ctx_r(lbm_cid cid) {
1314 mutex_lock(&blocking_extension_mutex);
1315 bool_Bool r = false0;
1316 eval_context_t *found = NULL((void*)0);
1317 mutex_lock(&qmutex);
1318 found = lookup_ctx_nm(&blocked, cid);
1319 if (found) {
1320 drop_ctx_nm(&blocked,found);
1321 enqueue_ctx_nm(&queue,found);
1322 r = true1;
1323 }
1324 mutex_unlock(&qmutex);
1325 mutex_unlock(&blocking_extension_mutex);
1326 return r;
1327}
1328
1329// unblock unboxed is also safe for rmbr:ed things.
1330bool_Bool lbm_unblock_ctx_unboxed(lbm_cid cid, lbm_value unboxed) {
1331 mutex_lock(&blocking_extension_mutex);
1332 bool_Bool r = false0;
1333 eval_context_t *found = NULL((void*)0);
1334 mutex_lock(&qmutex);
1335 found = lookup_ctx_nm(&blocked, cid);
1336 if (found) {
1337 drop_ctx_nm(&blocked,found);
1338 found->r = unboxed;
1339 if (lbm_is_error(unboxed)) {
1340 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
1341 found->app_cont = true1;
1342 }
1343 enqueue_ctx_nm(&queue,found);
1344 r = true1;
1345 }
1346 mutex_unlock(&qmutex);
1347 mutex_unlock(&blocking_extension_mutex);
1348 return r;
1349}
1350
1351static bool_Bool lbm_block_ctx_base(bool_Bool timeout, float t_s) {
1352 mutex_lock(&blocking_extension_mutex);
1353 blocking_extension = true1;
1354 if (timeout) {
1355 blocking_extension_timeout_us = S_TO_US(t_s)(lbm_uint)((t_s) * 1000000);
1356 blocking_extension_timeout = true1;
1357 } else {
1358 blocking_extension_timeout = false0;
1359 }
1360 return true1;
1361}
1362
1363void lbm_block_ctx_from_extension_timeout(float s) {
1364 lbm_block_ctx_base(true1, s);
1365}
1366
1367void lbm_block_ctx_from_extension(void) {
1368 lbm_block_ctx_base(false0, 0);
1369}
1370
1371// todo: May need to pop rmbrs from stack, if present.
1372// Suspect that the letting the discard cont run is really not a problem.
1373// Either way will be quite confusing what happens to allocated things when undoing block.
1374void lbm_undo_block_ctx_from_extension(void) {
1375 blocking_extension = false0;
1376 blocking_extension_timeout_us = 0;
1377 blocking_extension_timeout = false0;
1378 mutex_unlock(&blocking_extension_mutex);
1379}
1380
1381lbm_value lbm_find_receiver_and_send(lbm_cid cid, lbm_value msg) {
1382 mutex_lock(&qmutex);
1383 eval_context_t *found = NULL((void*)0);
1384 bool_Bool found_blocked = false0;
1385
1386 found = lookup_ctx_nm(&blocked, cid);
1387 if (found) found_blocked = true1;
1388
1389 if (found == NULL((void*)0)) {
1390 found = lookup_ctx_nm(&queue, cid);
1391 }
1392
1393 if (found) {
1394 if (!mailbox_add_mail(found, msg)) {
1395 mutex_unlock(&qmutex);
1396 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1397 }
1398
1399 if (found_blocked){
1400 drop_ctx_nm(&blocked,found);
1401 enqueue_ctx_nm(&queue,found);
1402 }
1403 mutex_unlock(&qmutex);
1404 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1405 }
1406
1407 /* check the current context */
1408 if (ctx_running && ctx_running->id == cid) {
1409 if (!mailbox_add_mail(ctx_running, msg)) {
1410 mutex_unlock(&qmutex);
1411 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1412 }
1413 mutex_unlock(&qmutex);
1414 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1415 }
1416 mutex_unlock(&qmutex);
1417 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1418}
1419
1420/* Pattern matching is currently implemented as a recursive
1421 function and make use of stack relative to the size of
1422 expressions that are being matched. */
1423static bool_Bool match(lbm_value p, lbm_value e, lbm_value *env, bool_Bool *gc) {
1424
1425 lbm_value binding;
1426
1427 if (lbm_is_match_binder(p)) {
1428 lbm_value var = get_cadr(p);
1429 lbm_value bindertype = get_car(p);
1430
1431 if (!lbm_is_symbol(var)) return false0;
1432
1433 switch (bindertype) {
1434 case ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u):
1435 if ( var == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) {
1436 return true1;
1437 }
1438 break;
1439 default: /* this should be an error case */
1440 return false0;
1441 }
1442 binding = lbm_cons(var, e);
1443 if ( lbm_type_of(binding) == LBM_TYPE_SYMBOL0x00000000u ) {
1444 *gc = true1;
1445 return false0;
1446 }
1447 *env = lbm_cons(binding, *env);
1448 if ( lbm_type_of(*env) == LBM_TYPE_SYMBOL0x00000000u ) {
1449 *gc = true1;
1450 return false0;
1451 }
1452 return true1;
1453 }
1454
1455 if (lbm_is_symbol(p)) {
1456 if (p == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return true1;
1457 return (p == e);
1458 }
1459 if (lbm_is_cons(p) &&
1460 lbm_is_cons(e) ) {
1461
1462 lbm_value headp, tailp;
1463 lbm_value heade, taile;
1464 get_car_and_cdr(p, &headp, &tailp);
1465 get_car_and_cdr(e, &heade, &taile); // Static analysis warns, but execution does not
1466 // past this point unless head and tail get initialized.
1467 if (!match(headp, heade, env, gc)) {
1468 return false0;
1469 }
1470 return match (tailp, taile, env, gc);
1471 }
1472 return struct_eq(p, e);
1473}
1474
1475// Find match is not very picky about syntax.
1476// A completely malformed recv form is most likely to
1477// just return no_match.
1478static int find_match(lbm_value plist, lbm_value *earr, lbm_uint num, lbm_value *e, lbm_value *env) {
1479
1480 // A pattern list is a list of pattern, expression lists.
1481 // ( (p1 e1) (p2 e2) ... (pn en))
1482 lbm_value curr_p = plist;
1483 int n = 0;
1484 bool_Bool gc = false0;
1485 for (int i = 0; i < (int)num; i ++ ) {
1486 lbm_value curr_e = earr[i];
1487 while (!lbm_is_symbol_nil(curr_p)) {
1488 lbm_value me = get_car(curr_p);
1489 if (match(get_car(me), curr_e, env, &gc)) {
1490 if (gc) return FM_NEED_GC-1;
1491 *e = get_cadr(me);
1492
1493 if (!lbm_is_symbol_nil(get_cadr(get_cdr(me)))) {
1494 return FM_PATTERN_ERROR-3;
1495 }
1496 return n;
1497 }
1498 curr_p = get_cdr(curr_p);
1499 }
1500 curr_p = plist; /* search all patterns against next exp */
1501 n ++;
1502 }
1503
1504 return FM_NO_MATCH-2;
1505}
1506
1507/****************************************************/
1508/* Garbage collection */
1509
1510static void mark_context(eval_context_t *ctx, void *arg1, void *arg2) {
1511 (void) arg1;
1512 (void) arg2;
1513 lbm_value roots[3] = {ctx->curr_exp, ctx->program, ctx->r };
1514 lbm_gc_mark_env(ctx->curr_env);
1515 lbm_gc_mark_roots(roots, 3);
1516 lbm_gc_mark_roots(ctx->mailbox, ctx->num_mail);
1517 lbm_gc_mark_aux(ctx->K.data, ctx->K.sp);
1518}
1519
1520static int gc(void) {
1521 if (ctx_running) {
1522 ctx_running->state = ctx_running->state | LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1523 }
1524
1525 gc_requested = false0;
1526 lbm_gc_state_inc();
1527
1528 // The freelist should generally be NIL when GC runs.
1529 lbm_nil_freelist();
1530 lbm_value *env = lbm_get_global_env();
1531 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
1532 lbm_gc_mark_env(env[i]);
1533 }
1534
1535 mutex_lock(&qmutex); // Lock the queues.
1536 // Any concurrent messing with the queues
1537 // while doing GC cannot possibly be good.
1538 queue_iterator_nm(&queue, mark_context, NULL((void*)0), NULL((void*)0));
1539 queue_iterator_nm(&blocked, mark_context, NULL((void*)0), NULL((void*)0));
1540
1541 if (ctx_running) {
1542 mark_context(ctx_running, NULL((void*)0), NULL((void*)0));
1543 }
1544 mutex_unlock(&qmutex);
1545
1546#ifdef VISUALIZE_HEAP
1547 heap_vis_gen_image();
1548#endif
1549
1550 int r = lbm_gc_sweep_phase();
1551 lbm_heap_new_freelist_length();
1552
1553 if (ctx_running) {
1554 ctx_running->state = ctx_running->state & ~LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1555 }
1556 return r;
1557}
1558
1559int lbm_perform_gc(void) {
1560 return gc();
1561}
1562
1563/****************************************************/
1564/* Evaluation functions */
1565
1566
1567static void eval_symbol(eval_context_t *ctx) {
1568 lbm_uint s = lbm_dec_sym(ctx->curr_exp);
1569 if (s >= RUNTIME_SYMBOLS_START0x40000) {
1570 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1571 if (lbm_env_lookup_b(&res, ctx->curr_exp, ctx->curr_env) ||
1572 lbm_global_env_lookup(&res, ctx->curr_exp)) {
1573 ctx->r = res;
1574 ctx->app_cont = true1;
1575 return;
1576 }
1577 // Dynamic load attempt
1578 // Only symbols of kind RUNTIME can be dynamically loaded.
1579 const char *sym_str = lbm_get_name_by_symbol(s);
1580 const char *code_str = NULL((void*)0);
1581 if (!dynamic_load_callback(sym_str, &code_str)) {
1582 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), ctx->curr_exp);
1583 }
1584 lbm_value *sptr = stack_reserve(ctx, 3);
1585 sptr[0] = ctx->curr_exp;
1586 sptr[1] = ctx->curr_env;
1587 sptr[2] = RESUME(((12) << 2) | 0xF8000001u);
1588
1589 lbm_value chan;
1590 if (!create_string_channel((char *)code_str, &chan)) {
1591 gc();
1592 if (!create_string_channel((char *)code_str, &chan)) {
1593 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1594 }
1595 }
1596
1597 lbm_value loader;
1598 WITH_GC_RMBR_1(loader, lbm_heap_allocate_list_init(2,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1599 ENC_SYM_READ,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1600 chan), chan)(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} };
1601 lbm_value evaluator;
1602 WITH_GC_RMBR_1(evaluator, lbm_heap_allocate_list_init(2,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1603 ENC_SYM_EVAL,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1604 loader), loader)(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } };
1605 ctx->curr_exp = evaluator;
1606 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // dynamics should be evaluable in empty local env
1607 } else {
1608 //special symbols and extensions can be handled the same way.
1609 ctx->r = ctx->curr_exp;
1610 ctx->app_cont = true1;
1611 }
1612}
1613
1614static void eval_quote(eval_context_t *ctx) {
1615 ctx->r = get_cadr(ctx->curr_exp);
1616 ctx->app_cont = true1;
1617}
1618
1619static void eval_selfevaluating(eval_context_t *ctx) {
1620 ctx->r = ctx->curr_exp;
1621 ctx->app_cont = true1;
1622}
1623
1624static void eval_progn(eval_context_t *ctx) {
1625 lbm_value exps = get_cdr(ctx->curr_exp);
1626
1627 if (lbm_is_cons(exps)) {
1628 lbm_uint *sptr = stack_reserve(ctx, 4);
1629 sptr[0] = ctx->curr_env; // env to restore between expressions in progn
1630 sptr[1] = lbm_enc_u(0); // Has env been copied (needed for progn local bindings)
1631 sptr[3] = PROGN_REST(((4) << 2) | 0xF8000001u);
1632 get_car_and_cdr(exps, &ctx->curr_exp, &sptr[2]);
1633 if (lbm_is_symbol(sptr[2])) /* The only symbol it can be is nil */
1634 lbm_stack_drop(&ctx->K, 4);
1635 } else if (lbm_is_symbol_nil(exps)) {
1636 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1637 ctx->app_cont = true1;
1638 } else {
1639 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1640 }
1641}
1642
1643static void eval_atomic(eval_context_t *ctx) {
1644 if (is_atomic) {
1645 lbm_set_error_reason("Atomic blocks cannot be nested!");
1646 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1647 }
1648 stack_reserve(ctx, 1)[0] = EXIT_ATOMIC(((14) << 2) | 0xF8000001u);
1649 is_atomic ++;
1650 eval_progn(ctx);
1651}
1652
1653/* (call-cc (lambda (k) .... )) */
1654static void eval_callcc(eval_context_t *ctx) {
1655 lbm_value cont_array;
1656 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1657 gc();
1658 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1659 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1660 return; // dead return but static analysis doesn't know :)
1661 }
1662 }
1663 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(cont_array);
1664 memcpy(arr->data, ctx->K.data, ctx->K.sp * sizeof(lbm_uint));
1665
1666 lbm_value acont = cons_with_gc(ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u), cont_array, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1667 lbm_value arg_list = cons_with_gc(acont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1668 // Go directly into application evaluation without passing go
1669 lbm_uint *sptr = stack_reserve(ctx, 3);
1670 sptr[0] = ctx->curr_env;
1671 sptr[1] = arg_list;
1672 sptr[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
1673 ctx->curr_exp = get_cadr(ctx->curr_exp);
1674}
1675
1676// (define sym exp)
1677#define KEY1 1
1678#define VAL2 2
1679static void eval_define(eval_context_t *ctx) {
1680 lbm_value parts[3];
1681 lbm_value rest = extract_n(ctx->curr_exp, parts, 3);
1682 lbm_uint *sptr = stack_reserve(ctx, 2);
1683 if (lbm_is_symbol(parts[KEY1]) && lbm_is_symbol_nil(rest)) {
1684 lbm_uint sym_val = lbm_dec_sym(parts[KEY1]);
1685 sptr[0] = parts[KEY1];
1686 if (sym_val >= RUNTIME_SYMBOLS_START0x40000) {
1687 sptr[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
1688 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02) {
1689 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
1690 }
1691 ctx->curr_exp = parts[VAL2];
1692 return;
1693 }
1694 }
1695 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
1696}
1697
1698
1699/* Eval lambda is cheating, a lot! It does this
1700 for performance reasons. The cheats are that
1701 1. When closure is created, a reference to the local env
1702 in which the lambda was evaluated is added to the closure.
1703 Ideally it should have created a list of free variables in the function
1704 and then looked up the values of these creating a new environment.
1705 2. The global env is considered global constant. As there is no copying
1706 of environment bindings into the closure, undefine may break closures.
1707
1708 Correct closure creation is a lot more expensive than what happens here.
1709 However, one can try to write programs in such a way that closures are created
1710 seldomly. If one does that the space-usage benefits of "correct" closures
1711 may outweigh the performance gain of "incorrect" ones.
1712
1713 some obscure programs such as test_setq_local_closure.lisp does not
1714 work properly due to this cheating.
1715 */
1716// (lambda param-list body-exp) -> (closure param-list body-exp env)
1717static void eval_lambda(eval_context_t *ctx) {
1718 lbm_value vals[3];
1719 extract_n(ctx->curr_exp, vals, 3);
1720 ctx->r = allocate_closure(vals[1],vals[2], ctx->curr_env);
1721#ifdef CLEAN_UP_CLOSURES
1722 lbm_uint sym_id = 0;
1723 if (clean_cl_env_symbol) {
1724 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1725 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1726 ctx->curr_exp = app;
1727 } else if (lbm_get_symbol_by_name("clean-cl-env", &sym_id)) {
1728 clean_cl_env_symbol = lbm_enc_sym(sym_id);
1729 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1730 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1731 ctx->curr_exp = app;
1732 } else {
1733 ctx->app_cont = true1;
1734 }
1735#else
1736 ctx->app_cont = true1;
1737#endif
1738}
1739
1740// (if cond-expr then-expr else-expr)
1741static void eval_if(eval_context_t *ctx) {
1742 lbm_value cdr = get_cdr(ctx->curr_exp);
1743 lbm_value *sptr = stack_reserve(ctx, 3);
1744 sptr[0] = get_cdr(cdr);
1745 sptr[1] = ctx->curr_env;
1746 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1747 ctx->curr_exp = get_car(cdr);
1748}
1749
1750// (cond (cond-expr-1 expr-1)
1751// ...
1752// (cond-expr-N expr-N))
1753static void eval_cond(eval_context_t *ctx) {
1754 lbm_value cond1[2];
1755 lbm_value rest_conds = extract_n(ctx->curr_exp, cond1, 2);
1756
1757 // end recursion at (cond )
1758 if (lbm_is_symbol_nil(cond1[1])) {
1759 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1760 ctx->app_cont = true1;
1761 } else {
1762 // Cond is one of the few places where a bit of syntax checking takes place at runtime..
1763 // Maybe dont bother?
1764 lbm_uint len = lbm_list_length(cond1[1]);
1765 if (len != 2) {
1766 lbm_set_error_reason("Incorrect syntax in cond");
1767 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1768 }
1769 lbm_value cond_expr[2];
1770 extract_n(cond1[1], cond_expr, 2);
1771 lbm_value rest;
1772 WITH_GC(rest, lbm_heap_allocate_list_init(2,(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1773 cond_expr[1], // Then branch(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1774 cons_with_gc(ENC_SYM_COND, rest_conds , ENC_SYM_NIL)))(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
1775 lbm_value *sptr = stack_reserve(ctx, 3);
1776 sptr[0] = rest;
1777 sptr[1] = ctx->curr_env;
1778 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1779 ctx->curr_exp = cond_expr[0]; //condition;
1780 }
1781}
1782
1783static void eval_app_cont(eval_context_t *ctx) {
1784 lbm_stack_drop(&ctx->K, 1);
1785 ctx->app_cont = true1;
1786}
1787
1788// Create a named location in an environment to later receive a value.
1789static binding_location_status create_binding_location_internal(lbm_value key, lbm_value *env) {
1790
1791 if (lbm_is_symbol(key) &&
1792 (key == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u) ||
1793 key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)))
1794 return BL_OK;
1795
1796 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) { // default case
1797 lbm_value binding;
1798 lbm_value new_env_tmp;
1799 binding = lbm_cons(key, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1800 new_env_tmp = lbm_cons(binding, *env);
1801 if (lbm_is_symbol(binding) || lbm_is_symbol(new_env_tmp)) {
1802 return BL_NO_MEMORY;
1803 }
1804 *env = new_env_tmp;
1805 } else if (lbm_is_cons(key)) { // deconstruct case
1806 int r = create_binding_location_internal(get_car(key), env);
1807 if (r == BL_OK) {
1808 r = create_binding_location_internal(get_cdr(key), env);
1809 }
1810 return r;
1811 }
1812 return BL_OK;
1813}
1814
1815static void create_binding_location(lbm_value key, lbm_value *env) {
1816
1817 lbm_value env_tmp = *env;
1818 binding_location_status r = create_binding_location_internal(key, &env_tmp);
1819 if (r != BL_OK) {
1820 if (r == BL_NO_MEMORY) {
1821 env_tmp = *env;
1822 lbm_gc_mark_phase(env_tmp);
1823 gc();
1824 r = create_binding_location_internal(key, &env_tmp);
1825 }
1826 switch(r) {
1827 case BL_OK:
1828 break;
1829 case BL_NO_MEMORY:
1830 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1831 break;
1832 case BL_INCORRECT_KEY:
1833 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
1834 break;
1835 }
1836 }
1837 *env = env_tmp;
1838}
1839
1840static void let_bind_values_eval(lbm_value binds, lbm_value exp, lbm_value env, eval_context_t *ctx) {
1841
1842 if (!lbm_is_cons(binds)) {
1843 // binds better be nil or there is a programmer error.
1844 ctx->curr_exp = exp;
1845 return;
1846 }
1847
1848 // Preallocate binding locations.
1849 lbm_value curr = binds;
1850 while (lbm_is_cons(curr)) {
1851 lbm_value new_env_tmp = env;
1852 lbm_value car_curr, cdr_curr;
1853 get_car_and_cdr(curr, &car_curr, &cdr_curr);
1854 lbm_value key = get_car(car_curr);
1855 create_binding_location(key, &new_env_tmp);
1856 env = new_env_tmp;
1857 curr = cdr_curr;
1858 }
1859
1860 lbm_value car_binds;
1861 lbm_value cdr_binds;
1862 get_car_and_cdr(binds, &car_binds, &cdr_binds);
1863 lbm_value key_val[2];
1864 extract_n(car_binds, key_val, 2);
1865
1866 lbm_uint *sptr = stack_reserve(ctx, 5);
1867 sptr[0] = exp;
1868 sptr[1] = cdr_binds;
1869 sptr[2] = env;
1870 sptr[3] = key_val[0];
1871 sptr[4] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
1872 ctx->curr_exp = key_val[1];
1873 ctx->curr_env = env;
1874}
1875
1876// (var x (...)) - local binding inside of an progn
1877// var has to take, place root-level nesting within progn.
1878// (progn ... (var a 10) ...) OK!
1879// (progn ... (something (var a 10)) ... ) NOT OK!
1880/* progn stack
1881 sp-4 : env
1882 sp-3 : 0
1883 sp-2 : rest
1884 sp-1 : PROGN_REST
1885*/
1886static void eval_var(eval_context_t *ctx) {
1887
1888 if (ctx->K.sp >= 4) { // Possibly in progn
1889 lbm_value sv = ctx->K.data[ctx->K.sp - 1];
1890 if (IS_CONTINUATION(sv)(((sv) & 0xF8000001u) == 0xF8000001u) && (sv == PROGN_REST(((4) << 2) | 0xF8000001u))) {
1891 lbm_uint sp = ctx->K.sp;
1892 uint32_t is_copied = lbm_dec_as_u32(ctx->K.data[sp-3]);
1893 if (is_copied == 0) {
1894 lbm_value env;
1895 WITH_GC(env, lbm_env_copy_spine(ctx->K.data[sp-4]))(env) = (lbm_env_copy_spine(ctx->K.data[sp-4])); if (lbm_is_symbol_merror
((env))) { gc(); (env) = (lbm_env_copy_spine(ctx->K.data[sp
-4])); if (lbm_is_symbol_merror((env))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1896 ctx->K.data[sp-3] = lbm_enc_u(1);
1897 ctx->K.data[sp-4] = env;
1898 }
1899 lbm_value new_env = ctx->K.data[sp-4];
1900 lbm_value args = get_cdr(ctx->curr_exp);
1901 lbm_value key = get_car(args);
1902 create_binding_location(key, &new_env);
1903 ctx->K.data[sp-4] = new_env;
1904
1905 lbm_value v_exp = get_cadr(args);
1906 lbm_value *sptr = stack_reserve(ctx, 3);
1907 sptr[0] = new_env;
1908 sptr[1] = key;
1909 sptr[2] = PROGN_VAR(((29) << 2) | 0xF8000001u);
1910 // Activating the new environment before the evaluation of the value to be bound,
1911 // means that other variables with same name will be shadowed already in the value
1912 // body.
1913 // The way closures work, the var-variable needs to be in scope during val evaluation
1914 // for a recursive closure to be possible.
1915 ctx->curr_env = new_env;
1916 ctx->curr_exp = v_exp;
1917 return;
1918 }
1919 }
1920 lbm_set_error_reason((char*)lbm_error_str_var_outside_progn);
1921 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1922}
1923
1924// (setq x (...)) - same as (set 'x (...)) or (setvar 'x (...))
1925static void eval_setq(eval_context_t *ctx) {
1926 lbm_value parts[3];
1927 extract_n(ctx->curr_exp, parts, 3);
1928 lbm_value *sptr = stack_reserve(ctx, 3);
1929 sptr[0] = ctx->curr_env;
1930 sptr[1] = parts[1];
1931 sptr[2] = SETQ(((30) << 2) | 0xF8000001u);
1932 ctx->curr_exp = parts[2];
1933}
1934
1935static void eval_move_to_flash(eval_context_t *ctx) {
1936 lbm_value args = get_cdr(ctx->curr_exp);
1937 lbm_value *sptr = stack_reserve(ctx,2);
1938 sptr[0] = args;
1939 sptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
1940 ctx->app_cont = true1;
1941}
1942
1943// (loop list-of-local-bindings
1944// condition-exp
1945// body-exp)
1946static void eval_loop(eval_context_t *ctx) {
1947 lbm_value env = ctx->curr_env;
1948 lbm_value parts[3];
1949 extract_n(get_cdr(ctx->curr_exp), parts, 3);
1950 lbm_value *sptr = stack_reserve(ctx, 3);
1951 sptr[0] = parts[LOOP_BODY2];
1952 sptr[1] = parts[LOOP_COND1];
1953 sptr[2] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
1954 let_bind_values_eval(parts[LOOP_BINDS0], parts[LOOP_COND1], env, ctx);
1955}
1956
1957/* (trap expression)
1958 *
1959 * suggested use:
1960 * (match (trap expression)
1961 * ((exit-error (? err)) (error-handler err))
1962 * ((exit-ok (? v)) (value-handler v)))
1963 */
1964static void eval_trap(eval_context_t *ctx) {
1965
1966 lbm_value expr = get_cadr(ctx->curr_exp);
1967 lbm_value retval;
1968 WITH_GC(retval, lbm_heap_allocate_list(2))(retval) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((retval))) { gc(); (retval) = (lbm_heap_allocate_list(2)); if
(lbm_is_symbol_merror((retval))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1969 lbm_set_car(retval, ENC_SYM_EXIT_OK(((0x3000B) << 4) | 0x00000000u)); // Assume things will go well.
1970 lbm_uint *sptr = stack_reserve(ctx,3);
1971 sptr[0] = retval;
1972 sptr[1] = ctx->flags;
1973 sptr[2] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1974 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10;
1975 ctx->curr_exp = expr;
1976}
1977
1978// (let list-of-binding s
1979// body-exp)
1980static void eval_let(eval_context_t *ctx) {
1981 lbm_value env = ctx->curr_env;
1982 lbm_value parts[3];
1983 extract_n(ctx->curr_exp, parts, 3);
1984 let_bind_values_eval(parts[1], parts[2], env, ctx);
1985}
1986
1987// (and exp0 ... expN)
1988static void eval_and(eval_context_t *ctx) {
1989 lbm_value rest = get_cdr(ctx->curr_exp);
1990 if (lbm_is_symbol_nil(rest)) {
1991 ctx->app_cont = true1;
1992 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1993 } else {
1994 lbm_value *sptr = stack_reserve(ctx, 3);
1995 sptr[0] = ctx->curr_env;
1996 sptr[1] = get_cdr(rest);
1997 sptr[2] = AND(((6) << 2) | 0xF8000001u);
1998 ctx->curr_exp = get_car(rest);
1999 }
2000}
2001
2002// (or exp0 ... expN)
2003static void eval_or(eval_context_t *ctx) {
2004 lbm_value rest = get_cdr(ctx->curr_exp);
2005 if (lbm_is_symbol_nil(rest)) {
2006 ctx->app_cont = true1;
2007 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2008 } else {
2009 lbm_value *sptr = stack_reserve(ctx, 3);
2010 sptr[0] = ctx->curr_env;
2011 sptr[1] = get_cdr(rest);
2012 sptr[2] = OR(((7) << 2) | 0xF8000001u);
2013 ctx->curr_exp = get_car(rest);
2014 }
2015}
2016
2017// Pattern matching
2018// format:
2019// (match e (pattern body)
2020// (pattern body)
2021// ... )
2022//
2023// There can be an optional pattern guard:
2024// (match e (pattern guard body)
2025// ... )
2026// a guard is a boolean expression.
2027// Guards make match, pattern matching more complicated
2028// than the recv pattern matching and requires staged execution
2029// via the continuation system rather than a while loop over a list.
2030static void eval_match(eval_context_t *ctx) {
2031
2032 lbm_value rest = get_cdr(ctx->curr_exp);
2033 if (lbm_type_of(rest) == LBM_TYPE_SYMBOL0x00000000u &&
2034 rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
2035 // Someone wrote the program (match)
2036 ctx->app_cont = true1;
2037 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2038 } else {
2039 lbm_value cdr_rest;
2040 get_car_and_cdr(rest, &ctx->curr_exp, &cdr_rest);
2041 lbm_value *sptr = stack_reserve(ctx, 3);
2042 sptr[0] = cdr_rest;
2043 sptr[1] = ctx->curr_env;
2044 sptr[2] = MATCH(((9) << 2) | 0xF8000001u);
2045 }
2046}
2047
2048static void receive_base(eval_context_t *ctx, lbm_value pats, float timeout_time, bool_Bool timeout) {
2049 if (ctx->num_mail == 0) {
2050 if (timeout) {
2051 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000), false0);
2052 } else {
2053 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1,0,false0);
2054 }
2055 } else {
2056 lbm_value *msgs = ctx->mailbox;
2057 lbm_uint num = ctx->num_mail;
2058
2059 if (lbm_is_symbol_nil(pats)) {
2060 /* A receive statement without any patterns */
2061 ctx->app_cont = true1;
2062 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2063 } else {
2064 /* The common case */
2065 lbm_value e;
2066 lbm_value new_env = ctx->curr_env;
2067 int n = find_match(pats, msgs, num, &e, &new_env);
2068 if (n == FM_NEED_GC-1) {
2069 gc();
2070 new_env = ctx->curr_env;
2071 n = find_match(pats, msgs, num, &e, &new_env);
2072 if (n == FM_NEED_GC-1) {
2073 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2074 }
2075 }
2076 if (n == FM_PATTERN_ERROR-3) {
2077 lbm_set_error_reason("Incorrect pattern format for recv");
2078 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),pats);
2079 } else if (n >= 0 ) { /* Match */
2080 mailbox_remove_mail(ctx, (lbm_uint)n);
2081 ctx->curr_env = new_env;
2082 ctx->curr_exp = e;
2083 } else { /* No match go back to sleep */
2084 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
2085 if (timeout) {
2086 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2,S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000),false0);
2087 } else {
2088 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,false0);
2089 }
2090 }
2091 }
2092 }
2093 return;
2094}
2095
2096static void eval_receive_timeout(eval_context_t *ctx) {
2097 if (is_atomic) {
2098 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2099 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2100 }
2101 lbm_value timeout_val = get_cadr(ctx->curr_exp);
2102 if (!lbm_is_number(timeout_val)) {
2103 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2104 }
2105 float timeout_time = lbm_dec_as_float(timeout_val);
2106 lbm_value pats = get_cdr(get_cdr(ctx->curr_exp));
2107 receive_base(ctx, pats, timeout_time, true1);
2108}
2109
2110// Receive
2111// (recv (pattern expr)
2112// (pattern expr))
2113static void eval_receive(eval_context_t *ctx) {
2114
2115 if (is_atomic) {
2116 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2117 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
2118 }
2119 lbm_value pats = get_cdr(ctx->curr_exp);
2120 receive_base(ctx, pats, 0, false0);
2121}
2122
2123/*********************************************************/
2124/* Continuation functions */
2125
2126/* cont_set_global_env
2127 sp-1 : Key-symbol
2128 */
2129static void cont_set_global_env(eval_context_t *ctx){
2130
2131 lbm_value key;
2132 lbm_value val = ctx->r;
2133
2134 lbm_pop(&ctx->K, &key);
2135 lbm_uint dec_key = lbm_dec_sym(key);
2136 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
2137 lbm_value *global_env = lbm_get_global_env();
2138 lbm_uint orig_env = global_env[ix_key];
2139 lbm_value new_env;
2140 // A key is a symbol and should not need to be remembered.
2141 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2142
2143 global_env[ix_key] = new_env;
2144 ctx->r = val;
2145
2146 ctx->app_cont = true1;
2147
2148 return;
2149}
2150
2151static void cont_resume(eval_context_t *ctx) {
2152 lbm_pop_2(&ctx->K, &ctx->curr_env, &ctx->curr_exp);
2153}
2154
2155static void cont_progn_rest(eval_context_t *ctx) {
2156 lbm_value *sptr = get_stack_ptr(ctx, 3);
2157
2158 lbm_value rest = sptr[2];
2159 lbm_value env = sptr[0];
2160
2161 lbm_value rest_car, rest_cdr;
1
'rest_car' declared without an initial value
→
2162 get_car_and_cdr(rest, &rest_car, &rest_cdr);
2
←
Calling 'get_car_and_cdr'
→
7
←
Returning from 'get_car_and_cdr'
→
2163 ctx->curr_exp = rest_car;
8
←
Assigned value is garbage or undefined
2164 ctx->curr_env = env;
2165 if (lbm_is_symbol_nil(rest_cdr)) {
2166 // allow for tail recursion
2167 lbm_stack_drop(&ctx->K, 3);
2168 } else {
2169 sptr[2] = rest_cdr;
2170 stack_reserve(ctx, 1)[0] = PROGN_REST(((4) << 2) | 0xF8000001u);
2171 }
2172}
2173
2174static void cont_wait(eval_context_t *ctx) {
2175
2176 lbm_value cid_val;
2177 lbm_pop(&ctx->K, &cid_val);
2178 lbm_cid cid = (lbm_cid)lbm_dec_i(cid_val);
2179
2180 bool_Bool exists = false0;
2181
2182 lbm_blocked_iterator(context_exists, &cid, &exists);
2183 lbm_running_iterator(context_exists, &cid, &exists);
2184
2185 if (ctx_running->id == cid) {
2186 exists = true1;
2187 }
2188
2189 if (exists) {
2190 lbm_value *sptr = stack_reserve(ctx, 2);
2191 sptr[0] = lbm_enc_i(cid);
2192 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2193 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2194 ctx->app_cont = true1;
2195 yield_ctx(50000);
2196 } else {
2197 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2198 ctx->app_cont = true1;
2199 }
2200}
2201
2202static lbm_value perform_setvar(lbm_value key, lbm_value val, lbm_value env) {
2203
2204 lbm_uint s = lbm_dec_sym(key);
2205 if (s >= RUNTIME_SYMBOLS_START0x40000) {
2206 lbm_value new_env = lbm_env_modify_binding(env, key, val);
2207 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2208 lbm_uint ix_key = lbm_dec_sym(key) & GLOBAL_ENV_MASK0x1F;
2209 lbm_value *glob_env = lbm_get_global_env();
2210 new_env = lbm_env_modify_binding(glob_env[ix_key], key, val);
2211 glob_env[ix_key] = new_env;
2212 }
2213 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2214 lbm_set_error_reason((char*)lbm_error_str_variable_not_bound);
2215 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), key);
2216 }
2217 return val;
2218 }
2219 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2220 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // unreachable
2221}
2222
2223static void apply_setvar(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2224 if (nargs == 2 && lbm_is_symbol(args[0])) {
2225 lbm_value res;
2226 WITH_GC(res, perform_setvar(args[0], args[1], ctx->curr_env))(res) = (perform_setvar(args[0], args[1], ctx->curr_env));
if (lbm_is_symbol_merror((res))) { gc(); (res) = (perform_setvar
(args[0], args[1], ctx->curr_env)); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2227 ctx->r = args[1];
2228 lbm_stack_drop(&ctx->K, nargs+1);
2229 ctx->app_cont = true1;
2230 } else {
2231 if (nargs == 2) lbm_set_error_reason((char*)lbm_error_str_incorrect_arg);
2232 else lbm_set_error_reason((char*)lbm_error_str_num_args);
2233 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2234 }
2235}
2236
2237static void apply_read_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, bool_Bool program, bool_Bool incremental) {
2238 if (nargs == 1) {
2239 lbm_value chan = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2240 if (lbm_type_of_functional(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2241 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2242 gc();
2243 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2244 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2245 }
2246 }
2247 } else if (lbm_type_of(args[0]) == LBM_TYPE_CHANNEL0x90000000u) {
2248 chan = args[0];
2249 } else {
2250 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2251 }
2252 lbm_value *sptr = get_stack_ptr(ctx, 2);
2253
2254 // If we are inside a reader, its settings are stored.
2255 sptr[0] = lbm_enc_u(ctx->flags); // flags stored.
2256 sptr[1] = chan;
2257 lbm_value *rptr = stack_reserve(ctx,1);
2258 rptr[0] = READ_DONE(((20) << 2) | 0xF8000001u);
2259
2260 // Each reader starts in a fresh situation
2261 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
2262
2263 if (program) {
2264 if (incremental) {
2265 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2266 lbm_value *rptr1 = stack_reserve(ctx,3);
2267 rptr1[0] = chan;
2268 rptr1[1] = ctx->curr_env;
2269 rptr1[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
2270 } else {
2271 ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2272 lbm_value *rptr1 = stack_reserve(ctx,4);
2273 rptr1[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2274 rptr1[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2275 rptr1[2] = chan;
2276 rptr1[3] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
2277 }
2278 }
2279 rptr = stack_reserve(ctx,3); // reuse of variable rptr
2280 rptr[0] = chan;
2281 rptr[1] = lbm_enc_u(1);
2282 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
2283 ctx->app_cont = true1;
2284 } else {
2285 lbm_set_error_reason((char*)lbm_error_str_num_args);
2286 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2287 }
2288}
2289
2290static void apply_read_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2291 apply_read_base(args,nargs,ctx,true1,false0);
2292}
2293
2294static void apply_read_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2295 apply_read_base(args,nargs,ctx,true1,true1);
2296}
2297
2298static void apply_read(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2299 apply_read_base(args,nargs,ctx,false0,false0);
2300}
2301
2302static void apply_spawn_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, uint32_t context_flags) {
2303
2304 lbm_uint stack_size = EVAL_CPS_DEFAULT_STACK_SIZE256;
2305 lbm_uint closure_pos = 0;
2306 char *name = NULL((void*)0);
2307
2308 if (nargs >= 1 &&
2309 lbm_is_closure(args[0])) {
2310 closure_pos = 0;
2311 } else if (nargs >= 2 &&
2312 lbm_is_number(args[0]) &&
2313 lbm_is_closure(args[1])) {
2314 stack_size = lbm_dec_as_u32(args[0]);
2315 closure_pos = 1;
2316 } else if (nargs >= 2 &&
2317 lbm_is_array_r(args[0]) &&
2318 lbm_is_closure(args[1])) {
2319 name = lbm_dec_str(args[0]);
2320 closure_pos = 1;
2321 }else if (nargs >= 3 &&
2322 lbm_is_array_r(args[0]) &&
2323 lbm_is_number(args[1]) &&
2324 lbm_is_closure(args[2])) {
2325 stack_size = lbm_dec_as_u32(args[1]);
2326 closure_pos = 2;
2327 name = lbm_dec_str(args[0]);
2328 } else {
2329 if (context_flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01)
2330 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN_TRAP(((0x30005) << 4) | 0x00000000u));
2331 else
2332 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN(((0x30004) << 4) | 0x00000000u));
2333 }
2334
2335 lbm_value cl[3];
2336 extract_n(get_cdr(args[closure_pos]), cl, 3);
2337 lbm_value curr_param = cl[CLO_PARAMS0];
2338 lbm_value clo_env = cl[CLO_ENV2];
2339 lbm_uint i = closure_pos + 1;
2340 while (lbm_is_cons(curr_param) && i <= nargs) {
2341 lbm_value entry = cons_with_gc(get_car(curr_param), args[i], clo_env);
2342 lbm_value aug_env = cons_with_gc(entry, clo_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2343 clo_env = aug_env;
2344 curr_param = get_cdr(curr_param);
2345 i ++;
2346 }
2347
2348 lbm_stack_drop(&ctx->K, nargs+1);
2349
2350 lbm_value program = cons_with_gc(cl[CLO_BODY1], ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), clo_env);
2351
2352 lbm_cid cid = lbm_create_ctx_parent(program,
2353 clo_env,
2354 stack_size,
2355 lbm_get_current_cid(),
2356 context_flags,
2357 name);
2358 ctx->r = lbm_enc_i(cid);
2359 ctx->app_cont = true1;
2360}
2361
2362static void apply_spawn(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2363 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00);
2364}
2365
2366static void apply_spawn_trap(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2367 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01);
2368}
2369
2370static void apply_yield(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2371 if (is_atomic) {
2372 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2373 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2374 }
2375 if (nargs == 1 && lbm_is_number(args[0])) {
2376 lbm_uint ts = lbm_dec_as_u32(args[0]);
2377 lbm_stack_drop(&ctx->K, nargs+1);
2378 yield_ctx(ts);
2379 } else {
2380 lbm_set_error_reason((char*)lbm_error_str_no_number);
2381 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2382 }
2383}
2384
2385static void apply_sleep(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2386 if (is_atomic) {
2387 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2388 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2389 }
2390 if (nargs == 1 && lbm_is_number(args[0])) {
2391 lbm_uint ts = (lbm_uint)(1000000.0f * lbm_dec_as_float(args[0]));
2392 lbm_stack_drop(&ctx->K, nargs+1);
2393 yield_ctx(ts);
2394 } else {
2395 lbm_set_error_reason((char*)lbm_error_str_no_number);
2396 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2397 }
2398}
2399
2400static void apply_wait(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2401 if (nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2402 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2403 lbm_value *sptr = get_stack_ptr(ctx, 2);
2404 sptr[0] = lbm_enc_i(cid);
2405 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2406 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2407 ctx->app_cont = true1;
2408 yield_ctx(50000);
2409 } else {
2410 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_WAIT(((0x30007) << 4) | 0x00000000u));
2411 }
2412}
2413
2414/* (eval expr)
2415 (eval env expr) */
2416static void apply_eval(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2417 if ( nargs == 1) {
2418 ctx->curr_exp = args[0];
2419 } else if (nargs == 2) {
2420 ctx->curr_exp = args[1];
2421 ctx->curr_env = args[0];
2422 } else {
2423 lbm_set_error_reason((char*)lbm_error_str_num_args);
2424 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL(((0x30008) << 4) | 0x00000000u));
2425 }
2426 lbm_stack_drop(&ctx->K, nargs+1);
2427}
2428
2429static void apply_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2430 int prg_pos = 0;
2431 if (nargs == 2) {
2432 prg_pos = 1;
2433 ctx->curr_env = args[0];
2434 }
2435 if (nargs == 1 || nargs == 2) {
2436 lbm_value prg = args[prg_pos];
2437 lbm_value app_cont;
2438 lbm_value app_cont_prg;
2439 lbm_value new_prg;
2440 lbm_value prg_copy;
2441
2442 int len = -1;
2443 WITH_GC(prg_copy, lbm_list_copy(&len, prg))(prg_copy) = (lbm_list_copy(&len, prg)); if (lbm_is_symbol_merror
((prg_copy))) { gc(); (prg_copy) = (lbm_list_copy(&len, prg
)); if (lbm_is_symbol_merror((prg_copy))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2444 lbm_stack_drop(&ctx->K, nargs+1);
2445
2446 if (ctx->K.sp > nargs+2) { // if there is a continuation
2447 app_cont = cons_with_gc(ENC_SYM_APP_CONT(((0x111) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2448 app_cont_prg = cons_with_gc(app_cont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2449 new_prg = lbm_list_append(app_cont_prg, ctx->program);
2450 new_prg = lbm_list_append(prg_copy, new_prg);
2451 } else {
2452 new_prg = lbm_list_append(prg_copy, ctx->program);
2453 }
2454 if (!lbm_is_list(new_prg)) {
2455 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2456 }
2457 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);
2458 ctx->program = get_cdr(new_prg);
2459 ctx->curr_exp = get_car(new_prg);
2460 } else {
2461 lbm_set_error_reason((char*)lbm_error_str_num_args);
2462 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2463 }
2464}
2465
2466static void apply_send(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2467 if (nargs == 2) {
2468 if (lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2469 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2470 lbm_value msg = args[1];
2471 lbm_value status = lbm_find_receiver_and_send(cid, msg);
2472 /* return the status */
2473 lbm_stack_drop(&ctx->K, nargs+1);
2474 ctx->r = status;
2475 ctx->app_cont = true1;
2476 } else {
2477 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2478 }
2479 } else {
2480 lbm_set_error_reason((char*)lbm_error_str_num_args);
2481 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2482 }
2483}
2484
2485static void apply_ok(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2486 lbm_value ok_val = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2487 if (nargs >= 1) {
2488 ok_val = args[0];
2489 }
2490 ctx->r = ok_val;
2491 ok_ctx();
2492}
2493
2494static void apply_error(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2495 (void) ctx;
2496 lbm_value err_val = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
2497 if (nargs >= 1) {
2498 err_val = args[0];
2499 }
2500 error_at_ctx(err_val, ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
2501}
2502
2503// (map f arg-list)
2504static void apply_map(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2505 if (nargs == 2 && lbm_is_cons(args[1])) {
2506 lbm_value *sptr = get_stack_ptr(ctx, 3);
2507
2508 lbm_value f = args[0];
2509 lbm_value h = get_car(args[1]);
2510 lbm_value t = get_cdr(args[1]);
2511
2512 lbm_value appli_1;
2513 lbm_value appli;
2514 WITH_GC(appli_1, lbm_heap_allocate_list(2))(appli_1) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli_1))) { gc(); (appli_1) = (lbm_heap_allocate_list(2));
if (lbm_is_symbol_merror((appli_1))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2515 WITH_GC_RMBR_1(appli, lbm_heap_allocate_list(2), appli_1)(appli) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli))) { lbm_gc_mark_phase(appli_1); gc(); (appli) = (lbm_heap_allocate_list
(2)); if (lbm_is_symbol_merror((appli))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2516
2517 lbm_value appli_0 = get_cdr(appli_1);
2518
2519 lbm_set_car_and_cdr(appli_0, h, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2520 lbm_set_car(appli_1, ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u));
2521
2522 lbm_set_car_and_cdr(get_cdr(appli), appli_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2523 lbm_set_car(appli, f);
2524
2525 lbm_value elt = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), appli);
2526 sptr[0] = t; // reuse stack space
2527 sptr[1] = ctx->curr_env;
2528 sptr[2] = elt;
2529 lbm_value *rptr = stack_reserve(ctx,4);
2530 rptr[0] = elt;
2531 rptr[1] = appli;
2532 rptr[2] = appli_0;
2533 rptr[3] = MAP(((26) << 2) | 0xF8000001u);
2534 ctx->curr_exp = appli;
2535 } else if (nargs == 2 && lbm_is_symbol_nil(args[1])) {
2536 lbm_stack_drop(&ctx->K, 3);
2537 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2538 ctx->app_cont = true1;
2539 return;
2540 } else {
2541 lbm_set_error_reason((char*)lbm_error_str_num_args);
2542 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_MAP(((0x3000D) << 4) | 0x00000000u));
2543 }
2544}
2545
2546static void apply_reverse(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2547 if (nargs == 1 && lbm_is_list(args[0])) {
2548 lbm_value curr = args[0];
2549
2550 lbm_value new_list = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2551 while (lbm_is_cons(curr)) {
2552 lbm_value tmp = cons_with_gc(get_car(curr), new_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2553 new_list = tmp;
2554 curr = get_cdr(curr);
2555 }
2556 lbm_stack_drop(&ctx->K, 2);
2557 ctx->r = new_list;
2558 ctx->app_cont = true1;
2559 } else {
2560 lbm_set_error_reason("Reverse requires a list argument");
2561 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_REVERSE(((0x3000E) << 4) | 0x00000000u));
2562 }
2563}
2564
2565static void apply_flatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2566 if (nargs == 1) {
2567
2568 lbm_value v = flatten_value(args[0]);
2569 if ( v == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)) {
2570 gc();
2571 v = flatten_value(args[0]);
2572 }
2573
2574 if (lbm_is_symbol(v)) {
2575 error_at_ctx(v, ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2576 } else {
2577 lbm_stack_drop(&ctx->K, 2);
2578 ctx->r = v;
2579 ctx->app_cont = true1;
2580 }
2581 return;
2582 }
2583 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2584}
2585
2586static void apply_unflatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2587 if(nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2588 lbm_array_header_t *array;
2589 array = (lbm_array_header_t *)get_car(args[0]);
2590
2591 lbm_flat_value_t fv;
2592 fv.buf = (uint8_t*)array->data;
2593 fv.buf_size = array->size;
2594 fv.buf_pos = 0;
2595
2596 lbm_value res;
2597
2598 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2599 if (lbm_unflatten_value(&fv, &res)) {
2600 ctx->r = res;
2601 }
2602 lbm_stack_drop(&ctx->K, 2);
2603 ctx->app_cont = true1;
2604 return;
2605 }
2606 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_UNFLATTEN(((0x30010) << 4) | 0x00000000u));
2607}
2608
2609static void apply_kill(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2610 if (nargs == 2 && lbm_is_number(args[0])) {
2611 lbm_cid cid = lbm_dec_as_i32(args[0]);
2612
2613 if (ctx->id == cid) {
2614 ctx->r = args[1];
2615 finish_ctx();
2616 return;
2617 }
2618 mutex_lock(&qmutex);
2619 eval_context_t *found = NULL((void*)0);
2620 found = lookup_ctx_nm(&blocked, cid);
2621 if (found)
2622 drop_ctx_nm(&blocked, found);
2623 else
2624 found = lookup_ctx_nm(&queue, cid);
2625 if (found)
2626 drop_ctx_nm(&queue, found);
2627
2628 if (found) {
2629 found->K.data[found->K.sp - 1] = KILL(((40) << 2) | 0xF8000001u);
2630 found->r = args[1];
2631 found->app_cont = true1;
2632 enqueue_ctx_nm(&queue,found);
2633 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2634 } else {
2635 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2636 }
2637 lbm_stack_drop(&ctx->K, 3);
2638 ctx->app_cont = true1;
2639 mutex_unlock(&qmutex);
2640 return;
2641 }
2642 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_KILL(((0x30011) << 4) | 0x00000000u));
2643}
2644
2645// (merge comparator list1 list2)
2646static void apply_merge(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2647 if (nargs == 3 && lbm_is_list(args[1]) && lbm_is_list(args[2])) {
2648
2649 if (!lbm_is_closure(args[0])) {
2650 lbm_value closure;
2651 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2652 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2653 lbm_value cl1 = lbm_cdr(closure);
2654 lbm_value par;
2655 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2656 lbm_set_car(cl1, par);
2657 lbm_value cl2 = lbm_cdr(cl1);
2658 lbm_value body;
2659 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2660 lbm_set_car(cl2, body);
2661 lbm_value cl3 = lbm_cdr(cl2);
2662 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2663
2664 // Replace operator on stack with closure and rest of the code is
2665 // compatible.
2666 args[0] = closure;
2667 }
2668
2669 // Copy input lists for functional behaviour at top-level
2670 // merge itself is in-place in the copied lists.
2671 lbm_value a;
2672 lbm_value b;
2673 int len_a = -1;
2674 int len_b = -1;
2675 WITH_GC(a, lbm_list_copy(&len_a, args[1]))(a) = (lbm_list_copy(&len_a, args[1])); if (lbm_is_symbol_merror
((a))) { gc(); (a) = (lbm_list_copy(&len_a, args[1])); if
(lbm_is_symbol_merror((a))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } };
2676 WITH_GC_RMBR_1(b, lbm_list_copy(&len_b, args[2]), a)(b) = (lbm_list_copy(&len_b, args[2])); if (lbm_is_symbol_merror
((b))) { lbm_gc_mark_phase(a); gc(); (b) = (lbm_list_copy(&
len_b, args[2])); if (lbm_is_symbol_merror((b))) { error_ctx(
(((0x23) << 4) | 0x00000000u)); } };
2677
2678 if (len_a == 0) {
2679 ctx->r = b;
2680 lbm_stack_drop(&ctx->K, 4);
2681 ctx->app_cont = true1;
2682 return;
2683 }
2684 if (len_b == 0) {
2685 ctx->r = a;
2686 lbm_stack_drop(&ctx->K, 4);
2687 ctx->app_cont = true1;
2688 return;
2689 }
2690
2691 args[1] = a; // keep safe by replacing the original on stack.
2692 args[2] = b;
2693
2694 lbm_value a_1 = a;
2695 lbm_value a_rest = lbm_cdr(a);
2696 lbm_value b_1 = b;
2697 lbm_value b_rest = lbm_cdr(b);
2698
2699 lbm_value cl[3]; // Comparator closure
2700 extract_n(lbm_cdr(args[0]), cl, 3);
2701 lbm_value cmp_env = cl[CLO_ENV2];
2702 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2703 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2704 lbm_uint len = lbm_list_length(cl[CLO_PARAMS0]);
2705 if (len == 2) {
2706 par1 = get_car(cl[CLO_PARAMS0]);
2707 par2 = get_cadr(cl[CLO_PARAMS0]);
2708 lbm_value new_env0;
2709 lbm_value new_env;
2710 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a_1)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a_1))); if (
lbm_is_symbol_merror((new_env0))) { gc(); (new_env0) = (lbm_env_set
(cmp_env, par1, lbm_car(a_1))); if (lbm_is_symbol_merror((new_env0
))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2711 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b_1)),new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1))); if (
lbm_is_symbol_merror((new_env))) { lbm_gc_mark_phase(new_env0
); gc(); (new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1
))); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2712 cmp_env = new_env;
2713 } else {
2714 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2715 }
2716 lbm_set_cdr(a_1, b_1);
2717 lbm_set_cdr(b_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2718 lbm_value cmp = cl[CLO_BODY1];
2719
2720 lbm_stack_drop(&ctx->K, 4); // TODO: Optimize drop 4 alloc 10 into alloc 6
2721 lbm_uint *sptr = stack_reserve(ctx, 10);
2722 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged list
2723 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged list
2724 sptr[2] = a_1;
2725 sptr[3] = a_rest;
2726 sptr[4] = b_rest;
2727 sptr[5] = cmp;
2728 sptr[6] = cmp_env;
2729 sptr[7] = par1;
2730 sptr[8] = par2;
2731 sptr[9] = MERGE_REST(((43) << 2) | 0xF8000001u);
2732 ctx->curr_exp = cl[CLO_BODY1];
2733 ctx->curr_env = cmp_env;
2734 return;
2735 }
2736 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MERGE(((0x30013) << 4) | 0x00000000u));
2737}
2738
2739// (sort comparator list)
2740static void apply_sort(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2741 if (nargs == 2 && lbm_is_list(args[1])) {
2742
2743 if (!lbm_is_closure(args[0])) {
2744 lbm_value closure;
2745 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2746 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2747 lbm_value cl1 = lbm_cdr(closure);
2748 lbm_value par;
2749 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2750 lbm_set_car(cl1, par);
2751 lbm_value cl2 = lbm_cdr(cl1);
2752 lbm_value body;
2753 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2754 lbm_set_car(cl2, body);
2755 lbm_value cl3 = lbm_cdr(cl2);
2756 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2757
2758 // Replace operator on stack with closure and rest of the code is
2759 // compatible.
2760 args[0] = closure;
2761 }
2762
2763 int len = -1;
2764 lbm_value list_copy;
2765 WITH_GC(list_copy, lbm_list_copy(&len, args[1]))(list_copy) = (lbm_list_copy(&len, args[1])); if (lbm_is_symbol_merror
((list_copy))) { gc(); (list_copy) = (lbm_list_copy(&len,
args[1])); if (lbm_is_symbol_merror((list_copy))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2766 if (len <= 1) {
2767 lbm_stack_drop(&ctx->K, 3);
2768 ctx->r = list_copy;
2769 ctx->app_cont = true1;
2770 return;
2771 }
2772
2773 args[1] = list_copy; // Keep safe, original replaced on stack.
2774
2775 // Take the headmost 2, 1-element sublists.
2776 lbm_value a = list_copy;
2777 lbm_value b = lbm_cdr(a);
2778 lbm_value rest = lbm_cdr(b);
2779 // Do not terminate b. keep rest of list safe from GC in the following
2780 // closure extraction.
2781 //lbm_set_cdr(a, b); // This is void
2782
2783 lbm_value cl[3]; // Comparator closure
2784 extract_n(lbm_cdr(args[0]), cl, 3);
2785 lbm_value cmp_env = cl[CLO_ENV2];
2786 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2787 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2788 lbm_uint cl_len = lbm_list_length(cl[CLO_PARAMS0]);
2789 if (cl_len == 2) {
2790 par1 = get_car(cl[CLO_PARAMS0]);
2791 par2 = get_cadr(cl[CLO_PARAMS0]);
2792 lbm_value new_env0;
2793 lbm_value new_env;
2794 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a))); if (lbm_is_symbol_merror
((new_env0))) { gc(); (new_env0) = (lbm_env_set(cmp_env, par1
, lbm_car(a))); if (lbm_is_symbol_merror((new_env0))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2795 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b)), new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { lbm_gc_mark_phase(new_env0); gc(); (new_env) =
(lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { error_ctx((((0x23) << 4) | 0x00000000u))
; } };
2796 cmp_env = new_env;
2797 } else {
2798 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2799 }
2800 lbm_value cmp = cl[CLO_BODY1];
2801
2802 // Terminate the comparator argument list.
2803 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2804
2805 lbm_stack_drop(&ctx->K, 3); //TODO: optimize drop 3, alloc 20 into alloc 17
2806 lbm_uint *sptr = stack_reserve(ctx, 20);
2807 sptr[0] = cmp;
2808 sptr[1] = cmp_env;
2809 sptr[2] = par1;
2810 sptr[3] = par2;
2811 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged accumulation of sublists
2812 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged accumulation of sublists
2813 sptr[6] = rest;
2814 sptr[7] = lbm_enc_i(1);
2815 sptr[8] = lbm_enc_i(len); //TODO: 28 bit i vs 32 bit i
2816 sptr[9] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
2817 sptr[10] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged sublist
2818 sptr[11] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged sublist
2819 sptr[12] = a;
2820 sptr[13] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no a_rest, 1 element lists in layer 1.
2821 sptr[14] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no b_rest, 1 element lists in layer 1.
2822 sptr[15] = cmp;
2823 sptr[16] = cmp_env;
2824 sptr[17] = par1;
2825 sptr[18] = par2;
2826 sptr[19] = MERGE_REST(((43) << 2) | 0xF8000001u);
2827 ctx->curr_exp = cmp;
2828 ctx->curr_env = cmp_env;
2829 return;
2830 }
2831 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
2832}
2833
2834static void apply_rest_args(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2835 lbm_value res;
2836 if (lbm_env_lookup_b(&res, ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ctx->curr_env)) {
2837 if (nargs == 1 && lbm_is_number(args[0])) {
2838 int32_t ix = lbm_dec_as_i32(args[0]);
2839 res = lbm_index_list(res, ix);
2840 }
2841 ctx->r = res;
2842 } else {
2843 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2844 }
2845 lbm_stack_drop(&ctx->K, nargs+1);
2846 ctx->app_cont = true1;
2847}
2848
2849/* (rotate list-expr dist/dir-expr) */
2850static void apply_rotate(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2851 if (nargs == 2 && lbm_is_list(args[0]) && lbm_is_number(args[1])) {
2852 int len = -1;
2853 lbm_value ls = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2854 WITH_GC(ls, lbm_list_copy(&len, args[0]))(ls) = (lbm_list_copy(&len, args[0])); if (lbm_is_symbol_merror
((ls))) { gc(); (ls) = (lbm_list_copy(&len, args[0])); if
(lbm_is_symbol_merror((ls))) { error_ctx((((0x23) << 4
) | 0x00000000u)); } };
2855 int dist = lbm_dec_as_i32(args[1]);
2856 if (len > 0 && dist != 0) {
2857 int d = dist;
2858 if (dist > 0) {
2859 ls = lbm_list_destructive_reverse(ls);
2860 } else {
2861 d = -dist;
2862 }
2863
2864 lbm_value start = ls;
2865 lbm_value end = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2866 lbm_value curr = start;
2867 while (lbm_is_cons(curr)) {
2868 end = curr;
2869 curr = get_cdr(curr);
2870 }
2871
2872 for (int i = 0; i < d; i ++) {
2873 lbm_value a = start;
2874 start = lbm_cdr(start);
2875 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2876 lbm_set_cdr(end, a);
2877 end = a;
2878 }
2879 ls = start;
2880 if (dist > 0) {
2881 ls = lbm_list_destructive_reverse(ls);
2882 }
2883 }
2884 lbm_stack_drop(&ctx->K, nargs+1);
2885 ctx->app_cont = true1;
2886 ctx->r = ls;
2887 return;
2888 }
2889 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2890}
2891
2892/***************************************************/
2893/* Application lookup table */
2894
2895typedef void (*apply_fun)(lbm_value *, lbm_uint, eval_context_t *);
2896static const apply_fun fun_table[] =
2897 {
2898 apply_setvar,
2899 apply_read,
2900 apply_read_program,
2901 apply_read_eval_program,
2902 apply_spawn,
2903 apply_spawn_trap,
2904 apply_yield,
2905 apply_wait,
2906 apply_eval,
2907 apply_eval_program,
2908 apply_send,
2909 apply_ok,
2910 apply_error,
2911 apply_map,
2912 apply_reverse,
2913 apply_flatten,
2914 apply_unflatten,
2915 apply_kill,
2916 apply_sleep,
2917 apply_merge,
2918 apply_sort,
2919 apply_rest_args,
2920 apply_rotate,
2921 };
2922
2923/***************************************************/
2924/* Application of function that takes arguments */
2925/* passed over the stack. */
2926
2927static void application(eval_context_t *ctx, lbm_value *fun_args, lbm_uint arg_count) {
2928 /* If arriving here, we know that the fun is a symbol.
2929 * and can be a built in operation or an extension.
2930 */
2931 lbm_value fun = fun_args[0];
2932
2933 lbm_uint fun_val = lbm_dec_sym(fun);
2934 lbm_uint fun_kind = SYMBOL_KIND(fun_val)((fun_val) >> 16);
2935
2936 switch (fun_kind) {
2937 case SYMBOL_KIND_EXTENSION1: {
2938 extension_fptr f = extension_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)].fptr;
2939
2940 lbm_value ext_res;
2941 WITH_GC(ext_res, f(&fun_args[1], arg_count))(ext_res) = (f(&fun_args[1], arg_count)); if (lbm_is_symbol_merror
((ext_res))) { gc(); (ext_res) = (f(&fun_args[1], arg_count
)); if (lbm_is_symbol_merror((ext_res))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2942 if (lbm_is_error(ext_res)) { //Error other than merror
2943 error_at_ctx(ext_res, fun);
2944 }
2945 lbm_stack_drop(&ctx->K, arg_count + 1);
2946
2947 ctx->app_cont = true1;
2948 ctx->r = ext_res;
2949
2950 if (blocking_extension) {
2951 blocking_extension = false0;
2952 if (blocking_extension_timeout) {
2953 blocking_extension_timeout = false0;
2954 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, blocking_extension_timeout_us,true1);
2955 } else {
2956 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,true1);
2957 }
2958 mutex_unlock(&blocking_extension_mutex);
2959 }
2960 } break;
2961 case SYMBOL_KIND_FUNDAMENTAL2:
2962 call_fundamental(SYMBOL_IX(fun_val)((fun_val) & 0xFFFF), &fun_args[1], arg_count, ctx);
2963 break;
2964 case SYMBOL_KIND_APPFUN3:
2965 fun_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)](&fun_args[1], arg_count, ctx);
2966 break;
2967 default:
2968 // Symbols that are "special" but not in the way caught above
2969 // ends up here.
2970 lbm_set_error_reason("Symbol does not represent a function");
2971 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),fun_args[0]);
2972 break;
2973 }
2974}
2975
2976static void cont_closure_application_args(eval_context_t *ctx) {
2977 lbm_uint* sptr = get_stack_ptr(ctx, 5);
2978
2979 lbm_value arg_env = (lbm_value)sptr[0];
2980 lbm_value exp = (lbm_value)sptr[1];
2981 lbm_value clo_env = (lbm_value)sptr[2];
2982 lbm_value params = (lbm_value)sptr[3];
2983 lbm_value args = (lbm_value)sptr[4];
2984
2985 lbm_value car_params, cdr_params;
2986 get_car_and_cdr(params, &car_params, &cdr_params);
2987
2988 bool_Bool a_nil = lbm_is_symbol_nil(args);
2989 bool_Bool p_nil = lbm_is_symbol_nil(cdr_params);
2990
2991 lbm_value binder = allocate_binding(car_params, ctx->r, clo_env);
2992
2993 if (!a_nil && !p_nil) {
2994 lbm_value car_args, cdr_args;
2995 get_car_and_cdr(args, &car_args, &cdr_args);
2996 sptr[2] = binder;
2997 sptr[3] = cdr_params;
2998 sptr[4] = cdr_args;
2999 stack_reserve(ctx,1)[0] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
3000 ctx->curr_exp = car_args;
3001 ctx->curr_env = arg_env;
3002 } else if (a_nil && p_nil) {
3003 // Arguments and parameters match up in number
3004 lbm_stack_drop(&ctx->K, 5);
3005 ctx->curr_env = binder;
3006 ctx->curr_exp = exp;
3007 } else if (p_nil) {
3008 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), binder);
3009 sptr[2] = rest_binder;
3010 sptr[3] = get_cdr(args);
3011 sptr[4] = get_car(rest_binder); // last element of rest_args so far
3012 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3013 ctx->curr_exp = get_car(args);
3014 ctx->curr_env = arg_env;
3015 } else {
3016 lbm_set_error_reason((char*)lbm_error_str_num_args);
3017 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
3018 }
3019}
3020
3021
3022static void cont_closure_args_rest(eval_context_t *ctx) {
3023 lbm_uint* sptr = get_stack_ptr(ctx, 5);
3024 lbm_value arg_env = (lbm_value)sptr[0];
3025 lbm_value exp = (lbm_value)sptr[1];
3026 lbm_value clo_env = (lbm_value)sptr[2];
3027 lbm_value args = (lbm_value)sptr[3];
3028 lbm_value last = (lbm_value)sptr[4];
3029 lbm_cons_t* heap = lbm_heap_state.heap;
3030
3031 lbm_value binding = lbm_heap_state.freelist;
3032 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3033 gc();
3034 binding = lbm_heap_state.freelist;
3035 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3036 }
3037 lbm_uint binding_ix = lbm_dec_ptr(binding);
3038 lbm_heap_state.freelist = heap[binding_ix].cdr;
3039 lbm_heap_state.num_alloc += 1;
3040 heap[binding_ix].car = ctx->r;
3041 heap[binding_ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3042
3043
3044 lbm_set_cdr(last, binding);
3045 sptr[4] = binding;
3046
3047 if (args == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3048 lbm_stack_drop(&ctx->K, 5);
3049 ctx->curr_env = clo_env;
3050 ctx->curr_exp = exp;
3051 } else {
3052 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3053 sptr[3] = get_cdr(args);
3054 ctx->curr_exp = get_car(args);
3055 ctx->curr_env = arg_env;
3056 }
3057}
3058
3059static void cont_application_args(eval_context_t *ctx) {
3060 lbm_uint *sptr = get_stack_ptr(ctx, 3);
3061
3062 lbm_value env = sptr[0];
3063 lbm_value rest = sptr[1];
3064 lbm_value count = sptr[2];
3065
3066 ctx->curr_env = env;
3067 sptr[0] = ctx->r; // Function 1st then Arguments
3068 if (lbm_is_cons(rest)) {
3069 lbm_cons_t *cell = lbm_ref_cell(rest);
3070 sptr[1] = env;
3071 sptr[2] = cell->cdr;
3072 lbm_value *rptr = stack_reserve(ctx,2);
3073 rptr[0] = count + (1 << LBM_VAL_SHIFT4);
3074 rptr[1] = APPLICATION_ARGS(((5) << 2) | 0xF8000001u);
3075 ctx->curr_exp = cell->car;
3076 } else {
3077 // No more arguments
3078 lbm_stack_drop(&ctx->K, 2);
3079 lbm_uint nargs = lbm_dec_u(count);
3080 lbm_value *args = get_stack_ptr(ctx, (uint32_t)(nargs + 1));
3081 application(ctx,args, nargs);
3082 }
3083}
3084
3085static void cont_and(eval_context_t *ctx) {
3086 lbm_value env;
3087 lbm_value rest;
3088 lbm_value arg = ctx->r;
3089 lbm_pop_2(&ctx->K, &rest, &env);
3090 if (lbm_is_symbol_nil(arg)) {
3091 ctx->app_cont = true1;
3092 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3093 } else if (lbm_is_symbol_nil(rest)) {
3094 ctx->app_cont = true1;
3095 } else {
3096 lbm_value *sptr = stack_reserve(ctx, 3);
3097 sptr[0] = env;
3098 sptr[1] = get_cdr(rest);
3099 sptr[2] = AND(((6) << 2) | 0xF8000001u);
3100 ctx->curr_env = env;
3101 ctx->curr_exp = get_car(rest);
3102 }
3103}
3104
3105static void cont_or(eval_context_t *ctx) {
3106 lbm_value env;
3107 lbm_value rest;
3108 lbm_value arg = ctx->r;
3109 lbm_pop_2(&ctx->K, &rest, &env);
3110 if (!lbm_is_symbol_nil(arg)) {
3111 ctx->app_cont = true1;
3112 } else if (lbm_is_symbol_nil(rest)) {
3113 ctx->app_cont = true1;
3114 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3115 } else {
3116 lbm_value *sptr = stack_reserve(ctx, 3);
3117 sptr[0] = env;
3118 sptr[1] = get_cdr(rest);
3119 sptr[2] = OR(((7) << 2) | 0xF8000001u);
3120 ctx->curr_exp = get_car(rest);
3121 ctx->curr_env = env;
3122 }
3123}
3124
3125static int fill_binding_location(lbm_value key, lbm_value value, lbm_value env) {
3126 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) {
3127 if (key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return FB_OK0;
3128 lbm_env_modify_binding(env,key,value);
3129 return FB_OK0;
3130 } else if (lbm_is_cons(key) &&
3131 lbm_is_cons(value)) {
3132 int r = fill_binding_location(get_car(key), get_car(value), env);
3133 if (r == FB_OK0) {
3134 r = fill_binding_location(get_cdr(key), get_cdr(value), env);
3135 }
3136 return r;
3137 }
3138 return FB_TYPE_ERROR-1;
3139}
3140
3141static void cont_bind_to_key_rest(eval_context_t *ctx) {
3142
3143 lbm_value *sptr = get_stack_ptr(ctx, 4);
3144
3145 lbm_value rest = sptr[1];
3146 lbm_value env = sptr[2];
3147 lbm_value key = sptr[3];
3148
3149 if (fill_binding_location(key, ctx->r, env) < 0) {
3150 lbm_set_error_reason("Incorrect type of name/key in let-binding");
3151 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
3152 }
3153
3154 if (lbm_is_cons(rest)) {
3155 lbm_value car_rest = get_car(rest);
3156 lbm_value key_val[2];
3157 extract_n(car_rest, key_val, 2);
3158
3159 sptr[1] = get_cdr(rest);
3160 sptr[3] = key_val[0];
3161 stack_reserve(ctx,1)[0] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
3162 ctx->curr_exp = key_val[1];
3163 ctx->curr_env = env;
3164 } else {
3165 // Otherwise evaluate the expression in the populated env
3166 ctx->curr_exp = sptr[0];
3167 ctx->curr_env = env;
3168 lbm_stack_drop(&ctx->K, 4);
3169 }
3170}
3171
3172static void cont_if(eval_context_t *ctx) {
3173
3174 lbm_value arg = ctx->r;
3175
3176 lbm_value *sptr = pop_stack_ptr(ctx, 2);
3177
3178 ctx->curr_env = sptr[1];
3179 if (lbm_is_symbol_nil(arg)) {
3180 ctx->curr_exp = get_cadr(sptr[0]); // else branch
3181 } else {
3182 ctx->curr_exp = get_car(sptr[0]); // then branch
3183 }
3184}
3185
3186static void cont_match(eval_context_t *ctx) {
3187 lbm_value e = ctx->r;
3188 bool_Bool do_gc = false0;
3189
3190 lbm_uint *sptr = get_stack_ptr(ctx, 2);
3191 lbm_value patterns = (lbm_value)sptr[0];
3192 lbm_value orig_env = (lbm_value)sptr[1]; // restore enclosing environment.
3193 lbm_value new_env = orig_env;
3194
3195 if (lbm_is_symbol_nil(patterns)) {
3196 // no more patterns
3197 lbm_stack_drop(&ctx->K, 2);
3198 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
3199 ctx->app_cont = true1;
3200 } else if (lbm_is_cons(patterns)) {
3201 lbm_value match_case = get_car(patterns);
3202 lbm_value pattern = get_car(match_case);
3203 lbm_value n1 = get_cadr(match_case);
3204 lbm_value n2 = get_cadr(get_cdr(match_case));
3205 lbm_value body;
3206 bool_Bool check_guard = false0;
3207 if (lbm_is_symbol_nil(n2)) { // TODO: Not a very robust check.
3208 body = n1;
3209 } else {
3210 body = n2;
3211 check_guard = true1;
3212 }
3213
3214 bool_Bool is_match = match(pattern, e, &new_env, &do_gc);
3215 if (do_gc) {
3216 gc();
3217 do_gc = false0;
3218 new_env = orig_env;
3219 is_match = match(pattern, e, &new_env, &do_gc);
3220 if (do_gc) {
3221 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3222 }
3223 }
3224 if (is_match) {
3225 if (check_guard) {
3226 lbm_value *rptr = stack_reserve(ctx,5);
3227 sptr[0] = get_cdr(patterns);
3228 sptr[1] = ctx->curr_env;
3229 rptr[0] = MATCH(((9) << 2) | 0xF8000001u);
3230 rptr[1] = new_env;
3231 rptr[2] = body;
3232 rptr[3] = e;
3233 rptr[4] = MATCH_GUARD(((27) << 2) | 0xF8000001u);
3234 ctx->curr_env = new_env;
3235 ctx->curr_exp = n1; // The guard
3236 } else {
3237 lbm_stack_drop(&ctx->K, 2);
3238 ctx->curr_env = new_env;
3239 ctx->curr_exp = body;
3240 }
3241 } else {
3242 // set up for checking of next pattern
3243 sptr[0] = get_cdr(patterns);
3244 sptr[1] = orig_env;
3245 stack_reserve(ctx,1)[0] = MATCH(((9) << 2) | 0xF8000001u);
3246 // leave r unaltered
3247 ctx->app_cont = true1;
3248 }
3249 } else {
3250 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MATCH(((0x108) << 4) | 0x00000000u));
3251 }
3252}
3253
3254static void cont_exit_atomic(eval_context_t *ctx) {
3255 is_atomic --;
3256 ctx->app_cont = true1;
3257}
3258
3259static void cont_map(eval_context_t *ctx) {
3260 lbm_value *sptr = get_stack_ptr(ctx, 6);
3261
3262 lbm_value ls = sptr[0];
3263 lbm_value env = sptr[1];
3264 lbm_value t = sptr[3];
3265 lbm_set_car(t, ctx->r); // update car field tailmost position.
3266 if (lbm_is_cons(ls)) {
3267 lbm_value next, rest;
3268 get_car_and_cdr(ls, &next, &rest);
3269 sptr[0] = rest;
3270 stack_reserve(ctx,1)[0] = MAP(((26) << 2) | 0xF8000001u);
3271 lbm_set_car(sptr[5], next); // new arguments
3272
3273 lbm_value elt = cons_with_gc(ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3274 lbm_set_cdr(t, elt);
3275 sptr[3] = elt; // (r1 ... rN . (nil . nil))
3276 ctx->curr_exp = sptr[4];
3277 ctx->curr_env = env;
3278 } else {
3279 ctx->r = sptr[2]; //head of result list
3280 ctx->curr_env = env;
3281 lbm_stack_drop(&ctx->K, 6);
3282 ctx->app_cont = true1;
3283 }
3284}
3285
3286static void cont_match_guard(eval_context_t *ctx) {
3287 if (lbm_is_symbol_nil(ctx->r)) {
3288 lbm_value e;
3289 lbm_pop(&ctx->K, &e);
3290 lbm_stack_drop(&ctx->K, 2);
3291 ctx->r = e;
3292 ctx->app_cont = true1;
3293 } else {
3294 lbm_value body;
3295 lbm_value env;
3296 lbm_stack_drop(&ctx->K, 1);
3297 lbm_pop_2(&ctx->K, &body, &env);
3298 lbm_stack_drop(&ctx->K, 3);
3299 ctx->curr_env = env;
3300 ctx->curr_exp = body;
3301 }
3302}
3303
3304static void cont_terminate(eval_context_t *ctx) {
3305 error_ctx(ctx->r);
3306}
3307
3308static void cont_loop(eval_context_t *ctx) {
3309 lbm_value *sptr = get_stack_ptr(ctx, 2);
3310 stack_reserve(ctx,1)[0] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
3311 ctx->curr_exp = sptr[1];
3312}
3313
3314static void cont_loop_condition(eval_context_t *ctx) {
3315 if (lbm_is_symbol_nil(ctx->r)) {
3316 lbm_stack_drop(&ctx->K, 2);
3317 ctx->app_cont = true1; // A loop returns nil? Makes sense to me... but in general?
3318 return;
3319 }
3320 lbm_value *sptr = get_stack_ptr(ctx, 2);
3321 stack_reserve(ctx,1)[0] = LOOP(((41) << 2) | 0xF8000001u);
3322 ctx->curr_exp = sptr[0];
3323}
3324
3325static void cont_merge_rest(eval_context_t *ctx) {
3326 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3327
3328 // If comparator returns true (result is in ctx->r):
3329 // "a" should be moved to the last element position in merged list.
3330 // A new element from "a_rest" should be moved into comparator argument 1 pos.
3331 // else
3332 // "b" should be moved to last element position in merged list.
3333 // A new element from "b_rest" should be moved into comparator argument 2 pos.
3334 //
3335 // If a_rest or b_rest is NIL:
3336 // we are done, the remaining elements of
3337 // non_nil list should be appended to merged list.
3338 // else
3339 // Set up for a new comparator evaluation and recurse.
3340 lbm_value a = sptr[2];
3341 lbm_value b = lbm_cdr(a);
3342 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate 1 element list
3343
3344 if (ctx->r == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) { // Comparison false
3345
3346 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3347 sptr[0] = b;
3348 sptr[1] = b;
3349 } else {
3350 lbm_set_cdr(sptr[1], b);
3351 sptr[1] = b;
3352 }
3353 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3354 lbm_set_cdr(a, sptr[3]);
3355 lbm_set_cdr(sptr[1], a);
3356 ctx->r = sptr[0];
3357 lbm_stack_drop(&ctx->K, 9);
3358 ctx->app_cont = true1;
3359 return;
3360 } else {
3361 b = sptr[4];
3362 sptr[4] = lbm_cdr(sptr[4]);
3363 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3364 }
3365 } else {
3366 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3367 sptr[0] = a;
3368 sptr[1] = a;
3369 } else {
3370 lbm_set_cdr(sptr[1], a);
3371 sptr[1] = a;
3372 }
3373
3374 if (sptr[3] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3375 lbm_set_cdr(b, sptr[4]);
3376 lbm_set_cdr(sptr[1], b);
3377 ctx->r = sptr[0];
3378 lbm_stack_drop(&ctx->K, 9);
3379 ctx->app_cont = true1;
3380 return;
3381 } else {
3382 a = sptr[3];
3383 sptr[3] = lbm_cdr(sptr[3]);
3384 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3385 }
3386 }
3387 lbm_set_cdr(a, b);
3388 sptr[2] = a;
3389
3390 lbm_value par1 = sptr[7];
3391 lbm_value par2 = sptr[8];
3392 lbm_value cmp_body = sptr[5];
3393 lbm_value cmp_env = sptr[6];
3394 // Environment should be preallocated already at this point
3395 // and the operations below should never need GC.
3396 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3397 lbm_value new_env = lbm_env_set(new_env0, par2, lbm_car(b));
3398 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3399 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3400 }
3401 cmp_env = new_env;
3402
3403 stack_reserve(ctx,1)[0] = MERGE_REST(((43) << 2) | 0xF8000001u);
3404 ctx->curr_exp = cmp_body;
3405 ctx->curr_env = cmp_env;
3406}
3407
3408// merge_layer stack contents
3409// s[sp-9] = cmp
3410// s[sp-8] = cmp_env
3411// s[sp-7] = par1
3412// s[sp-6] = par2
3413// s[sp-5] = acc - first cell
3414// s[sp-4] = acc - last cell
3415// s[sp-3] = rest;
3416// s[sp-2] = layer
3417// s[sp-1] = length or original list
3418//
3419// ctx->r merged sublist
3420static void cont_merge_layer(eval_context_t *ctx) {
3421 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3422 lbm_int layer = lbm_dec_i(sptr[7]);
3423 lbm_int len = lbm_dec_i(sptr[8]);
3424
3425 lbm_value r_curr = ctx->r;
3426 while (lbm_is_cons(r_curr)) {
3427 lbm_value next = lbm_cdr(r_curr);
3428 if (next == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3429 break;
3430 }
3431 r_curr = next;
3432 }
3433
3434 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3435 sptr[4] = ctx->r;
3436 sptr[5] = r_curr;
3437 } else {
3438 lbm_set_cdr(sptr[5], ctx->r); // accumulate merged sublists.
3439 sptr[5] = r_curr;
3440 }
3441
3442 lbm_value layer_rest = sptr[6];
3443 // switch layer or done ?
3444 if (layer_rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3445 if (layer * 2 >= len) {
3446 ctx->r = sptr[4];
3447 ctx->app_cont = true1;
3448 lbm_stack_drop(&ctx->K, 9);
3449 return;
3450 } else {
3451 // Setup for merges of the next layer
3452 layer = layer * 2;
3453 sptr[7] = lbm_enc_i(layer);
3454 layer_rest = sptr[4]; // continue on the accumulation of all sublists.
3455 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3456 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3457 }
3458 }
3459 // merge another sublist based on current layer.
3460 lbm_value a_list = layer_rest;
3461 // build sublist a
3462 lbm_value curr = layer_rest;
3463 for (int i = 0; i < layer-1; i ++) {
3464 if (lbm_is_cons(curr)) {
3465 curr = lbm_cdr(curr);
3466 } else {
3467 break;
3468 }
3469 }
3470 layer_rest = lbm_cdr(curr);
3471 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3472
3473 lbm_value b_list = layer_rest;
3474 // build sublist b
3475 curr = layer_rest;
3476 for (int i = 0; i < layer-1; i ++) {
3477 if (lbm_is_cons(curr)) {
3478 curr = lbm_cdr(curr);
3479 } else {
3480 break;
3481 }
3482 }
3483 layer_rest = lbm_cdr(curr);
3484 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3485
3486 sptr[6] = layer_rest;
3487
3488 if (b_list == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3489 stack_reserve(ctx,1)[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3490 ctx->r = a_list;
3491 ctx->app_cont = true1;
3492 return;
3493 }
3494 // Set up for a merge of sublists.
3495
3496 lbm_value a_rest = lbm_cdr(a_list);
3497 lbm_value b_rest = lbm_cdr(b_list);
3498 lbm_value a = a_list;
3499 lbm_value b = b_list;
3500 lbm_set_cdr(a, b);
3501 // Terminating the b list would be incorrect here
3502 // if there was any chance that the environment update below
3503 // performs GC.
3504 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3505
3506 lbm_value cmp_body = sptr[0];
3507 lbm_value cmp_env = sptr[1];
3508 lbm_value par1 = sptr[2];
3509 lbm_value par2 = sptr[3];
3510 // Environment should be preallocated already at this point
3511 // and the operations below should never need GC.
3512 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3513 lbm_value new_env = lbm_env_set(cmp_env, par2, lbm_car(b));
3514 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3515 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3516 }
3517 cmp_env = new_env;
3518
3519 lbm_uint *merge_cont = stack_reserve(ctx, 11);
3520 merge_cont[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3521 merge_cont[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3522 merge_cont[2] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3523 merge_cont[3] = a;
3524 merge_cont[4] = a_rest;
3525 merge_cont[5] = b_rest;
3526 merge_cont[6] = cmp_body;
3527 merge_cont[7] = cmp_env;
3528 merge_cont[8] = par1;
3529 merge_cont[9] = par2;
3530 merge_cont[10] = MERGE_REST(((43) << 2) | 0xF8000001u);
3531 ctx->curr_exp = cmp_body;
3532 ctx->curr_env = cmp_env;
3533 return;
3534}
3535
3536/****************************************************/
3537/* READER */
3538
3539static void read_finish(lbm_char_channel_t *str, eval_context_t *ctx) {
3540
3541 /* Tokenizer reached "end of file"
3542 The parser could be in a state where it needs
3543 more tokens to correctly finish an expression.
3544
3545 Three cases
3546 1. The program / expression is malformed and the context should die.
3547 2. We are finished reading a program and should close off the
3548 internal representation with a closing parenthesis. Then
3549 apply continuation.
3550 3. We are finished reading an expression and should
3551 apply the continuation.
3552
3553 In case 3, we should find the READ_DONE at sp - 1.
3554 In case 2, we should find the READ_DONE at sp - 5.
3555
3556 */
3557
3558 if (lbm_is_symbol(ctx->r)) {
3559 lbm_uint sym_val = lbm_dec_sym(ctx->r);
3560 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
3561 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
3562 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3563 }
3564 }
3565
3566 if (ctx->K.data[ctx->K.sp-1] == READ_DONE(((20) << 2) | 0xF8000001u) &&
3567 lbm_dec_u(ctx->K.data[ctx->K.sp-3]) == 0) {
3568 /* successfully finished reading an expression (CASE 3) */
3569 ctx->app_cont = true1;
3570 } else if (ctx->K.sp > 4 && ctx->K.data[ctx->K.sp - 4] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3571 lbm_value env;
3572 lbm_value s;
3573 lbm_value sym;
3574 lbm_pop_3(&ctx->K, &sym, &env, &s);
3575 ctx->curr_env = env;
3576 ctx->app_cont = true1; // Program evaluated and result is in ctx->r.
3577 } else if (ctx->K.sp > 5 && ctx->K.data[ctx->K.sp - 5] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3578 /* successfully finished reading a program (CASE 2) */
3579 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3580 ctx->app_cont = true1;
3581 } else {
3582 /* Parsing failed */
3583 if (lbm_channel_row(str) == 1 &&
3584 lbm_channel_column(str) == 1 ){
3585 // eof at empty stream.
3586 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3587 ctx->app_cont = true1;
3588 } else {
3589 lbm_set_error_reason((char*)lbm_error_str_parse_eof);
3590 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3591 }
3592 lbm_channel_reader_close(str);
3593 }
3594}
3595
3596/* cont_read_next_token
3597 sp-2 : Stream
3598 sp-1 : Grab row
3599*/
3600static void cont_read_next_token(eval_context_t *ctx) {
3601 lbm_value *sptr = get_stack_ptr(ctx, 2);
3602 lbm_value stream = sptr[0];
3603 lbm_value grab_row0 = sptr[1];
3604
3605 lbm_char_channel_t *chan = lbm_dec_channel(stream);
3606 if (chan == NULL((void*)0) || chan->state == NULL((void*)0)) {
3607 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3608 }
3609
3610 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3611 lbm_stack_drop(&ctx->K, 2);
3612 read_finish(chan, ctx);
3613 return;
3614 }
3615 /* Eat whitespace and comments */
3616 if (!tok_clean_whitespace(chan)) {
3617 sptr[0] = stream;
3618 sptr[1] = lbm_enc_u(0);
3619 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3620 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3621 return;
3622 }
3623 /* After eating whitespace we may be at end of file/stream */
3624 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3625 lbm_stack_drop(&ctx->K, 2);
3626 read_finish(chan, ctx);
3627 return;
3628 }
3629
3630 if (lbm_dec_u(grab_row0)) {
3631 ctx->row0 = (int32_t)lbm_channel_row(chan);
3632 }
3633
3634 /* Attempt to extract tokens from the character stream */
3635 int n = 0;
3636 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3637 unsigned int string_len = 0;
3638
3639 /*
3640 * SYNTAX
3641 */
3642 uint32_t match;
3643 n = tok_syntax(chan, &match);
3644 if (n > 0) {
3645 if (!lbm_channel_drop(chan, (unsigned int)n)) {
3646 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3647 }
3648 ctx->app_cont = true1;
3649 lbm_uint do_next = 0;
3650 switch(match) {
3651 case TOKOPENPAR1u: {
3652 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3653 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3654 lbm_value *rptr = stack_reserve(ctx,5);
3655 rptr[0] = stream;
3656 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3657 rptr[2] = stream;
3658 rptr[3] = lbm_enc_u(0);
3659 rptr[4] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3660 ctx->r = ENC_SYM_OPENPAR(((0x70) << 4) | 0x00000000u);
3661 } return;
3662 case TOKCLOSEPAR2u: {
3663 lbm_stack_drop(&ctx->K, 2);
3664 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3665 } return;
3666 case TOKOPENBRACK3u: {
3667 sptr[0] = stream;
3668 sptr[1] = READ_START_ARRAY(((24) << 2) | 0xF8000001u);
3669 lbm_value *rptr = stack_reserve(ctx, 3);
3670 rptr[0] = stream;
3671 rptr[1] = lbm_enc_u(0);
3672 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3673 ctx->r = ENC_SYM_OPENBRACK(((0x80) << 4) | 0x00000000u);
3674 } return;
3675 case TOKCLOSEBRACK4u:
3676 lbm_stack_drop(&ctx->K, 2);
3677 ctx->r = ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u);
3678 return;
3679 case TOKDOT5u:
3680 lbm_stack_drop(&ctx->K, 2);
3681 ctx->r = ENC_SYM_DOT(((0x76) << 4) | 0x00000000u);
3682 return;
3683 case TOKDONTCARE6u:
3684 lbm_stack_drop(&ctx->K, 2);
3685 ctx->r = ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u);
3686 return;
3687 case TOKQUOTE7u:
3688 do_next = READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u);
3689 break;
3690 case TOKBACKQUOTE8u: {
3691 sptr[0] = QQ_EXPAND_START(((35) << 2) | 0xF8000001u);
3692 sptr[1] = stream;
3693 lbm_value *rptr = stack_reserve(ctx, 2);
3694 rptr[0] = lbm_enc_u(0);
3695 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3696 ctx->app_cont = true1;
3697 } return;
3698 case TOKCOMMAAT9u:
3699 do_next = READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u);
3700 break;
3701 case TOKCOMMA10u:
3702 do_next = READ_COMMA_RESULT(((23) << 2) | 0xF8000001u);
3703 break;
3704 case TOKMATCHANY11u:
3705 lbm_stack_drop(&ctx->K, 2);
3706 ctx->r = ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u);
3707 return;
3708 case TOKOPENCURL12u: {
3709 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3710 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3711 lbm_value *rptr = stack_reserve(ctx,2);
3712 rptr[0] = stream;
3713 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3714 ctx->r = ENC_SYM_PROGN(((0x102) << 4) | 0x00000000u);
3715 } return;
3716 case TOKCLOSECURL13u:
3717 lbm_stack_drop(&ctx->K, 2);
3718 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3719 return;
3720 case TOKCONSTSTART14u: /* fall through */
3721 case TOKCONSTEND15u:
3722 case TOKCONSTSYMSTR16u: {
3723 if (match == TOKCONSTSTART14u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3724 if (match == TOKCONSTEND15u) ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3725 if (match == TOKCONSTSYMSTR16u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04;
3726 sptr[0] = stream;
3727 sptr[1] = lbm_enc_u(0);
3728 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3729 ctx->app_cont = true1;
3730 } return;
3731 default:
3732 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3733 }
3734 sptr[0] = do_next;
3735 sptr[1] = stream;
3736 lbm_value *rptr = stack_reserve(ctx, 2);
3737 rptr[0] = lbm_enc_u(0);
3738 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3739 ctx->app_cont = true1;
3740 return;
3741 } else if (n < 0) goto retry_token;
3742
3743 /*
3744 * STRING
3745 */
3746 n = tok_string(chan, &string_len);
3747 if (n >= 2) {
3748 lbm_channel_drop(chan, (unsigned int)n);
3749 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3750 gc();
3751 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3752 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3753 return; // dead return but static analysis does not know that.
3754 }
3755 }
3756 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(res);
3757 char *data = (char*)arr->data;
3758 memset(data,0, string_len + 1);
3759 memcpy(data, tokpar_sym_str, string_len);
3760 lbm_stack_drop(&ctx->K, 2);
3761 ctx->r = res;
3762 ctx->app_cont = true1;
3763 return;
3764 } else if (n < 0) goto retry_token;
3765
3766 /*
3767 * FLOAT
3768 */
3769 token_float f_val;
3770 n = tok_double(chan, &f_val);
3771 if (n > 0) {
3772 lbm_channel_drop(chan, (unsigned int) n);
3773 switch(f_val.type) {
3774 case TOKTYPEF32107u:
3775 WITH_GC(res, lbm_enc_float((float)f_val.value))(res) = (lbm_enc_float((float)f_val.value)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (lbm_enc_float((float)f_val.value));
if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
3776 break;
3777 case TOKTYPEF64108u:
3778 res = lbm_enc_double(f_val.value);
3779 break;
3780 default:
3781 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3782 }
3783 lbm_stack_drop(&ctx->K, 2);
3784 ctx->r = res;
3785 ctx->app_cont = true1;
3786 return;
3787 } else if (n < 0) goto retry_token;
3788
3789 /*
3790 * INTEGER
3791 */
3792 token_int int_result;
3793 n = tok_integer(chan, &int_result);
3794 if (n > 0) {
3795 lbm_channel_drop(chan, (unsigned int)n);
3796 switch(int_result.type) {
3797 case TOKTYPEBYTE100u:
3798 res = lbm_enc_char((uint8_t)(int_result.negative ? -int_result.value : int_result.value));
3799 break;
3800 case TOKTYPEI101u:
3801 res = lbm_enc_i((lbm_int)(int_result.negative ? -int_result.value : int_result.value));
3802 break;
3803 case TOKTYPEU102u:
3804 res = lbm_enc_u((lbm_uint)(int_result.negative ? -int_result.value : int_result.value));
3805 break;
3806 case TOKTYPEI32103u:
3807 WITH_GC(res, lbm_enc_i32((int32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i32((int32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i32((int32_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3808 break;
3809 case TOKTYPEU32104u:
3810 WITH_GC(res,lbm_enc_u32((uint32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u32((uint32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u32((uint32_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3811 break;
3812 case TOKTYPEI64105u:
3813 WITH_GC(res,lbm_enc_i64((int64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i64((int64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i64((int64_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3814 break;
3815 case TOKTYPEU64106u:
3816 WITH_GC(res,lbm_enc_u64((uint64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u64((uint64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u64((uint64_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3817 break;
3818 default:
3819 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3820 }
3821 lbm_stack_drop(&ctx->K, 2);
3822 ctx->r = res;
3823 ctx->app_cont = true1;
3824 return;
3825 } else if (n < 0) goto retry_token;
3826
3827 /*
3828 * SYMBOL
3829 */
3830 n = tok_symbol(chan);
3831 if (n > 0) {
3832 lbm_channel_drop(chan, (unsigned int) n);
3833 lbm_uint symbol_id;
3834 if (lbm_get_symbol_by_name(tokpar_sym_str, &symbol_id)) {
3835 res = lbm_enc_sym(symbol_id);
3836 } else {
3837 int r = 0;
3838 if (n > 4 &&
3839 tokpar_sym_str[0] == 'e' &&
3840 tokpar_sym_str[1] == 'x' &&
3841 tokpar_sym_str[2] == 't' &&
3842 tokpar_sym_str[3] == '-') {
3843 lbm_uint ext_id;
3844 lbm_uint ext_name_len = (lbm_uint)n + 1;
3845 char *ext_name = lbm_malloc(ext_name_len);
3846 if (!ext_name) {
3847 gc();
3848 ext_name = lbm_malloc(ext_name_len);
3849 }
3850 if (ext_name) {
3851 memcpy(ext_name, tokpar_sym_str, ext_name_len);
3852 r = lbm_add_extension(ext_name, lbm_extensions_default);
3853 if (!lbm_lookup_extension_id(ext_name, &ext_id)) {
3854 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3855 }
3856 symbol_id = ext_id;
3857 } else {
3858 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3859 }
3860 } else {
3861 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04 &&
3862 ctx->flags & EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08) {
3863 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id, true1); //flash
3864 if (!r) {
3865 lbm_set_error_reason((char*)lbm_error_str_flash_error);
3866 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3867 }
3868 } else {
3869 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3870 if (!r) {
3871 gc();
3872 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3873 }
3874 }
3875 }
3876 if (r) {
3877 res = lbm_enc_sym(symbol_id);
3878 } else {
3879 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3880 }
3881 }
3882 lbm_stack_drop(&ctx->K, 2);
3883 ctx->r = res;
3884 ctx->app_cont = true1;
3885 return;
3886 } else if (n == TOKENIZER_NEED_MORE-1) {
3887 goto retry_token;
3888 } else if (n <= TOKENIZER_STRING_ERROR-2) {
3889 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3890 }
3891
3892 /*
3893 * CHAR
3894 */
3895 char c_val;
3896 n = tok_char(chan, &c_val);
3897 if(n > 0) {
3898 lbm_channel_drop(chan,(unsigned int) n);
3899 lbm_stack_drop(&ctx->K, 2);
3900 ctx->r = lbm_enc_char((uint8_t)c_val);
3901 ctx->app_cont = true1;
3902 return;
3903 }else if (n < 0) goto retry_token;
3904
3905 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3906
3907 retry_token:
3908 if (n == TOKENIZER_NEED_MORE-1) {
3909 sptr[0] = stream;
3910 sptr[1] = lbm_enc_u(0);
3911 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3912 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3913 return;
3914 }
3915 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3916}
3917
3918static void cont_read_start_array(eval_context_t *ctx) {
3919 lbm_value *sptr = get_stack_ptr(ctx, 1);
3920 lbm_value stream = sptr[0];
3921
3922 lbm_char_channel_t *str = lbm_dec_channel(stream);
3923 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
3924 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3925 }
3926
3927 lbm_uint num_free = lbm_memory_longest_free();
3928 lbm_uint initial_size = (lbm_uint)((float)num_free * 0.9);
3929 if (initial_size == 0) {
3930 gc();
3931 num_free = lbm_memory_longest_free();
3932 initial_size = (lbm_uint)((float)num_free * 0.9);
3933 if (initial_size == 0) {
3934 lbm_channel_reader_close(str);
3935 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3936 }
3937 }
3938
3939 if (lbm_is_number(ctx->r)) {
3940 lbm_value array;
3941 initial_size = sizeof(lbm_uint) * initial_size;
3942
3943 if (!lbm_heap_allocate_array(&array, initial_size)) {
3944 lbm_set_error_reason("Out of memory while reading.");
3945 lbm_channel_reader_close(str);
3946 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3947 // NOTE: If array is not created evaluation ends here.
3948 // Static analysis seems unaware.
3949 }
3950
3951 sptr[0] = array;
3952 lbm_value *rptr = stack_reserve(ctx, 4);
3953 rptr[0] = lbm_enc_u(initial_size);
3954 rptr[1] = lbm_enc_u(0);
3955 rptr[2] = stream;
3956 rptr[3] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3957 ctx->app_cont = true1;
3958 } else {
3959 lbm_channel_reader_close(str);
3960 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3961 }
3962}
3963
3964static void cont_read_append_array(eval_context_t *ctx) {
3965 lbm_uint *sptr = get_stack_ptr(ctx, 4);
3966
3967 lbm_value array = sptr[0];
3968 lbm_value size = lbm_dec_as_u32(sptr[1]);
3969 lbm_value ix = lbm_dec_as_u32(sptr[2]);
3970 lbm_value stream = sptr[3];
3971
3972 if (ix >= (size - 1)) {
3973 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3974 }
3975
3976 // get_car can return nil. Whose value is 0!
3977 // So static Analysis is right about this being a potential NULL pointer.
3978 // However, if the array was created correcly to begin with, it should be fine.
3979 lbm_value arr_car = get_car(array);
3980 lbm_array_header_t *arr = (lbm_array_header_t*)arr_car;
3981
3982 if (lbm_is_number(ctx->r)) {
3983 ((uint8_t*)arr->data)[ix] = (uint8_t)lbm_dec_as_u32(ctx->r);
3984
3985 sptr[2] = lbm_enc_u(ix + 1);
3986 lbm_value *rptr = stack_reserve(ctx, 4);
3987 rptr[0] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3988 rptr[1] = stream;
3989 rptr[2] = lbm_enc_u(0);
3990 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3991 ctx->app_cont = true1;
3992 } else if (lbm_is_symbol(ctx->r) && ctx->r == ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u)) {
3993 lbm_uint array_size = ix / sizeof(lbm_uint);
3994
3995 if (ix % sizeof(lbm_uint) != 0) {
3996 array_size = array_size + 1;
3997 }
3998 lbm_memory_shrink((lbm_uint*)arr->data, array_size);
3999 arr->size = ix;
4000 lbm_stack_drop(&ctx->K, 4);
4001 ctx->r = array;
4002 ctx->app_cont = true1;
4003 } else {
4004 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
4005 }
4006}
4007
4008static void cont_read_append_continue(eval_context_t *ctx) {
4009 lbm_value *sptr = get_stack_ptr(ctx, 3);
4010
4011 lbm_value first_cell = sptr[0];
4012 lbm_value last_cell = sptr[1];
4013 lbm_value stream = sptr[2];
4014
4015 lbm_char_channel_t *str = lbm_dec_channel(stream);
4016 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4017 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4018 }
4019
4020 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4021
4022 switch(ctx->r) {
4023 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4024 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4025 lbm_set_cdr(last_cell, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate the list
4026 ctx->r = first_cell;
4027 } else {
4028 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4029 }
4030 lbm_stack_drop(&ctx->K, 3);
4031 /* Skip reading another token and apply the continuation */
4032 ctx->app_cont = true1;
4033 return;
4034 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4035 lbm_value *rptr = stack_reserve(ctx, 4);
4036 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4037 rptr[1] = stream;
4038 rptr[2] = lbm_enc_u(0);
4039 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4040 ctx->app_cont = true1;
4041 } return;
4042 }
4043 }
4044 lbm_value new_cell = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4045 if (lbm_is_symbol_merror(new_cell)) {
4046 lbm_channel_reader_close(str);
4047 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4048 return;
4049 }
4050 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4051 lbm_set_cdr(last_cell, new_cell);
4052 last_cell = new_cell;
4053 } else {
4054 first_cell = last_cell = new_cell;
4055 }
4056 sptr[0] = first_cell;
4057 sptr[1] = last_cell;
4058 sptr[2] = stream; // unchanged.
4059 lbm_value *rptr = stack_reserve(ctx, 4);
4060 rptr[0] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
4061 rptr[1] = stream;
4062 rptr[2] = lbm_enc_u(0);
4063 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4064 ctx->app_cont = true1;
4065}
4066
4067static void cont_read_eval_continue(eval_context_t *ctx) {
4068 lbm_value env;
4069 lbm_value stream;
4070 lbm_pop_2(&ctx->K, &env, &stream);
4071
4072 lbm_char_channel_t *str = lbm_dec_channel(stream);
4073 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4074 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4075 }
4076
4077 ctx->row1 = (lbm_int)str->row(str);
4078
4079 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4080
4081 switch(ctx->r) {
4082 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4083 ctx->app_cont = true1;
4084 return;
4085 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4086 // This case is a bit mysterious.
4087 // A dot, may in reality be an error in this location.
4088 lbm_value *rptr = stack_reserve(ctx, 4);
4089 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4090 rptr[1] = stream;
4091 rptr[2] = lbm_enc_u(0);
4092 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4093 ctx->app_cont = true1;
4094 } return;
4095 }
4096 }
4097
4098 lbm_value *rptr = stack_reserve(ctx, 6);
4099 rptr[0] = stream;
4100 rptr[1] = env;
4101 rptr[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
4102 rptr[3] = stream;
4103 rptr[4] = lbm_enc_u(1);
4104 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4105 rptr[6] = lbm_enc_u(ctx->flags);
4106 rptr[7] = POP_READER_FLAGS(((47) << 2) | 0xF8000001u);
4107 ctx->curr_env = env;
4108 ctx->curr_exp = ctx->r;
4109}
4110
4111static void cont_read_expect_closepar(eval_context_t *ctx) {
4112 lbm_value res;
4113 lbm_value stream;
4114
4115 lbm_pop_2(&ctx->K, &res, &stream);
4116
4117 lbm_char_channel_t *str = lbm_dec_channel(stream);
4118 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4119 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4120 }
4121
4122 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4123 ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u)) {
4124 ctx->r = res;
4125 ctx->app_cont = true1;
4126 } else {
4127 lbm_channel_reader_close(str);
4128 lbm_set_error_reason((char*)lbm_error_str_parse_close);
4129 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4130 }
4131}
4132
4133static void cont_read_dot_terminate(eval_context_t *ctx) {
4134 lbm_value *sptr = get_stack_ptr(ctx, 3);
4135
4136 lbm_value first_cell = sptr[0];
4137 lbm_value last_cell = sptr[1];
4138 lbm_value stream = sptr[2];
4139
4140 lbm_char_channel_t *str = lbm_dec_channel(stream);
4141 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4142 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4143 }
4144
4145 lbm_stack_drop(&ctx->K ,3);
4146
4147 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4148 (ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u) ||
4149 ctx->r == ENC_SYM_DOT(((0x76) << 4) | 0x00000000u))) {
4150 lbm_channel_reader_close(str);
4151 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4152 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4153 } else {
4154 if (lbm_is_cons(last_cell)) {
4155 lbm_set_cdr(last_cell, ctx->r);
4156 ctx->r = first_cell;
4157 lbm_value *rptr = stack_reserve(ctx, 6);
4158 rptr[0] = stream;
4159 rptr[1] = ctx->r;
4160 rptr[2] = READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u);
4161 rptr[3] = stream;
4162 rptr[4] = lbm_enc_u(0);
4163 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4164 ctx->app_cont = true1;
4165 } else {
4166 lbm_channel_reader_close(str);
4167 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4168 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4169 }
4170 }
4171}
4172
4173static void cont_read_done(eval_context_t *ctx) {
4174 lbm_value stream;
4175 lbm_value f_val;
4176 lbm_pop_2(&ctx->K, &stream ,&f_val);
4177
4178 uint32_t flags = lbm_dec_as_u32(f_val);
4179 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4180 ctx->flags |= (flags & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4181
4182 lbm_char_channel_t *str = lbm_dec_channel(stream);
4183 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4184 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4185 }
4186
4187 lbm_channel_reader_close(str);
4188 if (lbm_is_symbol(ctx->r)) {
4189 lbm_uint sym_val = lbm_dec_sym(ctx->r);
4190 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
4191 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
4192 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4193 }
4194 }
4195
4196 ctx->row0 = -1;
4197 ctx->row1 = -1;
4198 ctx->app_cont = true1;
4199}
4200
4201static void cont_read_quote_result(eval_context_t *ctx) {
4202 lbm_value cell;
4203 WITH_GC(cell, lbm_heap_allocate_list_init(2,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4204 ENC_SYM_QUOTE,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4205 ctx->r))(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
};
4206 ctx->r = cell;
4207 ctx->app_cont = true1;
4208}
4209
4210static void cont_read_commaat_result(eval_context_t *ctx) {
4211 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4212 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4213 ctx->r = cell1;
4214 ctx->app_cont = true1;
4215}
4216
4217static void cont_read_comma_result(eval_context_t *ctx) {
4218 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u),ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4219 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4220 ctx->r = cell1;
4221 ctx->app_cont = true1;
4222}
4223
4224static void cont_application_start(eval_context_t *ctx) {
4225
4226 /* sptr[0] = env
4227 * sptr[1] = args
4228 * ctx->r = function
4229 */
4230
4231 if (lbm_is_symbol(ctx->r)) {
4232 stack_reserve(ctx,1)[0] = lbm_enc_u(0);
4233 cont_application_args(ctx);
4234 } else if (lbm_is_cons(ctx->r)) {
4235 lbm_uint *sptr = get_stack_ptr(ctx, 2);
4236 lbm_value args = (lbm_value)sptr[1];
4237 switch (get_car(ctx->r)) {
4238 case ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u): {
4239 lbm_value cl[3];
4240 extract_n(get_cdr(ctx->r), cl, 3);
4241 lbm_value arg_env = (lbm_value)sptr[0];
4242 lbm_value arg0, arg_rest;
4243 get_car_and_cdr(args, &arg0, &arg_rest);
4244 sptr[1] = cl[CLO_BODY1];
4245 bool_Bool a_nil = lbm_is_symbol_nil(args);
4246 bool_Bool p_nil = lbm_is_symbol_nil(cl[CLO_PARAMS0]);
4247 lbm_value *reserved = stack_reserve(ctx, 4);
4248
4249 if (!a_nil && !p_nil) {
4250 reserved[0] = cl[CLO_ENV2];
4251 reserved[1] = cl[CLO_PARAMS0];
4252 reserved[2] = arg_rest;
4253 reserved[3] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
4254 ctx->curr_exp = arg0;
4255 ctx->curr_env = arg_env;
4256 } else if (a_nil && p_nil) {
4257 // No params, No args
4258 lbm_stack_drop(&ctx->K, 6);
4259 ctx->curr_exp = cl[CLO_BODY1];
4260 ctx->curr_env = cl[CLO_ENV2];
4261 } else if (p_nil) {
4262 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), cl[CLO_ENV2]);
4263 reserved[0] = rest_binder;
4264 reserved[1] = get_cdr(args);
4265 reserved[2] = get_car(rest_binder);
4266 reserved[3] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
4267 ctx->curr_exp = get_car(args);
4268 ctx->curr_env = arg_env;
4269 } else {
4270 lbm_set_error_reason((char*)lbm_error_str_num_args);
4271 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->r);
4272 }
4273 } break;
4274 case ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u):{
4275 /* Continuation created using call-cc.
4276 * ((SYM_CONT . cont-array) arg0 )
4277 */
4278 lbm_value c = get_cdr(ctx->r); /* should be the continuation array*/
4279
4280 if (!lbm_is_lisp_array_r(c)) {
4281 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4282 }
4283
4284 lbm_uint arg_count = lbm_list_length(args);
4285 lbm_value arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4286 switch (arg_count) {
4287 case 0:
4288 arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4289 break;
4290 case 1:
4291 arg = get_car(args);
4292 break;
4293 default:
4294 lbm_set_error_reason((char*)lbm_error_str_num_args);
4295 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4296 }
4297 lbm_stack_clear(&ctx->K);
4298
4299 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(c);
4300
4301 ctx->K.sp = arr->size / sizeof(lbm_uint);
4302 memcpy(ctx->K.data, arr->data, arr->size);
4303
4304 ctx->curr_exp = arg;
4305 break;
4306 }
4307 case ENC_SYM_MACRO(((0x10D) << 4) | 0x00000000u):{
4308 /*
4309 * Perform macro expansion.
4310 * Macro expansion is really just evaluation in an
4311 * environment augmented with the unevaluated expressions passed
4312 * as arguments.
4313 */
4314 lbm_value env = (lbm_value)sptr[0];
4315
4316 lbm_value curr_param = get_cadr(ctx->r);
4317 lbm_value curr_arg = args;
4318 lbm_value expand_env = env;
4319 while (lbm_is_cons(curr_param) &&
4320 lbm_is_cons(curr_arg)) {
4321 lbm_value car_curr_param, cdr_curr_param;
4322 lbm_value car_curr_arg, cdr_curr_arg;
4323 get_car_and_cdr(curr_param, &car_curr_param, &cdr_curr_param);
4324 get_car_and_cdr(curr_arg, &car_curr_arg, &cdr_curr_arg);
4325
4326 lbm_value entry = cons_with_gc(car_curr_param, car_curr_arg, expand_env);
4327 lbm_value aug_env = cons_with_gc(entry, expand_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4328 expand_env = aug_env;
4329
4330 curr_param = cdr_curr_param;
4331 curr_arg = cdr_curr_arg;
4332 }
4333 /* Two rounds of evaluation is performed.
4334 * First to instantiate the arguments into the macro body.
4335 * Second to evaluate the resulting program.
4336 */
4337 sptr[1] = EVAL_R(((11) << 2) | 0xF8000001u);
4338 lbm_value exp = get_cadr(get_cdr(ctx->r));
4339 ctx->curr_exp = exp;
4340 ctx->curr_env = expand_env;
4341 } break;
4342 default:
4343 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4344 }
4345 } else {
4346 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4347 }
4348}
4349
4350static void cont_eval_r(eval_context_t* ctx) {
4351 lbm_value env;
4352 lbm_pop(&ctx->K, &env);
4353 ctx->curr_exp = ctx->r;
4354 ctx->curr_env = env;
4355}
4356
4357static void cont_progn_var(eval_context_t* ctx) {
4358
4359 lbm_value key;
4360 lbm_value env;
4361
4362 lbm_pop_2(&ctx->K, &key, &env);
4363
4364 if (fill_binding_location(key, ctx->r, env) < 0) {
4365 lbm_set_error_reason("Incorrect type of name/key in let-binding");
4366 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
4367 }
4368
4369 ctx->app_cont = true1;
4370}
4371
4372static void cont_setq(eval_context_t *ctx) {
4373 lbm_value sym;
4374 lbm_value env;
4375 lbm_pop_2(&ctx->K, &sym, &env);
4376 lbm_value res;
4377 WITH_GC(res, perform_setvar(sym, ctx->r, env))(res) = (perform_setvar(sym, ctx->r, env)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (perform_setvar(sym, ctx->r, env)
); if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
4378 ctx->r = res;
4379 ctx->app_cont = true1;
4380}
4381
4382lbm_flash_status request_flash_storage_cell(lbm_value val, lbm_value *res) {
4383
4384 lbm_value flash_cell;
4385 lbm_flash_status s = lbm_allocate_const_cell(&flash_cell);
4386 if (s != LBM_FLASH_WRITE_OK)
4387 return s;
4388 lbm_value new_val = val;
4389 new_val &= ~LBM_PTR_VAL_MASK0x03FFFFFCu; // clear the value part of the ptr
4390 new_val |= (flash_cell & LBM_PTR_VAL_MASK0x03FFFFFCu);
4391 new_val |= LBM_PTR_TO_CONSTANT_BIT0x04000000u;
4392 *res = new_val;
4393 return s;
4394}
4395
4396static void cont_move_to_flash(eval_context_t *ctx) {
4397
4398 lbm_value args;
4399 lbm_pop(&ctx->K, &args);
4400
4401 if (lbm_is_symbol_nil(args)) {
4402 // Done looping over arguments. return true.
4403 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
4404 ctx->app_cont = true1;
4405 return;
4406 }
4407
4408 lbm_value first_arg, rest;
4409 get_car_and_cdr(args, &first_arg, &rest);
4410
4411 lbm_value val;
4412 if (lbm_is_symbol(first_arg) && lbm_global_env_lookup(&val, first_arg)) {
4413 // Prepare to copy the rest of the arguments when done with first.
4414 lbm_value *rptr = stack_reserve(ctx, 2);
4415 rptr[0] = rest;
4416 rptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
4417 if (lbm_is_ptr(val) &&
4418 (!(val & LBM_PTR_TO_CONSTANT_BIT0x04000000u))) {
4419 lbm_value * rptr1 = stack_reserve(ctx, 3);
4420 rptr1[0] = first_arg;
4421 rptr1[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
4422 rptr1[2] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4423 ctx->r = val;
4424 }
4425 ctx->app_cont = true1;
4426 return;
4427 }
4428 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4429}
4430
4431static void cont_move_val_to_flash_dispatch(eval_context_t *ctx) {
4432
4433 lbm_value val = ctx->r;
4434
4435 if (lbm_is_cons(val)) {
4436 lbm_value *rptr = stack_reserve(ctx, 5);
4437 rptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // fst cell of list
4438 rptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last cell of list
4439 rptr[2] = get_cdr(val);
4440 rptr[3] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4441 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4442 ctx->r = get_car(val);
4443 ctx->app_cont = true1;
4444 return;
4445 }
4446
4447 if (lbm_is_ptr(val) && (val & LBM_PTR_TO_CONSTANT_BIT0x04000000u)) {
4448 ctx->r = val;
4449 ctx->app_cont = true1;
4450 return;
4451 }
4452
4453 if (lbm_is_ptr(val)) {
4454 lbm_cons_t *ref = lbm_ref_cell(val);
4455 if (lbm_type_of(ref->cdr) == LBM_TYPE_SYMBOL0x00000000u) {
4456 switch (ref->cdr) {
4457 case ENC_SYM_RAW_I_TYPE(((0x31) << 4) | 0x00000000u): /* fall through */
4458 case ENC_SYM_RAW_U_TYPE(((0x32) << 4) | 0x00000000u):
4459 case ENC_SYM_RAW_F_TYPE(((0x33) << 4) | 0x00000000u): {
4460 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4461 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4462 handle_flash_status(write_const_car(flash_cell, ref->car));
4463 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4464 ctx->r = flash_cell;
4465 } break;
4466 case ENC_SYM_IND_I_TYPE(((0x34) << 4) | 0x00000000u): /* fall through */
4467 case ENC_SYM_IND_U_TYPE(((0x35) << 4) | 0x00000000u):
4468 case ENC_SYM_IND_F_TYPE(((0x36) << 4) | 0x00000000u): {
4469#ifndef LBM64
4470 /* 64 bit values are in lbm mem on 32bit platforms. */
4471 lbm_uint *lbm_mem_ptr = (lbm_uint*)ref->car;
4472 lbm_uint flash_ptr;
4473
4474 handle_flash_status(lbm_write_const_raw(lbm_mem_ptr, 2, &flash_ptr));
4475 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4476 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4477 handle_flash_status(write_const_car(flash_cell, flash_ptr));
4478 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4479 ctx->r = flash_cell;
4480#else
4481 // There are no indirect types in LBM64
4482 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4483#endif
4484 } break;
4485 case ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u): {
4486 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4487 lbm_uint size = arr->size / sizeof(lbm_uint);
4488 lbm_uint flash_addr;
4489 lbm_value *arrdata = (lbm_value *)arr->data;
4490 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4491 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4492 handle_flash_status(lbm_allocate_const_raw(size, &flash_addr));
4493 lift_array_flash(flash_cell,
4494 false0,
4495 (char *)flash_addr,
4496 arr->size);
4497 // Move array contents to flash recursively
4498 lbm_value *rptr = stack_reserve(ctx, 5);
4499 rptr[0] = flash_cell;
4500 rptr[1] = lbm_enc_u(0);
4501 rptr[2] = val;
4502 rptr[3] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4503 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4504 ctx->r = arrdata[0];
4505 ctx->app_cont = true1;
4506 return;
4507 }
4508 case ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u): {
4509 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4510 // arbitrary address: flash_arr.
4511 lbm_uint flash_arr;
4512 handle_flash_status(lbm_write_const_array_padded((uint8_t*)arr->data, arr->size, &flash_arr));
4513 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4514 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4515 lift_array_flash(flash_cell,
4516 true1,
4517 (char *)flash_arr,
4518 arr->size);
4519 ctx->r = flash_cell;
4520 } break;
4521 case ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u): /* fall through */
4522 case ENC_SYM_CUSTOM_TYPE(((0x38) << 4) | 0x00000000u):
4523 lbm_set_error_reason((char *)lbm_error_str_flash_not_possible);
4524 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4525 }
4526 } else {
4527 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4528 }
4529 ctx->app_cont = true1;
4530 return;
4531 }
4532 ctx->r = val;
4533 ctx->app_cont = true1;
4534}
4535
4536static void cont_move_list_to_flash(eval_context_t *ctx) {
4537
4538 // ctx->r holds the value that should go in car
4539
4540 lbm_value *sptr = get_stack_ptr(ctx, 3);
4541
4542 lbm_value fst = sptr[0];
4543 lbm_value lst = sptr[1];
4544 lbm_value val = sptr[2];
4545
4546
4547 lbm_value new_lst = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4548 // Allocate element ptr storage after storing the element to flash.
4549 handle_flash_status(request_flash_storage_cell(lbm_enc_cons_ptr(LBM_PTR_NULL(0x03FFFFFCu >> 2)), &new_lst));
4550
4551 if (lbm_is_symbol_nil(fst)) {
4552 lst = new_lst;
4553 fst = new_lst;
4554 handle_flash_status(write_const_car(lst, ctx->r));
4555 } else {
4556 handle_flash_status(write_const_cdr(lst, new_lst)); // low before high
4557 handle_flash_status(write_const_car(new_lst, ctx->r));
4558 lst = new_lst;
4559 }
4560
4561 if (lbm_is_cons(val)) {
4562 sptr[0] = fst;
4563 sptr[1] = lst;//rest_cell;
4564 sptr[2] = get_cdr(val);
4565 lbm_value *rptr = stack_reserve(ctx, 2);
4566 rptr[0] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4567 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4568 ctx->r = get_car(val);
4569 } else {
4570 sptr[0] = fst;
4571 sptr[1] = lst;
4572 sptr[2] = CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u);
4573 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4574 ctx->r = val;
4575 }
4576 ctx->app_cont = true1;
4577}
4578
4579static void cont_close_list_in_flash(eval_context_t *ctx) {
4580 lbm_value fst;
4581 lbm_value lst;
4582 lbm_pop_2(&ctx->K, &lst, &fst);
4583 lbm_value val = ctx->r;
4584 handle_flash_status(write_const_cdr(lst, val));
4585 ctx->r = fst;
4586 ctx->app_cont = true1;
4587}
4588
4589static void cont_move_array_elts_to_flash(eval_context_t *ctx) {
4590 lbm_value *sptr = get_stack_ptr(ctx, 3);
4591 // sptr[2] = source array in RAM
4592 // sptr[1] = current index
4593 // sptr[0] = target array in flash
4594 lbm_array_header_t *src_arr = (lbm_array_header_t*)get_car(sptr[2]);
4595 lbm_uint size = src_arr->size / sizeof(lbm_uint);
4596 lbm_value *srcdata = (lbm_value *)src_arr->data;
4597
4598 lbm_array_header_t *tgt_arr = (lbm_array_header_t*)get_car(sptr[0]);
4599 lbm_uint *tgtdata = (lbm_value *)tgt_arr->data;
4600 lbm_uint ix = lbm_dec_as_u32(sptr[1]);
4601 handle_flash_status(lbm_const_write(&tgtdata[ix], ctx->r));
4602 if (ix >= size-1) {
4603 ctx->r = sptr[0];
4604 lbm_stack_drop(&ctx->K, 3);
4605 ctx->app_cont = true1;
4606 return;
4607 }
4608 sptr[1] = lbm_enc_u(ix + 1);
4609 lbm_value *rptr = stack_reserve(ctx, 2);
4610 rptr[0] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4611 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4612 ctx->r = srcdata[ix+1];
4613 ctx->app_cont = true1;
4614 return;
4615}
4616
4617static void cont_qq_expand_start(eval_context_t *ctx) {
4618 lbm_value *rptr = stack_reserve(ctx, 2);
4619 rptr[0] = ctx->r;
4620 rptr[1] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4621 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4622 ctx->app_cont = true1;
4623}
4624
4625lbm_value quote_it(lbm_value qquoted) {
4626 if (lbm_is_symbol(qquoted) &&
4627 lbm_is_special(qquoted)) return qquoted;
4628
4629 lbm_value val = cons_with_gc(qquoted, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4630 return cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4631}
4632
4633bool_Bool is_append(lbm_value a) {
4634 return (lbm_is_cons(a) &&
4635 lbm_is_symbol(get_car(a)) &&
4636 (get_car(a) == ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u)));
4637}
4638
4639lbm_value append(lbm_value front, lbm_value back) {
4640 if (lbm_is_symbol_nil(front)) return back;
4641 if (lbm_is_symbol_nil(back)) return front;
4642
4643 if (lbm_is_quoted_list(front) &&
4644 lbm_is_quoted_list(back)) {
4645 lbm_value f = get_cadr(front);
4646 lbm_value b = get_cadr(back);
4647 return quote_it(lbm_list_append(f, b));
4648 }
4649
4650 if (is_append(back) &&
4651 lbm_is_quoted_list(get_cadr(back)) &&
4652 lbm_is_quoted_list(front)) {
4653 lbm_value ql = get_cadr(back);
4654 lbm_value f = get_cadr(front);
4655 lbm_value b = get_cadr(ql);
4656
4657 lbm_value v = lbm_list_append(f, b);
4658 lbm_set_car(get_cdr(ql), v);
4659 return back;
4660 }
4661
4662 if (is_append(back)) {
4663 back = get_cdr(back);
4664 lbm_value new = cons_with_gc(front, back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4665 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), new, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4666 }
4667
4668 lbm_value t0, t1;
4669
4670 t0 = cons_with_gc(back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), front);
4671 t1 = cons_with_gc(front, t0, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4672 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), t1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4673}
4674
4675/* Bawden's qq-expand implementation
4676(define (qq-expand x)
4677 (cond ((tag-comma? x)
4678 (tag-data x))
4679 ((tag-comma-atsign? x)
4680 (error "Illegal"))
4681 ((tag-backquote? x)
4682 (qq-expand
4683 (qq-expand (tag-data x))))
4684 ((pair? x)
4685 `(append
4686 ,(qq-expand-list (car x))
4687 ,(qq-expand (cdr x))))
4688 (else `',x)))
4689 */
4690static void cont_qq_expand(eval_context_t *ctx) {
4691 lbm_value qquoted;
4692 lbm_pop(&ctx->K, &qquoted);
4693
4694 switch(lbm_type_of(qquoted)) {
4695 case LBM_TYPE_CONS0x10000000u: {
4696 lbm_value car_val = get_car(qquoted);
4697 lbm_value cdr_val = get_cdr(qquoted);
4698 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4699 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4700 ctx->r = append(ctx->r, get_car(cdr_val));
4701 ctx->app_cont = true1;
4702 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4703 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4704 error_ctx(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u));
4705 } else {
4706 lbm_value *rptr = stack_reserve(ctx, 6);
4707 rptr[0] = ctx->r;
4708 rptr[1] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4709 rptr[2] = cdr_val;
4710 rptr[3] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4711 rptr[4] = car_val;
4712 rptr[5] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4713 ctx->app_cont = true1;
4714 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4715 }
4716
4717 } break;
4718 default: {
4719 lbm_value res = quote_it(qquoted);
4720 ctx->r = append(ctx->r, res);
4721 ctx->app_cont = true1;
4722 }
4723 }
4724}
4725
4726static void cont_qq_append(eval_context_t *ctx) {
4727 lbm_value head;
4728 lbm_pop(&ctx->K, &head);
4729 ctx->r = append(head, ctx->r);
4730 ctx->app_cont = true1;
4731}
4732
4733/* Bawden's qq-expand-list implementation
4734(define (qq-expand-list x)
4735 (cond ((tag-comma? x)
4736 `(list ,(tag-data x)))
4737 ((tag-comma-atsign? x)
4738 (tag-data x))
4739 ((tag-backquote? x)
4740 (qq-expand-list
4741 (qq-expand (tag-data x))))
4742 ((pair? x)
4743 `(list
4744 (append
4745 ,(qq-expand-list (car x))
4746 ,(qq-expand (cdr x)))))
4747 (else `'(,x))))
4748*/
4749
4750static void cont_qq_expand_list(eval_context_t* ctx) {
4751 lbm_value l;
4752 lbm_pop(&ctx->K, &l);
4753
4754 ctx->app_cont = true1;
4755 switch(lbm_type_of(l)) {
4756 case LBM_TYPE_CONS0x10000000u: {
4757 lbm_value car_val = get_car(l);
4758 lbm_value cdr_val = get_cdr(l);
4759 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4760 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4761 lbm_value tl = cons_with_gc(get_car(cdr_val), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4762 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4763 ctx->r = append(ctx->r, tmp);
4764 return;
4765 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4766 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4767 ctx->r = get_car(cdr_val);
4768 return;
4769 } else {
4770 lbm_value *rptr = stack_reserve(ctx, 7);
4771 rptr[0] = QQ_LIST(((39) << 2) | 0xF8000001u);
4772 rptr[1] = ctx->r;
4773 rptr[2] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4774 rptr[3] = cdr_val;
4775 rptr[4] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4776 rptr[5] = car_val;
4777 rptr[6] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4778 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4779 }
4780
4781 } break;
4782 default: {
4783 lbm_value a_list = cons_with_gc(l, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4784 lbm_value tl = cons_with_gc(a_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4785 lbm_value tmp = cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4786 ctx->r = append(ctx->r, tmp);
4787 }
4788 }
4789}
4790
4791static void cont_qq_list(eval_context_t *ctx) {
4792 lbm_value val = ctx->r;
4793 lbm_value apnd_app = cons_with_gc(val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4794 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), apnd_app, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4795 ctx->r = tmp;
4796 ctx->app_cont = true1;
4797}
4798
4799static void cont_kill(eval_context_t *ctx) {
4800 (void) ctx;
4801 finish_ctx();
4802}
4803
4804static void cont_pop_reader_flags(eval_context_t *ctx) {
4805 lbm_value flags;
4806 lbm_pop(&ctx->K, &flags);
4807 ctx->flags = ctx->flags & ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4808 ctx->flags |= (lbm_dec_as_u32(flags) & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4809 // r is unchanged.
4810 ctx->app_cont = true1;
4811}
4812
4813static void cont_exception_handler(eval_context_t *ctx) {
4814 lbm_value *sptr = pop_stack_ptr(ctx, 2);
4815 lbm_value retval = sptr[0];
4816 lbm_value flags = sptr[1];
4817 lbm_set_car(get_cdr(retval), ctx->r);
4818 ctx->flags = flags;
4819 ctx->r = retval;
4820 ctx->app_cont = true1;
4821}
4822
4823/*********************************************************/
4824/* Continuations table */
4825typedef void (*cont_fun)(eval_context_t *);
4826
4827static const cont_fun continuations[NUM_CONTINUATIONS49] =
4828 { advance_ctx, // CONT_DONE
4829 cont_set_global_env,
4830 cont_bind_to_key_rest,
4831 cont_if,
4832 cont_progn_rest,
4833 cont_application_args,
4834 cont_and,
4835 cont_or,
4836 cont_wait,
4837 cont_match,
4838 cont_application_start,
4839 cont_eval_r,
4840 cont_resume,
4841 cont_closure_application_args,
4842 cont_exit_atomic,
4843 cont_read_next_token,
4844 cont_read_append_continue,
4845 cont_read_eval_continue,
4846 cont_read_expect_closepar,
4847 cont_read_dot_terminate,
4848 cont_read_done,
4849 cont_read_quote_result,
4850 cont_read_commaat_result,
4851 cont_read_comma_result,
4852 cont_read_start_array,
4853 cont_read_append_array,
4854 cont_map,
4855 cont_match_guard,
4856 cont_terminate,
4857 cont_progn_var,
4858 cont_setq,
4859 cont_move_to_flash,
4860 cont_move_val_to_flash_dispatch,
4861 cont_move_list_to_flash,
4862 cont_close_list_in_flash,
4863 cont_qq_expand_start,
4864 cont_qq_expand,
4865 cont_qq_append,
4866 cont_qq_expand_list,
4867 cont_qq_list,
4868 cont_kill,
4869 cont_loop,
4870 cont_loop_condition,
4871 cont_merge_rest,
4872 cont_merge_layer,
4873 cont_closure_args_rest,
4874 cont_move_array_elts_to_flash,
4875 cont_pop_reader_flags,
4876 cont_exception_handler
4877 };
4878
4879/*********************************************************/
4880/* Evaluators lookup table (special forms) */
4881typedef void (*evaluator_fun)(eval_context_t *);
4882
4883static const evaluator_fun evaluators[] =
4884 {
4885 eval_quote,
4886 eval_define,
4887 eval_progn,
4888 eval_lambda,
4889 eval_if,
4890 eval_let,
4891 eval_and,
4892 eval_or,
4893 eval_match,
4894 eval_receive,
4895 eval_receive_timeout,
4896 eval_callcc,
4897 eval_atomic,
4898 eval_selfevaluating, // macro
4899 eval_selfevaluating, // cont
4900 eval_selfevaluating, // closure
4901 eval_cond,
4902 eval_app_cont,
4903 eval_var,
4904 eval_setq,
4905 eval_move_to_flash,
4906 eval_loop,
4907 eval_trap
4908 };
4909
4910
4911/*********************************************************/
4912/* Evaluator step function */
4913
4914static void evaluation_step(void){
4915 eval_context_t *ctx = ctx_running;
4916#ifdef VISUALIZE_HEAP
4917 heap_vis_gen_image();
4918#endif
4919
4920 if (ctx->app_cont) {
4921 lbm_value k;
4922 lbm_pop(&ctx->K, &k);
4923 ctx->app_cont = false0;
4924
4925 lbm_uint decoded_k = DEC_CONTINUATION(k)(((k) & ~0xF8000001u) >> 2);
4926
4927 if (decoded_k < NUM_CONTINUATIONS49) {
4928 continuations[decoded_k](ctx);
4929 } else {
4930 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4931 }
4932 return;
4933 }
4934
4935 if (lbm_is_symbol(ctx->curr_exp)) {
4936 eval_symbol(ctx);
4937 return;
4938 }
4939 if (lbm_is_cons(ctx->curr_exp)) {
4940 lbm_cons_t *cell = lbm_ref_cell(ctx->curr_exp);
4941 lbm_value h = cell->car;
4942 if (lbm_is_symbol(h) && ((h & ENC_SPECIAL_FORMS_MASK0xFFFFF000) == ENC_SPECIAL_FORMS_BIT0x00001000)) {
4943 lbm_uint eval_index = lbm_dec_sym(h) & SPECIAL_FORMS_INDEX_MASK0x000000FF;
4944 evaluators[eval_index](ctx);
4945 return;
4946 }
4947 /*
4948 * At this point head can be anything. It should evaluate
4949 * into a form that can be applied (closure, symbol, ...) though.
4950 */
4951 lbm_value *reserved = stack_reserve(ctx, 3);
4952 reserved[0] = ctx->curr_env;
4953 reserved[1] = cell->cdr;
4954 reserved[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
4955 ctx->curr_exp = h; // evaluate the function
4956 return;
4957 }
4958
4959 eval_selfevaluating(ctx);
4960 return;
4961}
4962
4963void lbm_pause_eval(void ) {
4964 eval_cps_next_state_arg = 0;
4965 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4966 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4967}
4968
4969void lbm_pause_eval_with_gc(uint32_t num_free) {
4970 eval_cps_next_state_arg = num_free;
4971 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4972 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4973}
4974
4975void lbm_continue_eval(void) {
4976 eval_cps_next_state = EVAL_CPS_STATE_RUNNING2;
4977 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4978}
4979
4980void lbm_kill_eval(void) {
4981 eval_cps_next_state = EVAL_CPS_STATE_KILL4;
4982 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4983}
4984
4985uint32_t lbm_get_eval_state(void) {
4986 return eval_cps_run_state;
4987}
4988
4989// Will wake up thread that is sleeping as well.
4990// Not sure this is good behavior.
4991static void handle_event_unblock_ctx(lbm_cid cid, lbm_value v) {
4992 eval_context_t *found = NULL((void*)0);
4993 mutex_lock(&qmutex);
4994
4995 found = lookup_ctx_nm(&blocked, cid);
4996 if (found) {
4997 drop_ctx_nm(&blocked,found);
4998 if (lbm_is_error(v)) {
4999 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
5000 found->app_cont = true1;
5001 }
5002 found->r = v;
5003 enqueue_ctx_nm(&queue,found);
5004 }
5005 mutex_unlock(&qmutex);
5006}
5007
5008static void handle_event_define(lbm_value key, lbm_value val) {
5009 lbm_uint dec_key = lbm_dec_sym(key);
5010 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
5011 lbm_value *global_env = lbm_get_global_env();
5012 lbm_uint orig_env = global_env[ix_key];
5013 lbm_value new_env;
5014 // A key is a symbol and should not need to be remembered.
5015 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
5016
5017 global_env[ix_key] = new_env;
5018}
5019
5020static lbm_value get_event_value(lbm_event_t *e) {
5021 lbm_value v;
5022 if (e->buf_len > 0) {
5023 lbm_flat_value_t fv;
5024 fv.buf = (uint8_t*)e->buf_ptr;
5025 fv.buf_size = e->buf_len;
5026 fv.buf_pos = 0;
5027 if (!lbm_unflatten_value(&fv, &v)) {
5028 lbm_set_flags(LBM_FLAG_HANDLER_EVENT_DELIVERY_FAILED(1 << 1));
5029 v = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
5030 }
5031 // Free the flat value buffer. GC is unaware of its existence.
5032 lbm_free(fv.buf);
5033 } else {
5034 v = (lbm_value)e->buf_ptr;
5035 }
5036 return v;
5037}
5038
5039static void process_events(void) {
5040
5041 if (!lbm_events) return;
5042 lbm_event_t e;
5043
5044 while (lbm_event_pop(&e)) {
5045
5046 lbm_value event_val = get_event_value(&e);
5047 switch(e.type) {
5048 case LBM_EVENT_UNBLOCK_CTX:
5049 handle_event_unblock_ctx((lbm_cid)e.parameter, event_val);
5050 break;
5051 case LBM_EVENT_DEFINE:
5052 handle_event_define((lbm_value)e.parameter, event_val);
5053 break;
5054 case LBM_EVENT_FOR_HANDLER:
5055 if (lbm_event_handler_pid >= 0) {
5056 lbm_find_receiver_and_send(lbm_event_handler_pid, event_val);
5057 }
5058 break;
5059 }
5060 }
5061}
5062
5063/* eval_cps_run can be paused
5064 I think it would be better use a mailbox for
5065 communication between other threads and the run_eval
5066 but for now a set of variables will be used. */
5067void lbm_run_eval(void){
5068
5069 if (setjmp(critical_error_jmp_buf)_setjmp (critical_error_jmp_buf) > 0) {
5070 printf_callback("GC stack overflow!\n");
5071 critical_error_callback();
5072 // terminate evaluation thread.
5073 return;
5074 }
5075
5076 setjmp(error_jmp_buf)_setjmp (error_jmp_buf);
5077
5078 while (eval_running) {
5079 if (eval_cps_state_changed || eval_cps_run_state == EVAL_CPS_STATE_PAUSED1) {
5080 eval_cps_state_changed = false0;
5081 switch (eval_cps_next_state) {
5082 case EVAL_CPS_STATE_PAUSED1:
5083 if (eval_cps_run_state != EVAL_CPS_STATE_PAUSED1) {
5084 if (lbm_heap_num_free() < eval_cps_next_state_arg) {
5085 gc();
5086 }
5087 eval_cps_next_state_arg = 0;
5088 }
5089 eval_cps_run_state = EVAL_CPS_STATE_PAUSED1;
5090 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5091 continue; /* jump back to start of eval_running loop */
5092 case EVAL_CPS_STATE_KILL4:
5093 eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
5094 eval_running = false0;
5095 continue;
5096 default: // running state
5097 eval_cps_run_state = eval_cps_next_state;
5098 break;
5099 }
5100 }
5101 while (true1) {
5102 if (eval_steps_quota && ctx_running) {
5103 eval_steps_quota--;
5104 evaluation_step();
5105 } else {
5106 if (eval_cps_state_changed) break;
5107 eval_steps_quota = eval_steps_refill;
5108 if (is_atomic) {
5109 if (!ctx_running) {
5110 lbm_set_flags(LBM_FLAG_ATOMIC_MALFUNCTION(1 << 0));
5111 is_atomic = 0;
5112 }
5113 } else {
5114 if (gc_requested) {
5115 gc();
5116 }
5117 process_events();
5118 mutex_lock(&qmutex);
5119 if (ctx_running) {
5120 enqueue_ctx_nm(&queue, ctx_running);
5121 ctx_running = NULL((void*)0);
5122 }
5123 wake_up_ctxs_nm();
5124 ctx_running = dequeue_ctx_nm(&queue);
5125 mutex_unlock(&qmutex);
5126 if (!ctx_running) {
5127 lbm_system_sleeping = true1;
5128 //Fixed sleep interval to poll events regularly.
5129 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5130 lbm_system_sleeping = false0;
5131 }
5132 }
5133 }
5134 }
5135 }
5136}
5137
5138lbm_cid lbm_eval_program(lbm_value lisp) {
5139 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), 256, NULL((void*)0));
5140}
5141
5142lbm_cid lbm_eval_program_ext(lbm_value lisp, unsigned int stack_size) {
5143 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), stack_size, NULL((void*)0));
5144}
5145
5146int lbm_eval_init() {
5147 if (!qmutex_initialized) {
5148 mutex_init(&qmutex);
5149 qmutex_initialized = true1;
5150 }
5151 if (!lbm_events_mutex_initialized) {
5152 mutex_init(&lbm_events_mutex);
5153 lbm_events_mutex_initialized = true1;
5154 }
5155 if (!blocking_extension_mutex_initialized) {
5156 mutex_init(&blocking_extension_mutex);
5157 blocking_extension_mutex_initialized = true1;
5158 }
5159
5160 mutex_lock(&qmutex);
5161 mutex_lock(&lbm_events_mutex);
5162
5163 blocked.first = NULL((void*)0);
5164 blocked.last = NULL((void*)0);
5165 queue.first = NULL((void*)0);
5166 queue.last = NULL((void*)0);
5167 ctx_running = NULL((void*)0);
5168
5169 eval_cps_run_state = EVAL_CPS_STATE_RUNNING2;
5170
5171 mutex_unlock(&lbm_events_mutex);
5172 mutex_unlock(&qmutex);
5173
5174 if (!lbm_init_env()) return 0;
5175 eval_running = true1;
5176 return 1;
5177}
5178
5179bool_Bool lbm_eval_init_events(unsigned int num_events) {
5180
5181 mutex_lock(&lbm_events_mutex);
5182 lbm_events = (lbm_event_t*)lbm_malloc(num_events * sizeof(lbm_event_t));
5183 bool_Bool r = false0;
5184 if (lbm_events) {
5185 lbm_events_max = num_events;
5186 lbm_events_head = 0;
5187 lbm_events_tail = 0;
5188 lbm_events_full = false0;
5189 lbm_event_handler_pid = -1;
5190 r = true1;
5191 }
5192 mutex_unlock(&lbm_events_mutex);
5193 return r;
5194}
diff --git a/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-cb7c37.html b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-cb7c37.html new file mode 100644 index 00000000..6c385925 --- /dev/null +++ b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-cb7c37.html @@ -0,0 +1,6545 @@ + + + +src/eval_cps.c + + + + + + + + + + + + + + + + + + + + + + + + + + +

Bug Summary

+ + + + +
File:eval_cps.c
Warning:line 3983, column 16
Access to field 'data' results in a dereference of a null pointer (loaded from variable 'arr')
+ +

Annotated Source Code

+

Press '?' + to see keyboard shortcuts

+ + +
clang -cc1 -triple i386-pc-linux-gnu -analyze -disable-free -disable-llvm-verifier -discard-value-names -main-file-name eval_cps.c -analyzer-store=region -analyzer-opt-analyze-nested-blocks -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -mrelocation-model static -mthread-model posix -mframe-pointer=none -fmath-errno -fno-rounding-math -masm-verbose -mconstructor-aliases -target-cpu i686 -dwarf-column-info -fno-split-dwarf-inlining -debugger-tuning=gdb -resource-dir /usr/lib/llvm-10/lib/clang/10.0.0 -I ./include -I ./include/extensions -I platform/linux/include -D _PRELUDE -internal-isystem /usr/local/include -internal-isystem /usr/lib/llvm-10/lib/clang/10.0.0/include -internal-externc-isystem /usr/include/i386-linux-gnu -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -std=c99 -fdebug-compilation-dir /home/joels/Current/lispbm -ferror-limit 19 -fmessage-length 0 -fgnuc-version=4.2.1 -fobjc-runtime=gcc -fdiagnostics-show-option -vectorize-loops -vectorize-slp -analyzer-output=html -faddrsig -o /home/joels/Current/lispbm/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1 -x c src/eval_cps.c +
+ + + +
+ + +
+ + + + +
+

src/eval_cps.c

+
→
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1/*
2 Copyright 2018, 2020 - 2024 Joel Svensson svenssonjoel@yahoo.se
3
4 This program is free software: you can redistribute it and/or modify
5 it under the terms of the GNU General Public License as published by
6 the Free Software Foundation, either version 3 of the License, or
7 (at your option) any later version.
8
9 This program is distributed in the hope that it will be useful,
10 but WITHOUT ANY WARRANTY; without even the implied warranty of
11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 GNU General Public License for more details.
13
14 You should have received a copy of the GNU General Public License
15 along with this program. If not, see <http://www.gnu.org/licenses/>.
16*/
17
18#include <lbm_memory.h>
19#include <lbm_types.h>
20#include "symrepr.h"
21#include "heap.h"
22#include "env.h"
23#include "eval_cps.h"
24#include "stack.h"
25#include "fundamental.h"
26#include "extensions.h"
27#include "tokpar.h"
28#include "lbm_channel.h"
29#include "print.h"
30#include "platform_mutex.h"
31#include "lbm_flat_value.h"
32#include "lbm_flags.h"
33
34#ifdef VISUALIZE_HEAP
35#include "heap_vis.h"
36#endif
37
38#include <setjmp.h>
39#include <stdarg.h>
40
41static jmp_buf error_jmp_buf;
42static jmp_buf critical_error_jmp_buf;
43
44#define S_TO_US(X)(lbm_uint)((X) * 1000000) (lbm_uint)((X) * 1000000)
45
46#define DEC_CONTINUATION(x)(((x) & ~0xF8000001u) >> 2) (((x) & ~LBM_CONTINUATION_INTERNAL0xF8000001u) >> LBM_ADDRESS_SHIFT2)
47#define IS_CONTINUATION(x)(((x) & 0xF8000001u) == 0xF8000001u) (((x) & LBM_CONTINUATION_INTERNAL0xF8000001u) == LBM_CONTINUATION_INTERNAL0xF8000001u)
48#define CONTINUATION(x)(((x) << 2) | 0xF8000001u) (((x) << LBM_ADDRESS_SHIFT2) | LBM_CONTINUATION_INTERNAL0xF8000001u)
49
50#define DONE(((0) << 2) | 0xF8000001u) CONTINUATION(0)(((0) << 2) | 0xF8000001u)
51#define SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u) CONTINUATION(1)(((1) << 2) | 0xF8000001u)
52#define BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u) CONTINUATION(2)(((2) << 2) | 0xF8000001u)
53#define IF(((3) << 2) | 0xF8000001u) CONTINUATION(3)(((3) << 2) | 0xF8000001u)
54#define PROGN_REST(((4) << 2) | 0xF8000001u) CONTINUATION(4)(((4) << 2) | 0xF8000001u)
55#define APPLICATION_ARGS(((5) << 2) | 0xF8000001u) CONTINUATION(5)(((5) << 2) | 0xF8000001u)
56#define AND(((6) << 2) | 0xF8000001u) CONTINUATION(6)(((6) << 2) | 0xF8000001u)
57#define OR(((7) << 2) | 0xF8000001u) CONTINUATION(7)(((7) << 2) | 0xF8000001u)
58#define WAIT(((8) << 2) | 0xF8000001u) CONTINUATION(8)(((8) << 2) | 0xF8000001u)
59#define MATCH(((9) << 2) | 0xF8000001u) CONTINUATION(9)(((9) << 2) | 0xF8000001u)
60#define APPLICATION_START(((10) << 2) | 0xF8000001u) CONTINUATION(10)(((10) << 2) | 0xF8000001u)
61#define EVAL_R(((11) << 2) | 0xF8000001u) CONTINUATION(11)(((11) << 2) | 0xF8000001u)
62#define RESUME(((12) << 2) | 0xF8000001u) CONTINUATION(12)(((12) << 2) | 0xF8000001u)
63#define CLOSURE_ARGS(((13) << 2) | 0xF8000001u) CONTINUATION(13)(((13) << 2) | 0xF8000001u)
64#define EXIT_ATOMIC(((14) << 2) | 0xF8000001u) CONTINUATION(14)(((14) << 2) | 0xF8000001u)
65#define READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u) CONTINUATION(15)(((15) << 2) | 0xF8000001u)
66#define READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u) CONTINUATION(16)(((16) << 2) | 0xF8000001u)
67#define READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u) CONTINUATION(17)(((17) << 2) | 0xF8000001u)
68#define READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u) CONTINUATION(18)(((18) << 2) | 0xF8000001u)
69#define READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u) CONTINUATION(19)(((19) << 2) | 0xF8000001u)
70#define READ_DONE(((20) << 2) | 0xF8000001u) CONTINUATION(20)(((20) << 2) | 0xF8000001u)
71#define READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u) CONTINUATION(21)(((21) << 2) | 0xF8000001u)
72#define READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u) CONTINUATION(22)(((22) << 2) | 0xF8000001u)
73#define READ_COMMA_RESULT(((23) << 2) | 0xF8000001u) CONTINUATION(23)(((23) << 2) | 0xF8000001u)
74#define READ_START_ARRAY(((24) << 2) | 0xF8000001u) CONTINUATION(24)(((24) << 2) | 0xF8000001u)
75#define READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u) CONTINUATION(25)(((25) << 2) | 0xF8000001u)
76#define MAP(((26) << 2) | 0xF8000001u) CONTINUATION(26)(((26) << 2) | 0xF8000001u)
77#define MATCH_GUARD(((27) << 2) | 0xF8000001u) CONTINUATION(27)(((27) << 2) | 0xF8000001u)
78#define TERMINATE(((28) << 2) | 0xF8000001u) CONTINUATION(28)(((28) << 2) | 0xF8000001u)
79#define PROGN_VAR(((29) << 2) | 0xF8000001u) CONTINUATION(29)(((29) << 2) | 0xF8000001u)
80#define SETQ(((30) << 2) | 0xF8000001u) CONTINUATION(30)(((30) << 2) | 0xF8000001u)
81#define MOVE_TO_FLASH(((31) << 2) | 0xF8000001u) CONTINUATION(31)(((31) << 2) | 0xF8000001u)
82#define MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u) CONTINUATION(32)(((32) << 2) | 0xF8000001u)
83#define MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u) CONTINUATION(33)(((33) << 2) | 0xF8000001u)
84#define CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u) CONTINUATION(34)(((34) << 2) | 0xF8000001u)
85#define QQ_EXPAND_START(((35) << 2) | 0xF8000001u) CONTINUATION(35)(((35) << 2) | 0xF8000001u)
86#define QQ_EXPAND(((36) << 2) | 0xF8000001u) CONTINUATION(36)(((36) << 2) | 0xF8000001u)
87#define QQ_APPEND(((37) << 2) | 0xF8000001u) CONTINUATION(37)(((37) << 2) | 0xF8000001u)
88#define QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u) CONTINUATION(38)(((38) << 2) | 0xF8000001u)
89#define QQ_LIST(((39) << 2) | 0xF8000001u) CONTINUATION(39)(((39) << 2) | 0xF8000001u)
90#define KILL(((40) << 2) | 0xF8000001u) CONTINUATION(40)(((40) << 2) | 0xF8000001u)
91#define LOOP(((41) << 2) | 0xF8000001u) CONTINUATION(41)(((41) << 2) | 0xF8000001u)
92#define LOOP_CONDITION(((42) << 2) | 0xF8000001u) CONTINUATION(42)(((42) << 2) | 0xF8000001u)
93#define MERGE_REST(((43) << 2) | 0xF8000001u) CONTINUATION(43)(((43) << 2) | 0xF8000001u)
94#define MERGE_LAYER(((44) << 2) | 0xF8000001u) CONTINUATION(44)(((44) << 2) | 0xF8000001u)
95#define CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u) CONTINUATION(45)(((45) << 2) | 0xF8000001u)
96#define MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u) CONTINUATION(46)(((46) << 2) | 0xF8000001u)
97#define POP_READER_FLAGS(((47) << 2) | 0xF8000001u) CONTINUATION(47)(((47) << 2) | 0xF8000001u)
98#define EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u) CONTINUATION(48)(((48) << 2) | 0xF8000001u)
99#define NUM_CONTINUATIONS49 49
100
101#define FM_NEED_GC-1 -1
102#define FM_NO_MATCH-2 -2
103#define FM_PATTERN_ERROR-3 -3
104
105typedef enum {
106 BL_OK = 0,
107 BL_NO_MEMORY,
108 BL_INCORRECT_KEY
109} binding_location_status;
110
111#define FB_OK0 0
112#define FB_TYPE_ERROR-1 -1
113
114const char* lbm_error_str_parse_eof = "End of parse stream.";
115const char* lbm_error_str_parse_dot = "Incorrect usage of '.'.";
116const char* lbm_error_str_parse_close = "Expected closing parenthesis.";
117const char* lbm_error_str_num_args = "Incorrect number of arguments.";
118const char* lbm_error_str_forbidden_in_atomic = "Operation is forbidden in an atomic block.";
119const char* lbm_error_str_no_number = "Argument(s) must be a number.";
120const char* lbm_error_str_not_a_boolean = "Argument must be t or nil (true or false).";
121const char* lbm_error_str_incorrect_arg = "Incorrect argument.";
122const char* lbm_error_str_var_outside_progn = "Usage of var outside of progn.";
123const char* lbm_error_str_flash_not_possible = "Value cannot be written to flash.";
124const char* lbm_error_str_flash_error = "Error writing to flash.";
125const char* lbm_error_str_flash_full = "Flash memory is full.";
126const char* lbm_error_str_variable_not_bound = "Variable not bound.";
127
128static lbm_value lbm_error_suspect;
129static bool_Bool lbm_error_has_suspect = false0;
130#ifdef LBM_ALWAYS_GC
131
132#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
133 gc(); \
134 (y) = (x); \
135 if (lbm_is_symbol_merror((y))) { \
136 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
137 }
138
139#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
140 lbm_gc_mark_phase(r); \
141 gc(); \
142 (y) = (x); \
143 if (lbm_is_symbol_merror((y))) { \
144 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
145 }
146
147#else
148
149#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
150 (y) = (x); \
151 if (lbm_is_symbol_merror((y))) { \
152 gc(); \
153 (y) = (x); \
154 if (lbm_is_symbol_merror((y))) { \
155 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
156 } \
157 /* continue executing statements below */ \
158 }
159#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
160 (y) = (x); \
161 if (lbm_is_symbol_merror((y))) { \
162 lbm_gc_mark_phase(r); \
163 gc(); \
164 (y) = (x); \
165 if (lbm_is_symbol_merror((y))) { \
166 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
167 } \
168 /* continue executing statements below */ \
169 }
170
171#endif
172
173typedef struct {
174 eval_context_t *first;
175 eval_context_t *last;
176} eval_context_queue_t;
177
178#ifdef CLEAN_UP_CLOSURES
179static lbm_value clean_cl_env_symbol = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
180#endif
181
182static int gc(void);
183static void error_ctx(lbm_value);
184static void error_at_ctx(lbm_value err_val, lbm_value at);
185static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx);
186static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail);
187
188// The currently executing context.
189eval_context_t *ctx_running = NULL((void*)0);
190volatile bool_Bool lbm_system_sleeping = false0;
191
192static volatile bool_Bool gc_requested = false0;
193void lbm_request_gc(void) {
194 gc_requested = true1;
195}
196
197/*
198 On ChibiOs the CH_CFG_ST_FREQUENCY setting in chconf.h sets the
199 resolution of the timer used for sleep operations. If this is set
200 to 10KHz the resolution is 100us.
201
202 The CH_CFG_ST_TIMEDELTA specifies the minimum number of ticks that
203 can be safely specified in a timeout directive (wonder if that
204 means sleep-period). The timedelta is set to 2.
205
206 If I have understood these correctly it means that the minimum
207 sleep duration possible is 2 * 100us = 200us.
208*/
209
210#define EVAL_CPS_DEFAULT_STACK_SIZE256 256
211#define EVAL_CPS_MIN_SLEEP200 200
212#define EVAL_STEPS_QUOTA10 10
213
214static volatile uint32_t eval_steps_refill = EVAL_STEPS_QUOTA10;
215static uint32_t eval_steps_quota = EVAL_STEPS_QUOTA10;
216
217void lbm_set_eval_step_quota(uint32_t quota) {
218 eval_steps_refill = quota;
219}
220
221static uint32_t eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
222static volatile uint32_t eval_cps_next_state = EVAL_CPS_STATE_NONE0;
223static volatile uint32_t eval_cps_next_state_arg = 0;
224static volatile bool_Bool eval_cps_state_changed = false0;
225
226static void usleep_nonsense(uint32_t us) {
227 (void) us;
228}
229
230static bool_Bool dynamic_load_nonsense(const char *sym, const char **code) {
231 (void) sym;
232 (void) code;
233 return false0;
234}
235
236static uint32_t timestamp_nonsense(void) {
237 return 0;
238}
239
240static int printf_nonsense(const char *fmt, ...) {
241 (void) fmt;
242 return 0;
243}
244
245static void ctx_done_nonsense(eval_context_t *ctx) {
246 (void) ctx;
247}
248
249static void critical_nonsense(void) {
250 return;
251}
252
253static void (*critical_error_callback)(void) = critical_nonsense;
254static void (*usleep_callback)(uint32_t) = usleep_nonsense;
255static uint32_t (*timestamp_us_callback)(void) = timestamp_nonsense;
256static void (*ctx_done_callback)(eval_context_t *) = ctx_done_nonsense;
257static int (*printf_callback)(const char *, ...) = printf_nonsense;
258static bool_Bool (*dynamic_load_callback)(const char *, const char **) = dynamic_load_nonsense;
259
260void lbm_set_critical_error_callback(void (*fptr)(void)) {
261 if (fptr == NULL((void*)0)) critical_error_callback = critical_nonsense;
262 else critical_error_callback = fptr;
263}
264
265void lbm_set_usleep_callback(void (*fptr)(uint32_t)) {
266 if (fptr == NULL((void*)0)) usleep_callback = usleep_nonsense;
267 else usleep_callback = fptr;
268}
269
270void lbm_set_timestamp_us_callback(uint32_t (*fptr)(void)) {
271 if (fptr == NULL((void*)0)) timestamp_us_callback = timestamp_nonsense;
272 else timestamp_us_callback = fptr;
273}
274
275void lbm_set_ctx_done_callback(void (*fptr)(eval_context_t *)) {
276 if (fptr == NULL((void*)0)) ctx_done_callback = ctx_done_nonsense;
277 else ctx_done_callback = fptr;
278}
279
280void lbm_set_printf_callback(int (*fptr)(const char*, ...)){
281 if (fptr == NULL((void*)0)) printf_callback = printf_nonsense;
282 else printf_callback = fptr;
283}
284
285void lbm_set_dynamic_load_callback(bool_Bool (*fptr)(const char *, const char **)) {
286 if (fptr == NULL((void*)0)) dynamic_load_callback = dynamic_load_nonsense;
287 else dynamic_load_callback = fptr;
288}
289
290static volatile lbm_event_t *lbm_events = NULL((void*)0);
291static unsigned int lbm_events_head = 0;
292static unsigned int lbm_events_tail = 0;
293static unsigned int lbm_events_max = 0;
294static bool_Bool lbm_events_full = false0;
295static mutex_t lbm_events_mutex;
296static bool_Bool lbm_events_mutex_initialized = false0;
297static volatile lbm_cid lbm_event_handler_pid = -1;
298
299lbm_cid lbm_get_event_handler_pid(void) {
300 return lbm_event_handler_pid;
301}
302
303void lbm_set_event_handler_pid(lbm_cid pid) {
304 lbm_event_handler_pid = pid;
305}
306
307bool_Bool lbm_event_handler_exists(void) {
308 return(lbm_event_handler_pid > 0);
309}
310
311
312static bool_Bool event_internal(lbm_event_type_t event_type, lbm_uint parameter, lbm_uint buf_ptr, lbm_uint buf_len) {
313 bool_Bool r = false0;
314 if (lbm_events) {
315 mutex_lock(&lbm_events_mutex);
316 if (!lbm_events_full) {
317 lbm_event_t event;
318 event.type = event_type;
319 event.parameter = parameter;
320 event.buf_ptr = buf_ptr;
321 event.buf_len = buf_len;
322 lbm_events[lbm_events_head] = event;
323 lbm_events_head = (lbm_events_head + 1) % lbm_events_max;
324 lbm_events_full = lbm_events_head == lbm_events_tail;
325 r = true1;
326 }
327 mutex_unlock(&lbm_events_mutex);
328 }
329 return r;
330}
331
332bool_Bool lbm_event_define(lbm_value key, lbm_flat_value_t *fv) {
333 return event_internal(LBM_EVENT_DEFINE, key, (lbm_uint)fv->buf, fv->buf_size);
334}
335
336bool_Bool lbm_event_unboxed(lbm_value unboxed) {
337 lbm_uint t = lbm_type_of(unboxed);
338 if (t == LBM_TYPE_SYMBOL0x00000000u ||
339 t == LBM_TYPE_I0x00000008u ||
340 t == LBM_TYPE_U0x0000000Cu ||
341 t == LBM_TYPE_CHAR0x00000004u) {
342 if (lbm_event_handler_pid > 0) {
343 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)unboxed, 0);
344 }
345 }
346 return false0;
347}
348
349bool_Bool lbm_event(lbm_flat_value_t *fv) {
350 if (lbm_event_handler_pid > 0) {
351 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)fv->buf, fv->buf_size);
352 }
353 return false0;
354}
355
356static bool_Bool lbm_event_pop(lbm_event_t *event) {
357 mutex_lock(&lbm_events_mutex);
358 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
359 mutex_unlock(&lbm_events_mutex);
360 return false0;
361 }
362 *event = lbm_events[lbm_events_tail];
363 lbm_events_tail = (lbm_events_tail + 1) % lbm_events_max;
364 lbm_events_full = false0;
365 mutex_unlock(&lbm_events_mutex);
366 return true1;
367}
368
369bool_Bool lbm_event_queue_is_empty(void) {
370 mutex_lock(&lbm_events_mutex);
371 bool_Bool empty = false0;
372 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
373 empty = true1;
374 }
375 mutex_unlock(&lbm_events_mutex);
376 return empty;
377}
378
379static bool_Bool eval_running = false0;
380static volatile bool_Bool blocking_extension = false0;
381static mutex_t blocking_extension_mutex;
382static bool_Bool blocking_extension_mutex_initialized = false0;
383static lbm_uint blocking_extension_timeout_us = 0;
384static bool_Bool blocking_extension_timeout = false0;
385
386static uint32_t is_atomic = 0;
387
388/* Process queues */
389static eval_context_queue_t blocked = {NULL((void*)0), NULL((void*)0)};
390static eval_context_queue_t queue = {NULL((void*)0), NULL((void*)0)};
391
392/* one mutex for all queue operations */
393mutex_t qmutex;
394bool_Bool qmutex_initialized = false0;
395
396
397// MODES
398static volatile bool_Bool lbm_verbose = false0;
399
400void lbm_toggle_verbose(void) {
401 lbm_verbose = !lbm_verbose;
402}
403
404void lbm_set_verbose(bool_Bool verbose) {
405 lbm_verbose = verbose;
406}
407
408lbm_cid lbm_get_current_cid(void) {
409 if (ctx_running)
410 return ctx_running->id;
411 else
412 return -1;
413}
414
415eval_context_t *lbm_get_current_context(void) {
416 return ctx_running;
417}
418
419/****************************************************/
420/* Utilities used locally in this file */
421
422static lbm_value cons_with_gc(lbm_value head, lbm_value tail, lbm_value remember) {
423#ifdef LBM_ALWAYS_GC
424 lbm_value roots[3] = {head, tail, remember};
425 lbm_gc_mark_roots(roots, 3);
426 gc();
427 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
428 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
429 if (lbm_is_symbol_merror(res)) {
430 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
431 }
432 return res;
433#else
434 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
435 if (lbm_is_symbol_merror(res)) {
436 lbm_value roots[3] = {head, tail, remember};
437 lbm_gc_mark_roots(roots,3);
438 gc();
439 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
440 if (lbm_is_symbol_merror(res)) {
441 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
442 }
443 }
444 return res;
445#endif
446}
447
448static lbm_uint *get_stack_ptr(eval_context_t *ctx, unsigned int n) {
449 if (n <= ctx->K.sp) {
450 lbm_uint index = ctx->K.sp - n;
451 return &ctx->K.data[index];
452 }
453 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
454 return 0; // dead code cannot be reached, but C compiler doesn't realise.
455}
456
457// pop_stack_ptr is safe when no GC is performed and
458// the values of the stack will be dropped.
459static lbm_uint *pop_stack_ptr(eval_context_t *ctx, unsigned int n) {
460 if (n <= ctx->K.sp) {
461 ctx->K.sp -= n;
462 return &ctx->K.data[ctx->K.sp];
463 }
464 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
465 return 0; // dead code cannot be reached, but C compiler doesn't realise.
466}
467
468static inline lbm_uint *stack_reserve(eval_context_t *ctx, unsigned int n) {
469 if (ctx->K.sp + n < ctx->K.size) {
470 lbm_uint *ptr = &ctx->K.data[ctx->K.sp];
471 ctx->K.sp += n;
472 return ptr;
473 }
474 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
475 return 0; // dead code cannot be reached, but C compiler doesn't realise.
476}
477
478static void handle_flash_status(lbm_flash_status s) {
479 if ( s == LBM_FLASH_FULL) {
480 lbm_set_error_reason((char*)lbm_error_str_flash_full);
481 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
482 }
483 if (s == LBM_FLASH_WRITE_ERROR) {
484 lbm_set_error_reason((char*)lbm_error_str_flash_error);
485 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
486 }
487}
488
489static void lift_array_flash(lbm_value flash_cell, bool_Bool bytearray, char *data, lbm_uint num_elt) {
490
491 lbm_array_header_t flash_array_header;
492 flash_array_header.size = num_elt;
493 flash_array_header.data = (lbm_uint*)data;
494 lbm_uint flash_array_header_ptr;
495 handle_flash_status(lbm_write_const_raw((lbm_uint*)&flash_array_header,
496 sizeof(lbm_array_header_t) / sizeof(lbm_uint),
497 &flash_array_header_ptr));
498 handle_flash_status(write_const_car(flash_cell, flash_array_header_ptr));
499 lbm_uint t = bytearray ? ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u) : ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u);
500 handle_flash_status(write_const_cdr(flash_cell, t));
501}
502
503static void get_car_and_cdr(lbm_value a, lbm_value *a_car, lbm_value *a_cdr) {
504 if (lbm_is_ptr(a)) {
505 lbm_cons_t *cell = lbm_ref_cell(a);
506 *a_car = cell->car;
507 *a_cdr = cell->cdr;
508 } else if (lbm_is_symbol_nil(a)) {
509 *a_car = *a_cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
510 } else {
511 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
512 }
513}
514
515/* car cdr caar cadr replacements that are evaluator safe. */
516static lbm_value get_car(lbm_value a) {
517 if (lbm_is_ptr(a)) {
6
←
Assuming the condition is false
→
7
←
Taking false branch
→
518 lbm_cons_t *cell = lbm_ref_cell(a);
519 return cell->car;
520 } else if (lbm_is_symbol_nil(a)) {
8
←
Calling 'lbm_is_symbol_nil'
→
11
←
Returning from 'lbm_is_symbol_nil'
→
12
←
Taking true branch
→
521 return a;
13
←
Returning zero (loaded from 'a')
→
522 }
523 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
524 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
525}
526
527static lbm_value get_cdr(lbm_value a) {
528 if (lbm_is_ptr(a)) {
529 lbm_cons_t *cell = lbm_ref_cell(a);
530 return cell->cdr;
531 } else if (lbm_is_symbol_nil(a)) {
532 return a;
533 }
534 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
535 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
536}
537
538static lbm_value get_cadr(lbm_value a) {
539 if (lbm_is_ptr(a)) {
540 lbm_cons_t *cell = lbm_ref_cell(a);
541 lbm_value tmp = cell->cdr;
542 if (lbm_is_ptr(tmp)) {
543 return lbm_ref_cell(tmp)->car;
544 } else if (lbm_is_symbol_nil(tmp)) {
545 return tmp;
546 }
547 } else if (lbm_is_symbol_nil(a)) {
548 return a;
549 }
550 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
551 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
552}
553
554static lbm_value allocate_closure(lbm_value params, lbm_value body, lbm_value env) {
555
556#ifdef LBM_ALWAYS_GC
557 gc();
558 if (lbm_heap_num_free() < 4) {
559 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
560 }
561#else
562 if (lbm_heap_num_free() < 4) {
563 gc();
564 if (lbm_heap_num_free() < 4) {
565 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
566 }
567 }
568#endif
569 // The freelist will always contain just plain heap-cells.
570 // So dec_ptr is sufficient.
571 lbm_value res = lbm_heap_state.freelist;
572 if (lbm_type_of(res) == LBM_TYPE_CONS0x10000000u) {
573 lbm_cons_t *heap = lbm_heap_state.heap;
574 lbm_uint ix = lbm_dec_ptr(res);
575 heap[ix].car = ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u);
576 ix = lbm_dec_ptr(heap[ix].cdr);
577 heap[ix].car = params;
578 ix = lbm_dec_ptr(heap[ix].cdr);
579 heap[ix].car = body;
580 ix = lbm_dec_ptr(heap[ix].cdr);
581 heap[ix].car = env;
582 lbm_heap_state.freelist = heap[ix].cdr;
583 heap[ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
584 lbm_heap_state.num_alloc+=4;
585 } else {
586 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
587 }
588 return res;
589}
590
591// Allocate a binding and attach it to a list (if so desired)
592static lbm_value allocate_binding(lbm_value key, lbm_value val, lbm_value the_cdr) {
593 if (lbm_heap_num_free() < 2) {
594 gc();
595 if (lbm_heap_num_free() < 2) {
596 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
597 }
598 }
599 lbm_cons_t* heap = lbm_heap_state.heap;
600 lbm_value binding_cell = lbm_heap_state.freelist;
601 lbm_uint binding_cell_ix = lbm_dec_ptr(binding_cell);
602 lbm_value list_cell = heap[binding_cell_ix].cdr;
603 lbm_uint list_cell_ix = lbm_dec_ptr(list_cell);
604 lbm_heap_state.freelist = heap[list_cell_ix].cdr;
605 lbm_heap_state.num_alloc += 2;
606 heap[binding_cell_ix].car = key;
607 heap[binding_cell_ix].cdr = val;
608 heap[list_cell_ix].car = binding_cell;
609 heap[list_cell_ix].cdr = the_cdr;
610 return list_cell;
611}
612
613#define CLO_PARAMS0 0
614#define CLO_BODY1 1
615#define CLO_ENV2 2
616#define LOOP_BINDS0 0
617#define LOOP_COND1 1
618#define LOOP_BODY2 2
619
620// (a b c) -> [a b c]
621static lbm_value extract_n(lbm_value curr, lbm_value *res, unsigned int n) {
622 for (unsigned int i = 0; i < n; i ++) {
623 if (lbm_is_ptr(curr)) {
624 lbm_cons_t *cell = lbm_ref_cell(curr);
625 res[i] = cell->car;
626 curr = cell->cdr;
627 } else {
628 res[i] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
629 }
630 }
631 return curr; // Rest of list is returned here.
632}
633
634static void call_fundamental(lbm_uint fundamental, lbm_value *args, lbm_uint arg_count, eval_context_t *ctx) {
635 lbm_value res;
636 res = fundamental_table[fundamental](args, arg_count, ctx);
637 if (lbm_is_error(res)) {
638 if (lbm_is_symbol_merror(res)) {
639 gc();
640 res = fundamental_table[fundamental](args, arg_count, ctx);
641 }
642 if (lbm_is_error(res)) {
643 error_at_ctx(res, lbm_enc_sym(FUNDAMENTAL_SYMBOLS_START0x20000 | fundamental));
644 }
645 }
646 lbm_stack_drop(&ctx->K, arg_count+1);
647 ctx->app_cont = true1;
648 ctx->r = res;
649}
650
651// block_current_ctx blocks a context until it is
652// woken up externally or a timeout period of time passes.
653static void block_current_ctx(uint32_t state, lbm_uint sleep_us, bool_Bool do_cont) {
654 ctx_running->timestamp = timestamp_us_callback();
655 ctx_running->sleep_us = sleep_us;
656 ctx_running->state = state;
657 ctx_running->app_cont = do_cont;
658 enqueue_ctx(&blocked, ctx_running);
659 ctx_running = NULL((void*)0);
660}
661
662lbm_flash_status lbm_write_const_array_padded(uint8_t *data, lbm_uint n, lbm_uint *res) {
663 lbm_uint full_words = n / sizeof(lbm_uint);
664 lbm_uint n_mod = n % sizeof(lbm_uint);
665
666 if (n_mod == 0) { // perfect fit.
667 return lbm_write_const_raw((lbm_uint*)data, full_words, res);
668 } else {
669 lbm_uint last_word = 0;
670 memcpy(&last_word, &data[full_words * sizeof(lbm_uint)], n_mod);
671 if (full_words >= 1) {
672 lbm_flash_status s = lbm_write_const_raw((lbm_uint*)data, full_words, res);
673 if ( s == LBM_FLASH_WRITE_OK) {
674 lbm_uint dummy;
675 s = lbm_write_const_raw(&last_word, 1, &dummy);
676 }
677 return s;
678 } else {
679 return lbm_write_const_raw(&last_word, 1, res);
680 }
681 }
682}
683
684/****************************************************/
685/* Error message creation */
686
687#define ERROR_MESSAGE_BUFFER_SIZE_BYTES256 256
688
689void print_environments(char *buf, unsigned int size) {
690
691 lbm_value curr_l = ctx_running->curr_env;
692 printf_callback("\tCurrent local environment:\n");
693 while (lbm_type_of(curr_l) == LBM_TYPE_CONS0x10000000u) {
694 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_l));
695 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_l)));
696 printf_callback("\t%s = %s\n", buf, buf+(size/2));
697 curr_l = lbm_cdr(curr_l);
698 }
699 printf_callback("\n\n");
700 printf_callback("\tCurrent global environment:\n");
701 lbm_value *glob_env = lbm_get_global_env();
702
703 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
704 lbm_value curr_g = glob_env[i];;
705 while (lbm_type_of(curr_g) == LBM_TYPE_CONS0x10000000u) {
706
707 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_g));
708 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_g)));
709 printf_callback("\t%s = %s\n", buf, buf+(size/2));
710 curr_g = lbm_cdr(curr_g);
711 }
712 }
713}
714
715void print_error_message(lbm_value error, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int col, lbm_int row0, lbm_int row1) {
716 if (!printf_callback) return;
717
718 /* try to allocate a lbm_print_value buffer on the lbm_memory */
719 char *buf = lbm_malloc_reserve(ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
720 if (!buf) {
721 printf_callback("Error: Not enough free memory to create a human readable error message\n");
722 return;
723 }
724
725 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, error);
726 printf_callback( "*** Error: %s\n", buf);
727 if (has_at) {
728 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, at);
729 printf_callback("*** In: %s\n",buf);
730 if (lbm_error_has_suspect) {
731 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, lbm_error_suspect);
732 lbm_error_has_suspect = false0;
733 printf_callback("*** At: %s\n", buf);
734 } else {
735 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
736 printf_callback("*** After: %s\n",buf);
737 }
738 } else {
739 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
740 printf_callback("*** Near: %s\n",buf);
741 }
742
743 printf_callback("\n");
744
745 if (lbm_is_symbol(error) &&
746 error == ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u)) {
747 printf_callback("*** Line: %u\n", row);
748 printf_callback("*** Column: %u\n", col);
749 } else if (row0 != -1 || row1 != -1 ) {
750 printf_callback("*** Between rows: (-1 unknown) \n");
751 printf_callback("*** Start: %d\n", (int32_t)row0);
752 printf_callback("*** End: %d\n", (int32_t)row1);
753 }
754
755 printf_callback("\n");
756
757 if (ctx_running->error_reason) {
758 printf_callback("Reason:\n %s\n\n", ctx_running->error_reason);
759 }
760 if (lbm_verbose) {
761 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
762 printf_callback(" In context: %d\n", ctx_running->id);
763 printf_callback(" Current intermediate result: %s\n\n", buf);
764
765 print_environments(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
766 printf_callback("\n\n");
767
768 printf_callback(" Stack:\n");
769 for (unsigned int i = 0; i < ctx_running->K.sp; i ++) {
770 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->K.data[i]);
771 printf_callback(" %s\n", buf);
772 }
773 }
774 lbm_free(buf);
775}
776
777/****************************************************/
778/* Tokenizing and parsing */
779
780bool_Bool create_string_channel(char *str, lbm_value *res) {
781
782 lbm_char_channel_t *chan = NULL((void*)0);
783 lbm_string_channel_state_t *st = NULL((void*)0);
784
785 st = (lbm_string_channel_state_t*)lbm_memory_allocate(sizeof(lbm_string_channel_state_t) / sizeof(lbm_uint) +1);
786 if (st == NULL((void*)0)) {
787 return false0;
788 }
789 chan = (lbm_char_channel_t*)lbm_memory_allocate(sizeof(lbm_char_channel_t) / sizeof(lbm_uint) + 1);
790 if (chan == NULL((void*)0)) {
791 lbm_memory_free((lbm_uint*)st);
792 return false0;
793 }
794
795 lbm_create_string_char_channel(st, chan, str);
796 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
797 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
798 lbm_memory_free((lbm_uint*)st);
799 lbm_memory_free((lbm_uint*)chan);
800 return false0;
801 }
802
803 *res = cell;
804 return true1;
805}
806
807bool_Bool lift_char_channel(lbm_char_channel_t *chan , lbm_value *res) {
808 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
809 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
810 return false0;
811 }
812 *res = cell;
813 return true1;
814}
815
816
817/****************************************************/
818/* Queue functions */
819
820static void queue_iterator_nm(eval_context_queue_t *q, ctx_fun f, void *arg1, void *arg2) {
821 eval_context_t *curr;
822 curr = q->first;
823
824 while (curr != NULL((void*)0)) {
825 f(curr, arg1, arg2);
826 curr = curr->next;
827 }
828}
829
830void lbm_running_iterator(ctx_fun f, void *arg1, void *arg2){
831 mutex_lock(&qmutex);
832 queue_iterator_nm(&queue, f, arg1, arg2);
833 mutex_unlock(&qmutex);
834}
835
836void lbm_blocked_iterator(ctx_fun f, void *arg1, void *arg2){
837 mutex_lock(&qmutex);
838 queue_iterator_nm(&blocked, f, arg1, arg2);
839 mutex_unlock(&qmutex);
840}
841
842static void enqueue_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
843 if (q->last == NULL((void*)0)) {
844 ctx->prev = NULL((void*)0);
845 ctx->next = NULL((void*)0);
846 q->first = ctx;
847 q->last = ctx;
848 } else {
849 ctx->prev = q->last;
850 ctx->next = NULL((void*)0);
851 q->last->next = ctx;
852 q->last = ctx;
853 }
854}
855
856static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx) {
857 mutex_lock(&qmutex);
858 enqueue_ctx_nm(q,ctx);
859 mutex_unlock(&qmutex);
860}
861
862static eval_context_t *lookup_ctx_nm(eval_context_queue_t *q, lbm_cid cid) {
863 eval_context_t *curr;
864 curr = q->first;
865 while (curr != NULL((void*)0)) {
866 if (curr->id == cid) {
867 return curr;
868 }
869 curr = curr->next;
870 }
871 return NULL((void*)0);
872}
873
874static bool_Bool drop_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
875
876 bool_Bool res = false0;
877 if (q->first == NULL((void*)0) || q->last == NULL((void*)0)) {
878 if (!(q->last == NULL((void*)0) && q->first == NULL((void*)0))) {
879 /* error state that should not happen */
880 return res;
881 }
882 /* Queue is empty */
883 return res;
884 }
885
886 eval_context_t *curr = q->first;
887 while (curr) {
888 if (curr->id == ctx->id) {
889 res = true1;
890 eval_context_t *tmp = curr->next;
891 if (curr->prev == NULL((void*)0)) {
892 if (curr->next == NULL((void*)0)) {
893 q->last = NULL((void*)0);
894 q->first = NULL((void*)0);
895 } else {
896 q->first = tmp;
897 tmp->prev = NULL((void*)0);
898 }
899 } else { /* curr->prev != NULL */
900 if (curr->next == NULL((void*)0)) {
901 q->last = curr->prev;
902 q->last->next = NULL((void*)0);
903 } else {
904 curr->prev->next = tmp;
905 tmp->prev = curr->prev;
906 }
907 }
908 break;
909 }
910 curr = curr->next;
911 }
912 return res;
913}
914
915/* End execution of the running context. */
916static void finish_ctx(void) {
917
918 if (!ctx_running) {
919 return;
920 }
921 /* Drop the continuation stack immediately to free up lbm_memory */
922 lbm_stack_free(&ctx_running->K);
923 ctx_done_callback(ctx_running);
924 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->name)) {
925 lbm_free(ctx_running->name);
926 }
927 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->error_reason)) {
928 lbm_memory_free((lbm_uint*)ctx_running->error_reason);
929 }
930 lbm_memory_free((lbm_uint*)ctx_running->mailbox);
931 lbm_memory_free((lbm_uint*)ctx_running);
932 ctx_running = NULL((void*)0);
933}
934
935static void context_exists(eval_context_t *ctx, void *cid, void *b) {
936 if (ctx->id == *(lbm_cid*)cid) {
937 *(bool_Bool*)b = true1;
938 }
939}
940
941bool_Bool lbm_wait_ctx(lbm_cid cid, lbm_uint timeout_ms) {
942
943 bool_Bool exists;
944 uint32_t i = 0;
945
946 do {
947 exists = false0;
948 lbm_blocked_iterator(context_exists, &cid, &exists);
949 lbm_running_iterator(context_exists, &cid, &exists);
950
951 if (ctx_running &&
952 ctx_running->id == cid) {
953 exists = true1;
954 }
955
956 if (exists) {
957 if (usleep_callback) {
958 usleep_callback(1000);
959 }
960 if (timeout_ms > 0) i ++;
961 }
962 } while (exists && i < timeout_ms);
963
964 if (exists) return false0;
965 return true1;
966}
967
968void lbm_set_error_suspect(lbm_value suspect) {
969 lbm_error_suspect = suspect;
970 lbm_error_has_suspect = true1;
971}
972
973void lbm_set_error_reason(char *error_str) {
974 if (ctx_running != NULL((void*)0)) {
975 ctx_running->error_reason = error_str;
976 }
977}
978
979// Not possible to CONS_WITH_GC in error_ctx_base (potential loop)
980static void error_ctx_base(lbm_value err_val, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int column) {
981
982 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
983 if (lbm_heap_num_free() < 3) {
984 gc();
985 }
986
987 if (lbm_heap_num_free() >= 3) {
988 lbm_value msg = lbm_cons(err_val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
989 msg = lbm_cons(lbm_enc_i(ctx_running->id), msg);
990 msg = lbm_cons(ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u), msg);
991 if (!lbm_is_symbol_merror(msg)) {
992 lbm_find_receiver_and_send(ctx_running->parent, msg);
993 goto error_ctx_base_done;
994 }
995 }
996 }
997 if ((ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10) &&
998 (err_val != ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u))) {
999 lbm_uint v;
1000 while (ctx_running->K.sp > 0) {
1001 lbm_pop(&ctx_running->K, &v);
1002 if (v == EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u)) {
1003 lbm_value *sptr = get_stack_ptr(ctx_running, 2);
1004 lbm_set_car(sptr[0], ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
1005 stack_reserve(ctx_running, 1)[0] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1006 ctx_running->app_cont = true1;
1007 ctx_running->r = err_val;
1008 longjmp(error_jmp_buf, 1);
1009 }
1010 }
1011 err_val = ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u);
1012 }
1013 print_error_message(err_val,
1014 has_at,
1015 at,
1016 row,
1017 column,
1018 ctx_running->row0,
1019 ctx_running->row1);
1020 error_ctx_base_done:
1021 ctx_running->r = err_val;
1022 finish_ctx();
1023 longjmp(error_jmp_buf, 1);
1024}
1025
1026static void error_at_ctx(lbm_value err_val, lbm_value at) {
1027 error_ctx_base(err_val, true1, at, 0, 0);
1028}
1029
1030static void error_ctx(lbm_value err_val) {
1031 error_ctx_base(err_val, false0, 0, 0, 0);
1032}
1033
1034static void read_error_ctx(unsigned int row, unsigned int column) {
1035 error_ctx_base(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u), false0, 0, row, column);
1036}
1037
1038void lbm_critical_error(void) {
1039 longjmp(critical_error_jmp_buf, 1);
1040}
1041
1042// successfully finish a context
1043static void ok_ctx(void) {
1044 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
1045 lbm_value msg;
1046 WITH_GC(msg, lbm_heap_allocate_list_init(3,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1047 ENC_SYM_EXIT_OK,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1048 lbm_enc_i(ctx_running->id),(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1049 ctx_running->r))(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
1050 lbm_find_receiver_and_send(ctx_running->parent, msg);
1051 }
1052 finish_ctx();
1053}
1054
1055static eval_context_t *dequeue_ctx_nm(eval_context_queue_t *q) {
1056 if (q->last == NULL((void*)0)) {
1057 return NULL((void*)0);
1058 }
1059 // q->first should only be NULL if q->last is.
1060 eval_context_t *res = q->first;
1061
1062 if (q->first == q->last) { // One thing in queue
1063 q->first = NULL((void*)0);
1064 q->last = NULL((void*)0);
1065 } else {
1066 q->first = q->first->next;
1067 q->first->prev = NULL((void*)0);
1068 }
1069 res->prev = NULL((void*)0);
1070 res->next = NULL((void*)0);
1071 return res;
1072}
1073
1074static void wake_up_ctxs_nm(void) {
1075 lbm_uint t_now;
1076
1077 if (timestamp_us_callback) {
1078 t_now = timestamp_us_callback();
1079 } else {
1080 t_now = 0;
1081 }
1082
1083 eval_context_queue_t *q = &blocked;
1084 eval_context_t *curr = q->first;
1085
1086 while (curr != NULL((void*)0)) {
1087 lbm_uint t_diff;
1088 eval_context_t *next = curr->next;
1089 if (curr->state != LBM_THREAD_STATE_BLOCKED(uint32_t)1) {
1090 if ( curr->timestamp > t_now) {
1091 /* There was an overflow on the counter */
1092#ifndef LBM64
1093 t_diff = (0xFFFFFFFF - curr->timestamp) + t_now;
1094#else
1095 t_diff = (0xFFFFFFFFFFFFFFFF - curr->timestamp) + t_now;
1096#endif
1097 } else {
1098 t_diff = t_now - curr->timestamp;
1099 }
1100
1101 if (t_diff >= curr->sleep_us) {
1102 eval_context_t *wake_ctx = curr;
1103 if (curr == q->last) {
1104 if (curr->prev) {
1105 q->last = curr->prev;
1106 q->last->next = NULL((void*)0);
1107 } else {
1108 q->first = NULL((void*)0);
1109 q->last = NULL((void*)0);
1110 }
1111 } else if (curr->prev == NULL((void*)0)) {
1112 q->first = curr->next;
1113 q->first->prev = NULL((void*)0);
1114 } else {
1115 curr->prev->next = curr->next;
1116 if (curr->next) {
1117 curr->next->prev = curr->prev;
1118 }
1119 }
1120 wake_ctx->next = NULL((void*)0);
1121 wake_ctx->prev = NULL((void*)0);
1122 if (curr->state == LBM_THREAD_STATE_TIMEOUT(uint32_t)2) {
1123 mailbox_add_mail(wake_ctx, ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u));
1124 wake_ctx->r = ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u);
1125 }
1126 wake_ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1127 enqueue_ctx_nm(&queue, wake_ctx);
1128 }
1129 }
1130 curr = next;
1131 }
1132}
1133
1134static void yield_ctx(lbm_uint sleep_us) {
1135 if (timestamp_us_callback) {
1136 ctx_running->timestamp = timestamp_us_callback();
1137 ctx_running->sleep_us = sleep_us;
1138 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1139 } else {
1140 ctx_running->timestamp = 0;
1141 ctx_running->sleep_us = 0;
1142 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1143 }
1144 ctx_running->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1145 ctx_running->app_cont = true1;
1146 enqueue_ctx(&blocked,ctx_running);
1147 ctx_running = NULL((void*)0);
1148}
1149
1150static lbm_cid lbm_create_ctx_parent(lbm_value program, lbm_value env, lbm_uint stack_size, lbm_cid parent, uint32_t context_flags, char *name) {
1151
1152 if (!lbm_is_cons(program)) return -1;
1153
1154 eval_context_t *ctx = NULL((void*)0);
1155
1156 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1157 if (ctx == NULL((void*)0)) {
1158 lbm_uint roots[2] = {program, env};
1159 lbm_gc_mark_roots(roots, 2);
1160 gc();
1161 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1162 }
1163 if (ctx == NULL((void*)0)) return -1;
1164
1165 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1166 lbm_uint roots[2] = {program, env};
1167 lbm_gc_mark_roots(roots, 2);
1168 gc();
1169 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1170 lbm_memory_free((lbm_uint*)ctx);
1171 return -1;
1172 }
1173 }
1174
1175 lbm_value *mailbox = NULL((void*)0);
1176 mailbox = (lbm_value*)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1177 if (mailbox == NULL((void*)0)) {
1178 lbm_value roots[2] = {program, env};
1179 lbm_gc_mark_roots(roots,2);
1180 gc();
1181 mailbox = (lbm_value *)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1182 }
1183 if (mailbox == NULL((void*)0)) {
1184 lbm_stack_free(&ctx->K);
1185 lbm_memory_free((lbm_uint*)ctx);
1186 return -1;
1187 }
1188
1189 // TODO: Limit names to 19 chars + 1 char for 0? (or something similar).
1190 if (name) {
1191 lbm_uint name_len = strlen(name) + 1;
1192 ctx->name = lbm_malloc(strlen(name) + 1);
1193 if (ctx->name == NULL((void*)0)) {
1194 lbm_value roots[2] = {program, env};
1195 lbm_gc_mark_roots(roots, 2);
1196 gc();
1197 ctx->name = lbm_malloc(strlen(name) + 1);
1198 }
1199 if (ctx->name == NULL((void*)0)) {
1200 lbm_stack_free(&ctx->K);
1201 lbm_memory_free((lbm_uint*)mailbox);
1202 lbm_memory_free((lbm_uint*)ctx);
1203 return -1;
1204 }
1205 memcpy(ctx->name, name, name_len+1);
1206 } else {
1207 ctx->name = NULL((void*)0);
1208 }
1209
1210 lbm_int cid = lbm_memory_address_to_ix((lbm_uint*)ctx);
1211
1212 ctx->program = lbm_cdr(program);
1213 ctx->curr_exp = lbm_car(program);
1214 ctx->curr_env = env;
1215 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1216 ctx->error_reason = NULL((void*)0);
1217 ctx->mailbox = mailbox;
1218 ctx->mailbox_size = EVAL_CPS_DEFAULT_MAILBOX_SIZE10;
1219 ctx->flags = context_flags;
1220 ctx->num_mail = 0;
1221 ctx->app_cont = false0;
1222 ctx->timestamp = 0;
1223 ctx->sleep_us = 0;
1224 ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1225 ctx->prev = NULL((void*)0);
1226 ctx->next = NULL((void*)0);
1227
1228 ctx->row0 = -1;
1229 ctx->row1 = -1;
1230
1231 ctx->id = cid;
1232 ctx->parent = parent;
1233
1234 if (!lbm_push(&ctx->K, DONE(((0) << 2) | 0xF8000001u))) {
1235 lbm_memory_free((lbm_uint*)ctx->mailbox);
1236 lbm_stack_free(&ctx->K);
1237 lbm_memory_free((lbm_uint*)ctx);
1238 return -1;
1239 }
1240
1241 enqueue_ctx(&queue,ctx);
1242
1243 return ctx->id;
1244}
1245
1246lbm_cid lbm_create_ctx(lbm_value program, lbm_value env, lbm_uint stack_size, char *name) {
1247 // Creates a parentless context.
1248 return lbm_create_ctx_parent(program,
1249 env,
1250 stack_size,
1251 -1,
1252 EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00,
1253 name);
1254}
1255
1256bool_Bool lbm_mailbox_change_size(eval_context_t *ctx, lbm_uint new_size) {
1257
1258 lbm_value *mailbox = NULL((void*)0);
1259 mailbox = (lbm_value*)lbm_memory_allocate(new_size);
1260 if (mailbox == NULL((void*)0)) {
1261 gc();
1262 mailbox = (lbm_value *)lbm_memory_allocate(new_size);
1263 }
1264 if (mailbox == NULL((void*)0)) {
1265 return false0;
1266 }
1267
1268 for (lbm_uint i = 0; i < ctx->num_mail; i ++ ) {
1269 mailbox[i] = ctx->mailbox[i];
1270 }
1271 lbm_memory_free(ctx->mailbox);
1272 ctx->mailbox = mailbox;
1273 ctx->mailbox_size = (uint32_t)new_size;
1274 return true1;
1275}
1276
1277static void mailbox_remove_mail(eval_context_t *ctx, lbm_uint ix) {
1278
1279 for (lbm_uint i = ix; i < ctx->num_mail-1; i ++) {
1280 ctx->mailbox[i] = ctx->mailbox[i+1];
1281 }
1282 ctx->num_mail --;
1283}
1284
1285static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail) {
1286
1287 if (ctx->num_mail >= ctx->mailbox_size) {
1288 mailbox_remove_mail(ctx, 0);
1289 }
1290
1291 ctx->mailbox[ctx->num_mail] = mail;
1292 ctx->num_mail ++;
1293 return true1;
1294}
1295
1296/* Advance execution to the next expression in the program */
1297static void advance_ctx(eval_context_t *ctx) {
1298 if (lbm_is_cons(ctx->program)) {
1299 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);;
1300 get_car_and_cdr(ctx->program, &ctx->curr_exp, &ctx->program);
1301 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1302 } else {
1303 if (ctx_running == ctx) { // This should always be the case because of odd historical reasons.
1304 ok_ctx();
1305 }
1306 }
1307}
1308
1309bool_Bool lbm_unblock_ctx(lbm_cid cid, lbm_flat_value_t *fv) {
1310 return event_internal(LBM_EVENT_UNBLOCK_CTX, (lbm_uint)cid, (lbm_uint)fv->buf, fv->buf_size);
1311}
1312
1313bool_Bool lbm_unblock_ctx_r(lbm_cid cid) {
1314 mutex_lock(&blocking_extension_mutex);
1315 bool_Bool r = false0;
1316 eval_context_t *found = NULL((void*)0);
1317 mutex_lock(&qmutex);
1318 found = lookup_ctx_nm(&blocked, cid);
1319 if (found) {
1320 drop_ctx_nm(&blocked,found);
1321 enqueue_ctx_nm(&queue,found);
1322 r = true1;
1323 }
1324 mutex_unlock(&qmutex);
1325 mutex_unlock(&blocking_extension_mutex);
1326 return r;
1327}
1328
1329// unblock unboxed is also safe for rmbr:ed things.
1330bool_Bool lbm_unblock_ctx_unboxed(lbm_cid cid, lbm_value unboxed) {
1331 mutex_lock(&blocking_extension_mutex);
1332 bool_Bool r = false0;
1333 eval_context_t *found = NULL((void*)0);
1334 mutex_lock(&qmutex);
1335 found = lookup_ctx_nm(&blocked, cid);
1336 if (found) {
1337 drop_ctx_nm(&blocked,found);
1338 found->r = unboxed;
1339 if (lbm_is_error(unboxed)) {
1340 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
1341 found->app_cont = true1;
1342 }
1343 enqueue_ctx_nm(&queue,found);
1344 r = true1;
1345 }
1346 mutex_unlock(&qmutex);
1347 mutex_unlock(&blocking_extension_mutex);
1348 return r;
1349}
1350
1351static bool_Bool lbm_block_ctx_base(bool_Bool timeout, float t_s) {
1352 mutex_lock(&blocking_extension_mutex);
1353 blocking_extension = true1;
1354 if (timeout) {
1355 blocking_extension_timeout_us = S_TO_US(t_s)(lbm_uint)((t_s) * 1000000);
1356 blocking_extension_timeout = true1;
1357 } else {
1358 blocking_extension_timeout = false0;
1359 }
1360 return true1;
1361}
1362
1363void lbm_block_ctx_from_extension_timeout(float s) {
1364 lbm_block_ctx_base(true1, s);
1365}
1366
1367void lbm_block_ctx_from_extension(void) {
1368 lbm_block_ctx_base(false0, 0);
1369}
1370
1371// todo: May need to pop rmbrs from stack, if present.
1372// Suspect that the letting the discard cont run is really not a problem.
1373// Either way will be quite confusing what happens to allocated things when undoing block.
1374void lbm_undo_block_ctx_from_extension(void) {
1375 blocking_extension = false0;
1376 blocking_extension_timeout_us = 0;
1377 blocking_extension_timeout = false0;
1378 mutex_unlock(&blocking_extension_mutex);
1379}
1380
1381lbm_value lbm_find_receiver_and_send(lbm_cid cid, lbm_value msg) {
1382 mutex_lock(&qmutex);
1383 eval_context_t *found = NULL((void*)0);
1384 bool_Bool found_blocked = false0;
1385
1386 found = lookup_ctx_nm(&blocked, cid);
1387 if (found) found_blocked = true1;
1388
1389 if (found == NULL((void*)0)) {
1390 found = lookup_ctx_nm(&queue, cid);
1391 }
1392
1393 if (found) {
1394 if (!mailbox_add_mail(found, msg)) {
1395 mutex_unlock(&qmutex);
1396 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1397 }
1398
1399 if (found_blocked){
1400 drop_ctx_nm(&blocked,found);
1401 enqueue_ctx_nm(&queue,found);
1402 }
1403 mutex_unlock(&qmutex);
1404 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1405 }
1406
1407 /* check the current context */
1408 if (ctx_running && ctx_running->id == cid) {
1409 if (!mailbox_add_mail(ctx_running, msg)) {
1410 mutex_unlock(&qmutex);
1411 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1412 }
1413 mutex_unlock(&qmutex);
1414 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1415 }
1416 mutex_unlock(&qmutex);
1417 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1418}
1419
1420/* Pattern matching is currently implemented as a recursive
1421 function and make use of stack relative to the size of
1422 expressions that are being matched. */
1423static bool_Bool match(lbm_value p, lbm_value e, lbm_value *env, bool_Bool *gc) {
1424
1425 lbm_value binding;
1426
1427 if (lbm_is_match_binder(p)) {
1428 lbm_value var = get_cadr(p);
1429 lbm_value bindertype = get_car(p);
1430
1431 if (!lbm_is_symbol(var)) return false0;
1432
1433 switch (bindertype) {
1434 case ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u):
1435 if ( var == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) {
1436 return true1;
1437 }
1438 break;
1439 default: /* this should be an error case */
1440 return false0;
1441 }
1442 binding = lbm_cons(var, e);
1443 if ( lbm_type_of(binding) == LBM_TYPE_SYMBOL0x00000000u ) {
1444 *gc = true1;
1445 return false0;
1446 }
1447 *env = lbm_cons(binding, *env);
1448 if ( lbm_type_of(*env) == LBM_TYPE_SYMBOL0x00000000u ) {
1449 *gc = true1;
1450 return false0;
1451 }
1452 return true1;
1453 }
1454
1455 if (lbm_is_symbol(p)) {
1456 if (p == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return true1;
1457 return (p == e);
1458 }
1459 if (lbm_is_cons(p) &&
1460 lbm_is_cons(e) ) {
1461
1462 lbm_value headp, tailp;
1463 lbm_value heade, taile;
1464 get_car_and_cdr(p, &headp, &tailp);
1465 get_car_and_cdr(e, &heade, &taile); // Static analysis warns, but execution does not
1466 // past this point unless head and tail get initialized.
1467 if (!match(headp, heade, env, gc)) {
1468 return false0;
1469 }
1470 return match (tailp, taile, env, gc);
1471 }
1472 return struct_eq(p, e);
1473}
1474
1475// Find match is not very picky about syntax.
1476// A completely malformed recv form is most likely to
1477// just return no_match.
1478static int find_match(lbm_value plist, lbm_value *earr, lbm_uint num, lbm_value *e, lbm_value *env) {
1479
1480 // A pattern list is a list of pattern, expression lists.
1481 // ( (p1 e1) (p2 e2) ... (pn en))
1482 lbm_value curr_p = plist;
1483 int n = 0;
1484 bool_Bool gc = false0;
1485 for (int i = 0; i < (int)num; i ++ ) {
1486 lbm_value curr_e = earr[i];
1487 while (!lbm_is_symbol_nil(curr_p)) {
1488 lbm_value me = get_car(curr_p);
1489 if (match(get_car(me), curr_e, env, &gc)) {
1490 if (gc) return FM_NEED_GC-1;
1491 *e = get_cadr(me);
1492
1493 if (!lbm_is_symbol_nil(get_cadr(get_cdr(me)))) {
1494 return FM_PATTERN_ERROR-3;
1495 }
1496 return n;
1497 }
1498 curr_p = get_cdr(curr_p);
1499 }
1500 curr_p = plist; /* search all patterns against next exp */
1501 n ++;
1502 }
1503
1504 return FM_NO_MATCH-2;
1505}
1506
1507/****************************************************/
1508/* Garbage collection */
1509
1510static void mark_context(eval_context_t *ctx, void *arg1, void *arg2) {
1511 (void) arg1;
1512 (void) arg2;
1513 lbm_value roots[3] = {ctx->curr_exp, ctx->program, ctx->r };
1514 lbm_gc_mark_env(ctx->curr_env);
1515 lbm_gc_mark_roots(roots, 3);
1516 lbm_gc_mark_roots(ctx->mailbox, ctx->num_mail);
1517 lbm_gc_mark_aux(ctx->K.data, ctx->K.sp);
1518}
1519
1520static int gc(void) {
1521 if (ctx_running) {
1522 ctx_running->state = ctx_running->state | LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1523 }
1524
1525 gc_requested = false0;
1526 lbm_gc_state_inc();
1527
1528 // The freelist should generally be NIL when GC runs.
1529 lbm_nil_freelist();
1530 lbm_value *env = lbm_get_global_env();
1531 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
1532 lbm_gc_mark_env(env[i]);
1533 }
1534
1535 mutex_lock(&qmutex); // Lock the queues.
1536 // Any concurrent messing with the queues
1537 // while doing GC cannot possibly be good.
1538 queue_iterator_nm(&queue, mark_context, NULL((void*)0), NULL((void*)0));
1539 queue_iterator_nm(&blocked, mark_context, NULL((void*)0), NULL((void*)0));
1540
1541 if (ctx_running) {
1542 mark_context(ctx_running, NULL((void*)0), NULL((void*)0));
1543 }
1544 mutex_unlock(&qmutex);
1545
1546#ifdef VISUALIZE_HEAP
1547 heap_vis_gen_image();
1548#endif
1549
1550 int r = lbm_gc_sweep_phase();
1551 lbm_heap_new_freelist_length();
1552
1553 if (ctx_running) {
1554 ctx_running->state = ctx_running->state & ~LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1555 }
1556 return r;
1557}
1558
1559int lbm_perform_gc(void) {
1560 return gc();
1561}
1562
1563/****************************************************/
1564/* Evaluation functions */
1565
1566
1567static void eval_symbol(eval_context_t *ctx) {
1568 lbm_uint s = lbm_dec_sym(ctx->curr_exp);
1569 if (s >= RUNTIME_SYMBOLS_START0x40000) {
1570 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1571 if (lbm_env_lookup_b(&res, ctx->curr_exp, ctx->curr_env) ||
1572 lbm_global_env_lookup(&res, ctx->curr_exp)) {
1573 ctx->r = res;
1574 ctx->app_cont = true1;
1575 return;
1576 }
1577 // Dynamic load attempt
1578 // Only symbols of kind RUNTIME can be dynamically loaded.
1579 const char *sym_str = lbm_get_name_by_symbol(s);
1580 const char *code_str = NULL((void*)0);
1581 if (!dynamic_load_callback(sym_str, &code_str)) {
1582 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), ctx->curr_exp);
1583 }
1584 lbm_value *sptr = stack_reserve(ctx, 3);
1585 sptr[0] = ctx->curr_exp;
1586 sptr[1] = ctx->curr_env;
1587 sptr[2] = RESUME(((12) << 2) | 0xF8000001u);
1588
1589 lbm_value chan;
1590 if (!create_string_channel((char *)code_str, &chan)) {
1591 gc();
1592 if (!create_string_channel((char *)code_str, &chan)) {
1593 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1594 }
1595 }
1596
1597 lbm_value loader;
1598 WITH_GC_RMBR_1(loader, lbm_heap_allocate_list_init(2,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1599 ENC_SYM_READ,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1600 chan), chan)(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} };
1601 lbm_value evaluator;
1602 WITH_GC_RMBR_1(evaluator, lbm_heap_allocate_list_init(2,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1603 ENC_SYM_EVAL,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1604 loader), loader)(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } };
1605 ctx->curr_exp = evaluator;
1606 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // dynamics should be evaluable in empty local env
1607 } else {
1608 //special symbols and extensions can be handled the same way.
1609 ctx->r = ctx->curr_exp;
1610 ctx->app_cont = true1;
1611 }
1612}
1613
1614static void eval_quote(eval_context_t *ctx) {
1615 ctx->r = get_cadr(ctx->curr_exp);
1616 ctx->app_cont = true1;
1617}
1618
1619static void eval_selfevaluating(eval_context_t *ctx) {
1620 ctx->r = ctx->curr_exp;
1621 ctx->app_cont = true1;
1622}
1623
1624static void eval_progn(eval_context_t *ctx) {
1625 lbm_value exps = get_cdr(ctx->curr_exp);
1626
1627 if (lbm_is_cons(exps)) {
1628 lbm_uint *sptr = stack_reserve(ctx, 4);
1629 sptr[0] = ctx->curr_env; // env to restore between expressions in progn
1630 sptr[1] = lbm_enc_u(0); // Has env been copied (needed for progn local bindings)
1631 sptr[3] = PROGN_REST(((4) << 2) | 0xF8000001u);
1632 get_car_and_cdr(exps, &ctx->curr_exp, &sptr[2]);
1633 if (lbm_is_symbol(sptr[2])) /* The only symbol it can be is nil */
1634 lbm_stack_drop(&ctx->K, 4);
1635 } else if (lbm_is_symbol_nil(exps)) {
1636 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1637 ctx->app_cont = true1;
1638 } else {
1639 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1640 }
1641}
1642
1643static void eval_atomic(eval_context_t *ctx) {
1644 if (is_atomic) {
1645 lbm_set_error_reason("Atomic blocks cannot be nested!");
1646 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1647 }
1648 stack_reserve(ctx, 1)[0] = EXIT_ATOMIC(((14) << 2) | 0xF8000001u);
1649 is_atomic ++;
1650 eval_progn(ctx);
1651}
1652
1653/* (call-cc (lambda (k) .... )) */
1654static void eval_callcc(eval_context_t *ctx) {
1655 lbm_value cont_array;
1656 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1657 gc();
1658 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1659 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1660 return; // dead return but static analysis doesn't know :)
1661 }
1662 }
1663 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(cont_array);
1664 memcpy(arr->data, ctx->K.data, ctx->K.sp * sizeof(lbm_uint));
1665
1666 lbm_value acont = cons_with_gc(ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u), cont_array, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1667 lbm_value arg_list = cons_with_gc(acont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1668 // Go directly into application evaluation without passing go
1669 lbm_uint *sptr = stack_reserve(ctx, 3);
1670 sptr[0] = ctx->curr_env;
1671 sptr[1] = arg_list;
1672 sptr[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
1673 ctx->curr_exp = get_cadr(ctx->curr_exp);
1674}
1675
1676// (define sym exp)
1677#define KEY1 1
1678#define VAL2 2
1679static void eval_define(eval_context_t *ctx) {
1680 lbm_value parts[3];
1681 lbm_value rest = extract_n(ctx->curr_exp, parts, 3);
1682 lbm_uint *sptr = stack_reserve(ctx, 2);
1683 if (lbm_is_symbol(parts[KEY1]) && lbm_is_symbol_nil(rest)) {
1684 lbm_uint sym_val = lbm_dec_sym(parts[KEY1]);
1685 sptr[0] = parts[KEY1];
1686 if (sym_val >= RUNTIME_SYMBOLS_START0x40000) {
1687 sptr[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
1688 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02) {
1689 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
1690 }
1691 ctx->curr_exp = parts[VAL2];
1692 return;
1693 }
1694 }
1695 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
1696}
1697
1698
1699/* Eval lambda is cheating, a lot! It does this
1700 for performance reasons. The cheats are that
1701 1. When closure is created, a reference to the local env
1702 in which the lambda was evaluated is added to the closure.
1703 Ideally it should have created a list of free variables in the function
1704 and then looked up the values of these creating a new environment.
1705 2. The global env is considered global constant. As there is no copying
1706 of environment bindings into the closure, undefine may break closures.
1707
1708 Correct closure creation is a lot more expensive than what happens here.
1709 However, one can try to write programs in such a way that closures are created
1710 seldomly. If one does that the space-usage benefits of "correct" closures
1711 may outweigh the performance gain of "incorrect" ones.
1712
1713 some obscure programs such as test_setq_local_closure.lisp does not
1714 work properly due to this cheating.
1715 */
1716// (lambda param-list body-exp) -> (closure param-list body-exp env)
1717static void eval_lambda(eval_context_t *ctx) {
1718 lbm_value vals[3];
1719 extract_n(ctx->curr_exp, vals, 3);
1720 ctx->r = allocate_closure(vals[1],vals[2], ctx->curr_env);
1721#ifdef CLEAN_UP_CLOSURES
1722 lbm_uint sym_id = 0;
1723 if (clean_cl_env_symbol) {
1724 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1725 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1726 ctx->curr_exp = app;
1727 } else if (lbm_get_symbol_by_name("clean-cl-env", &sym_id)) {
1728 clean_cl_env_symbol = lbm_enc_sym(sym_id);
1729 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1730 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1731 ctx->curr_exp = app;
1732 } else {
1733 ctx->app_cont = true1;
1734 }
1735#else
1736 ctx->app_cont = true1;
1737#endif
1738}
1739
1740// (if cond-expr then-expr else-expr)
1741static void eval_if(eval_context_t *ctx) {
1742 lbm_value cdr = get_cdr(ctx->curr_exp);
1743 lbm_value *sptr = stack_reserve(ctx, 3);
1744 sptr[0] = get_cdr(cdr);
1745 sptr[1] = ctx->curr_env;
1746 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1747 ctx->curr_exp = get_car(cdr);
1748}
1749
1750// (cond (cond-expr-1 expr-1)
1751// ...
1752// (cond-expr-N expr-N))
1753static void eval_cond(eval_context_t *ctx) {
1754 lbm_value cond1[2];
1755 lbm_value rest_conds = extract_n(ctx->curr_exp, cond1, 2);
1756
1757 // end recursion at (cond )
1758 if (lbm_is_symbol_nil(cond1[1])) {
1759 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1760 ctx->app_cont = true1;
1761 } else {
1762 // Cond is one of the few places where a bit of syntax checking takes place at runtime..
1763 // Maybe dont bother?
1764 lbm_uint len = lbm_list_length(cond1[1]);
1765 if (len != 2) {
1766 lbm_set_error_reason("Incorrect syntax in cond");
1767 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1768 }
1769 lbm_value cond_expr[2];
1770 extract_n(cond1[1], cond_expr, 2);
1771 lbm_value rest;
1772 WITH_GC(rest, lbm_heap_allocate_list_init(2,(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1773 cond_expr[1], // Then branch(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1774 cons_with_gc(ENC_SYM_COND, rest_conds , ENC_SYM_NIL)))(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
1775 lbm_value *sptr = stack_reserve(ctx, 3);
1776 sptr[0] = rest;
1777 sptr[1] = ctx->curr_env;
1778 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1779 ctx->curr_exp = cond_expr[0]; //condition;
1780 }
1781}
1782
1783static void eval_app_cont(eval_context_t *ctx) {
1784 lbm_stack_drop(&ctx->K, 1);
1785 ctx->app_cont = true1;
1786}
1787
1788// Create a named location in an environment to later receive a value.
1789static binding_location_status create_binding_location_internal(lbm_value key, lbm_value *env) {
1790
1791 if (lbm_is_symbol(key) &&
1792 (key == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u) ||
1793 key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)))
1794 return BL_OK;
1795
1796 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) { // default case
1797 lbm_value binding;
1798 lbm_value new_env_tmp;
1799 binding = lbm_cons(key, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1800 new_env_tmp = lbm_cons(binding, *env);
1801 if (lbm_is_symbol(binding) || lbm_is_symbol(new_env_tmp)) {
1802 return BL_NO_MEMORY;
1803 }
1804 *env = new_env_tmp;
1805 } else if (lbm_is_cons(key)) { // deconstruct case
1806 int r = create_binding_location_internal(get_car(key), env);
1807 if (r == BL_OK) {
1808 r = create_binding_location_internal(get_cdr(key), env);
1809 }
1810 return r;
1811 }
1812 return BL_OK;
1813}
1814
1815static void create_binding_location(lbm_value key, lbm_value *env) {
1816
1817 lbm_value env_tmp = *env;
1818 binding_location_status r = create_binding_location_internal(key, &env_tmp);
1819 if (r != BL_OK) {
1820 if (r == BL_NO_MEMORY) {
1821 env_tmp = *env;
1822 lbm_gc_mark_phase(env_tmp);
1823 gc();
1824 r = create_binding_location_internal(key, &env_tmp);
1825 }
1826 switch(r) {
1827 case BL_OK:
1828 break;
1829 case BL_NO_MEMORY:
1830 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1831 break;
1832 case BL_INCORRECT_KEY:
1833 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
1834 break;
1835 }
1836 }
1837 *env = env_tmp;
1838}
1839
1840static void let_bind_values_eval(lbm_value binds, lbm_value exp, lbm_value env, eval_context_t *ctx) {
1841
1842 if (!lbm_is_cons(binds)) {
1843 // binds better be nil or there is a programmer error.
1844 ctx->curr_exp = exp;
1845 return;
1846 }
1847
1848 // Preallocate binding locations.
1849 lbm_value curr = binds;
1850 while (lbm_is_cons(curr)) {
1851 lbm_value new_env_tmp = env;
1852 lbm_value car_curr, cdr_curr;
1853 get_car_and_cdr(curr, &car_curr, &cdr_curr);
1854 lbm_value key = get_car(car_curr);
1855 create_binding_location(key, &new_env_tmp);
1856 env = new_env_tmp;
1857 curr = cdr_curr;
1858 }
1859
1860 lbm_value car_binds;
1861 lbm_value cdr_binds;
1862 get_car_and_cdr(binds, &car_binds, &cdr_binds);
1863 lbm_value key_val[2];
1864 extract_n(car_binds, key_val, 2);
1865
1866 lbm_uint *sptr = stack_reserve(ctx, 5);
1867 sptr[0] = exp;
1868 sptr[1] = cdr_binds;
1869 sptr[2] = env;
1870 sptr[3] = key_val[0];
1871 sptr[4] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
1872 ctx->curr_exp = key_val[1];
1873 ctx->curr_env = env;
1874}
1875
1876// (var x (...)) - local binding inside of an progn
1877// var has to take, place root-level nesting within progn.
1878// (progn ... (var a 10) ...) OK!
1879// (progn ... (something (var a 10)) ... ) NOT OK!
1880/* progn stack
1881 sp-4 : env
1882 sp-3 : 0
1883 sp-2 : rest
1884 sp-1 : PROGN_REST
1885*/
1886static void eval_var(eval_context_t *ctx) {
1887
1888 if (ctx->K.sp >= 4) { // Possibly in progn
1889 lbm_value sv = ctx->K.data[ctx->K.sp - 1];
1890 if (IS_CONTINUATION(sv)(((sv) & 0xF8000001u) == 0xF8000001u) && (sv == PROGN_REST(((4) << 2) | 0xF8000001u))) {
1891 lbm_uint sp = ctx->K.sp;
1892 uint32_t is_copied = lbm_dec_as_u32(ctx->K.data[sp-3]);
1893 if (is_copied == 0) {
1894 lbm_value env;
1895 WITH_GC(env, lbm_env_copy_spine(ctx->K.data[sp-4]))(env) = (lbm_env_copy_spine(ctx->K.data[sp-4])); if (lbm_is_symbol_merror
((env))) { gc(); (env) = (lbm_env_copy_spine(ctx->K.data[sp
-4])); if (lbm_is_symbol_merror((env))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1896 ctx->K.data[sp-3] = lbm_enc_u(1);
1897 ctx->K.data[sp-4] = env;
1898 }
1899 lbm_value new_env = ctx->K.data[sp-4];
1900 lbm_value args = get_cdr(ctx->curr_exp);
1901 lbm_value key = get_car(args);
1902 create_binding_location(key, &new_env);
1903 ctx->K.data[sp-4] = new_env;
1904
1905 lbm_value v_exp = get_cadr(args);
1906 lbm_value *sptr = stack_reserve(ctx, 3);
1907 sptr[0] = new_env;
1908 sptr[1] = key;
1909 sptr[2] = PROGN_VAR(((29) << 2) | 0xF8000001u);
1910 // Activating the new environment before the evaluation of the value to be bound,
1911 // means that other variables with same name will be shadowed already in the value
1912 // body.
1913 // The way closures work, the var-variable needs to be in scope during val evaluation
1914 // for a recursive closure to be possible.
1915 ctx->curr_env = new_env;
1916 ctx->curr_exp = v_exp;
1917 return;
1918 }
1919 }
1920 lbm_set_error_reason((char*)lbm_error_str_var_outside_progn);
1921 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1922}
1923
1924// (setq x (...)) - same as (set 'x (...)) or (setvar 'x (...))
1925static void eval_setq(eval_context_t *ctx) {
1926 lbm_value parts[3];
1927 extract_n(ctx->curr_exp, parts, 3);
1928 lbm_value *sptr = stack_reserve(ctx, 3);
1929 sptr[0] = ctx->curr_env;
1930 sptr[1] = parts[1];
1931 sptr[2] = SETQ(((30) << 2) | 0xF8000001u);
1932 ctx->curr_exp = parts[2];
1933}
1934
1935static void eval_move_to_flash(eval_context_t *ctx) {
1936 lbm_value args = get_cdr(ctx->curr_exp);
1937 lbm_value *sptr = stack_reserve(ctx,2);
1938 sptr[0] = args;
1939 sptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
1940 ctx->app_cont = true1;
1941}
1942
1943// (loop list-of-local-bindings
1944// condition-exp
1945// body-exp)
1946static void eval_loop(eval_context_t *ctx) {
1947 lbm_value env = ctx->curr_env;
1948 lbm_value parts[3];
1949 extract_n(get_cdr(ctx->curr_exp), parts, 3);
1950 lbm_value *sptr = stack_reserve(ctx, 3);
1951 sptr[0] = parts[LOOP_BODY2];
1952 sptr[1] = parts[LOOP_COND1];
1953 sptr[2] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
1954 let_bind_values_eval(parts[LOOP_BINDS0], parts[LOOP_COND1], env, ctx);
1955}
1956
1957/* (trap expression)
1958 *
1959 * suggested use:
1960 * (match (trap expression)
1961 * ((exit-error (? err)) (error-handler err))
1962 * ((exit-ok (? v)) (value-handler v)))
1963 */
1964static void eval_trap(eval_context_t *ctx) {
1965
1966 lbm_value expr = get_cadr(ctx->curr_exp);
1967 lbm_value retval;
1968 WITH_GC(retval, lbm_heap_allocate_list(2))(retval) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((retval))) { gc(); (retval) = (lbm_heap_allocate_list(2)); if
(lbm_is_symbol_merror((retval))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1969 lbm_set_car(retval, ENC_SYM_EXIT_OK(((0x3000B) << 4) | 0x00000000u)); // Assume things will go well.
1970 lbm_uint *sptr = stack_reserve(ctx,3);
1971 sptr[0] = retval;
1972 sptr[1] = ctx->flags;
1973 sptr[2] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1974 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10;
1975 ctx->curr_exp = expr;
1976}
1977
1978// (let list-of-binding s
1979// body-exp)
1980static void eval_let(eval_context_t *ctx) {
1981 lbm_value env = ctx->curr_env;
1982 lbm_value parts[3];
1983 extract_n(ctx->curr_exp, parts, 3);
1984 let_bind_values_eval(parts[1], parts[2], env, ctx);
1985}
1986
1987// (and exp0 ... expN)
1988static void eval_and(eval_context_t *ctx) {
1989 lbm_value rest = get_cdr(ctx->curr_exp);
1990 if (lbm_is_symbol_nil(rest)) {
1991 ctx->app_cont = true1;
1992 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1993 } else {
1994 lbm_value *sptr = stack_reserve(ctx, 3);
1995 sptr[0] = ctx->curr_env;
1996 sptr[1] = get_cdr(rest);
1997 sptr[2] = AND(((6) << 2) | 0xF8000001u);
1998 ctx->curr_exp = get_car(rest);
1999 }
2000}
2001
2002// (or exp0 ... expN)
2003static void eval_or(eval_context_t *ctx) {
2004 lbm_value rest = get_cdr(ctx->curr_exp);
2005 if (lbm_is_symbol_nil(rest)) {
2006 ctx->app_cont = true1;
2007 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2008 } else {
2009 lbm_value *sptr = stack_reserve(ctx, 3);
2010 sptr[0] = ctx->curr_env;
2011 sptr[1] = get_cdr(rest);
2012 sptr[2] = OR(((7) << 2) | 0xF8000001u);
2013 ctx->curr_exp = get_car(rest);
2014 }
2015}
2016
2017// Pattern matching
2018// format:
2019// (match e (pattern body)
2020// (pattern body)
2021// ... )
2022//
2023// There can be an optional pattern guard:
2024// (match e (pattern guard body)
2025// ... )
2026// a guard is a boolean expression.
2027// Guards make match, pattern matching more complicated
2028// than the recv pattern matching and requires staged execution
2029// via the continuation system rather than a while loop over a list.
2030static void eval_match(eval_context_t *ctx) {
2031
2032 lbm_value rest = get_cdr(ctx->curr_exp);
2033 if (lbm_type_of(rest) == LBM_TYPE_SYMBOL0x00000000u &&
2034 rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
2035 // Someone wrote the program (match)
2036 ctx->app_cont = true1;
2037 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2038 } else {
2039 lbm_value cdr_rest;
2040 get_car_and_cdr(rest, &ctx->curr_exp, &cdr_rest);
2041 lbm_value *sptr = stack_reserve(ctx, 3);
2042 sptr[0] = cdr_rest;
2043 sptr[1] = ctx->curr_env;
2044 sptr[2] = MATCH(((9) << 2) | 0xF8000001u);
2045 }
2046}
2047
2048static void receive_base(eval_context_t *ctx, lbm_value pats, float timeout_time, bool_Bool timeout) {
2049 if (ctx->num_mail == 0) {
2050 if (timeout) {
2051 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000), false0);
2052 } else {
2053 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1,0,false0);
2054 }
2055 } else {
2056 lbm_value *msgs = ctx->mailbox;
2057 lbm_uint num = ctx->num_mail;
2058
2059 if (lbm_is_symbol_nil(pats)) {
2060 /* A receive statement without any patterns */
2061 ctx->app_cont = true1;
2062 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2063 } else {
2064 /* The common case */
2065 lbm_value e;
2066 lbm_value new_env = ctx->curr_env;
2067 int n = find_match(pats, msgs, num, &e, &new_env);
2068 if (n == FM_NEED_GC-1) {
2069 gc();
2070 new_env = ctx->curr_env;
2071 n = find_match(pats, msgs, num, &e, &new_env);
2072 if (n == FM_NEED_GC-1) {
2073 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2074 }
2075 }
2076 if (n == FM_PATTERN_ERROR-3) {
2077 lbm_set_error_reason("Incorrect pattern format for recv");
2078 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),pats);
2079 } else if (n >= 0 ) { /* Match */
2080 mailbox_remove_mail(ctx, (lbm_uint)n);
2081 ctx->curr_env = new_env;
2082 ctx->curr_exp = e;
2083 } else { /* No match go back to sleep */
2084 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
2085 if (timeout) {
2086 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2,S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000),false0);
2087 } else {
2088 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,false0);
2089 }
2090 }
2091 }
2092 }
2093 return;
2094}
2095
2096static void eval_receive_timeout(eval_context_t *ctx) {
2097 if (is_atomic) {
2098 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2099 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2100 }
2101 lbm_value timeout_val = get_cadr(ctx->curr_exp);
2102 if (!lbm_is_number(timeout_val)) {
2103 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2104 }
2105 float timeout_time = lbm_dec_as_float(timeout_val);
2106 lbm_value pats = get_cdr(get_cdr(ctx->curr_exp));
2107 receive_base(ctx, pats, timeout_time, true1);
2108}
2109
2110// Receive
2111// (recv (pattern expr)
2112// (pattern expr))
2113static void eval_receive(eval_context_t *ctx) {
2114
2115 if (is_atomic) {
2116 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2117 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
2118 }
2119 lbm_value pats = get_cdr(ctx->curr_exp);
2120 receive_base(ctx, pats, 0, false0);
2121}
2122
2123/*********************************************************/
2124/* Continuation functions */
2125
2126/* cont_set_global_env
2127 sp-1 : Key-symbol
2128 */
2129static void cont_set_global_env(eval_context_t *ctx){
2130
2131 lbm_value key;
2132 lbm_value val = ctx->r;
2133
2134 lbm_pop(&ctx->K, &key);
2135 lbm_uint dec_key = lbm_dec_sym(key);
2136 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
2137 lbm_value *global_env = lbm_get_global_env();
2138 lbm_uint orig_env = global_env[ix_key];
2139 lbm_value new_env;
2140 // A key is a symbol and should not need to be remembered.
2141 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2142
2143 global_env[ix_key] = new_env;
2144 ctx->r = val;
2145
2146 ctx->app_cont = true1;
2147
2148 return;
2149}
2150
2151static void cont_resume(eval_context_t *ctx) {
2152 lbm_pop_2(&ctx->K, &ctx->curr_env, &ctx->curr_exp);
2153}
2154
2155static void cont_progn_rest(eval_context_t *ctx) {
2156 lbm_value *sptr = get_stack_ptr(ctx, 3);
2157
2158 lbm_value rest = sptr[2];
2159 lbm_value env = sptr[0];
2160
2161 lbm_value rest_car, rest_cdr;
2162 get_car_and_cdr(rest, &rest_car, &rest_cdr);
2163 ctx->curr_exp = rest_car;
2164 ctx->curr_env = env;
2165 if (lbm_is_symbol_nil(rest_cdr)) {
2166 // allow for tail recursion
2167 lbm_stack_drop(&ctx->K, 3);
2168 } else {
2169 sptr[2] = rest_cdr;
2170 stack_reserve(ctx, 1)[0] = PROGN_REST(((4) << 2) | 0xF8000001u);
2171 }
2172}
2173
2174static void cont_wait(eval_context_t *ctx) {
2175
2176 lbm_value cid_val;
2177 lbm_pop(&ctx->K, &cid_val);
2178 lbm_cid cid = (lbm_cid)lbm_dec_i(cid_val);
2179
2180 bool_Bool exists = false0;
2181
2182 lbm_blocked_iterator(context_exists, &cid, &exists);
2183 lbm_running_iterator(context_exists, &cid, &exists);
2184
2185 if (ctx_running->id == cid) {
2186 exists = true1;
2187 }
2188
2189 if (exists) {
2190 lbm_value *sptr = stack_reserve(ctx, 2);
2191 sptr[0] = lbm_enc_i(cid);
2192 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2193 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2194 ctx->app_cont = true1;
2195 yield_ctx(50000);
2196 } else {
2197 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2198 ctx->app_cont = true1;
2199 }
2200}
2201
2202static lbm_value perform_setvar(lbm_value key, lbm_value val, lbm_value env) {
2203
2204 lbm_uint s = lbm_dec_sym(key);
2205 if (s >= RUNTIME_SYMBOLS_START0x40000) {
2206 lbm_value new_env = lbm_env_modify_binding(env, key, val);
2207 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2208 lbm_uint ix_key = lbm_dec_sym(key) & GLOBAL_ENV_MASK0x1F;
2209 lbm_value *glob_env = lbm_get_global_env();
2210 new_env = lbm_env_modify_binding(glob_env[ix_key], key, val);
2211 glob_env[ix_key] = new_env;
2212 }
2213 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2214 lbm_set_error_reason((char*)lbm_error_str_variable_not_bound);
2215 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), key);
2216 }
2217 return val;
2218 }
2219 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2220 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // unreachable
2221}
2222
2223static void apply_setvar(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2224 if (nargs == 2 && lbm_is_symbol(args[0])) {
2225 lbm_value res;
2226 WITH_GC(res, perform_setvar(args[0], args[1], ctx->curr_env))(res) = (perform_setvar(args[0], args[1], ctx->curr_env));
if (lbm_is_symbol_merror((res))) { gc(); (res) = (perform_setvar
(args[0], args[1], ctx->curr_env)); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2227 ctx->r = args[1];
2228 lbm_stack_drop(&ctx->K, nargs+1);
2229 ctx->app_cont = true1;
2230 } else {
2231 if (nargs == 2) lbm_set_error_reason((char*)lbm_error_str_incorrect_arg);
2232 else lbm_set_error_reason((char*)lbm_error_str_num_args);
2233 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2234 }
2235}
2236
2237static void apply_read_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, bool_Bool program, bool_Bool incremental) {
2238 if (nargs == 1) {
2239 lbm_value chan = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2240 if (lbm_type_of_functional(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2241 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2242 gc();
2243 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2244 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2245 }
2246 }
2247 } else if (lbm_type_of(args[0]) == LBM_TYPE_CHANNEL0x90000000u) {
2248 chan = args[0];
2249 } else {
2250 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2251 }
2252 lbm_value *sptr = get_stack_ptr(ctx, 2);
2253
2254 // If we are inside a reader, its settings are stored.
2255 sptr[0] = lbm_enc_u(ctx->flags); // flags stored.
2256 sptr[1] = chan;
2257 lbm_value *rptr = stack_reserve(ctx,1);
2258 rptr[0] = READ_DONE(((20) << 2) | 0xF8000001u);
2259
2260 // Each reader starts in a fresh situation
2261 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
2262
2263 if (program) {
2264 if (incremental) {
2265 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2266 lbm_value *rptr1 = stack_reserve(ctx,3);
2267 rptr1[0] = chan;
2268 rptr1[1] = ctx->curr_env;
2269 rptr1[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
2270 } else {
2271 ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2272 lbm_value *rptr1 = stack_reserve(ctx,4);
2273 rptr1[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2274 rptr1[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2275 rptr1[2] = chan;
2276 rptr1[3] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
2277 }
2278 }
2279 rptr = stack_reserve(ctx,3); // reuse of variable rptr
2280 rptr[0] = chan;
2281 rptr[1] = lbm_enc_u(1);
2282 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
2283 ctx->app_cont = true1;
2284 } else {
2285 lbm_set_error_reason((char*)lbm_error_str_num_args);
2286 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2287 }
2288}
2289
2290static void apply_read_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2291 apply_read_base(args,nargs,ctx,true1,false0);
2292}
2293
2294static void apply_read_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2295 apply_read_base(args,nargs,ctx,true1,true1);
2296}
2297
2298static void apply_read(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2299 apply_read_base(args,nargs,ctx,false0,false0);
2300}
2301
2302static void apply_spawn_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, uint32_t context_flags) {
2303
2304 lbm_uint stack_size = EVAL_CPS_DEFAULT_STACK_SIZE256;
2305 lbm_uint closure_pos = 0;
2306 char *name = NULL((void*)0);
2307
2308 if (nargs >= 1 &&
2309 lbm_is_closure(args[0])) {
2310 closure_pos = 0;
2311 } else if (nargs >= 2 &&
2312 lbm_is_number(args[0]) &&
2313 lbm_is_closure(args[1])) {
2314 stack_size = lbm_dec_as_u32(args[0]);
2315 closure_pos = 1;
2316 } else if (nargs >= 2 &&
2317 lbm_is_array_r(args[0]) &&
2318 lbm_is_closure(args[1])) {
2319 name = lbm_dec_str(args[0]);
2320 closure_pos = 1;
2321 }else if (nargs >= 3 &&
2322 lbm_is_array_r(args[0]) &&
2323 lbm_is_number(args[1]) &&
2324 lbm_is_closure(args[2])) {
2325 stack_size = lbm_dec_as_u32(args[1]);
2326 closure_pos = 2;
2327 name = lbm_dec_str(args[0]);
2328 } else {
2329 if (context_flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01)
2330 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN_TRAP(((0x30005) << 4) | 0x00000000u));
2331 else
2332 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN(((0x30004) << 4) | 0x00000000u));
2333 }
2334
2335 lbm_value cl[3];
2336 extract_n(get_cdr(args[closure_pos]), cl, 3);
2337 lbm_value curr_param = cl[CLO_PARAMS0];
2338 lbm_value clo_env = cl[CLO_ENV2];
2339 lbm_uint i = closure_pos + 1;
2340 while (lbm_is_cons(curr_param) && i <= nargs) {
2341 lbm_value entry = cons_with_gc(get_car(curr_param), args[i], clo_env);
2342 lbm_value aug_env = cons_with_gc(entry, clo_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2343 clo_env = aug_env;
2344 curr_param = get_cdr(curr_param);
2345 i ++;
2346 }
2347
2348 lbm_stack_drop(&ctx->K, nargs+1);
2349
2350 lbm_value program = cons_with_gc(cl[CLO_BODY1], ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), clo_env);
2351
2352 lbm_cid cid = lbm_create_ctx_parent(program,
2353 clo_env,
2354 stack_size,
2355 lbm_get_current_cid(),
2356 context_flags,
2357 name);
2358 ctx->r = lbm_enc_i(cid);
2359 ctx->app_cont = true1;
2360}
2361
2362static void apply_spawn(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2363 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00);
2364}
2365
2366static void apply_spawn_trap(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2367 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01);
2368}
2369
2370static void apply_yield(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2371 if (is_atomic) {
2372 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2373 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2374 }
2375 if (nargs == 1 && lbm_is_number(args[0])) {
2376 lbm_uint ts = lbm_dec_as_u32(args[0]);
2377 lbm_stack_drop(&ctx->K, nargs+1);
2378 yield_ctx(ts);
2379 } else {
2380 lbm_set_error_reason((char*)lbm_error_str_no_number);
2381 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2382 }
2383}
2384
2385static void apply_sleep(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2386 if (is_atomic) {
2387 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2388 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2389 }
2390 if (nargs == 1 && lbm_is_number(args[0])) {
2391 lbm_uint ts = (lbm_uint)(1000000.0f * lbm_dec_as_float(args[0]));
2392 lbm_stack_drop(&ctx->K, nargs+1);
2393 yield_ctx(ts);
2394 } else {
2395 lbm_set_error_reason((char*)lbm_error_str_no_number);
2396 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2397 }
2398}
2399
2400static void apply_wait(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2401 if (nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2402 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2403 lbm_value *sptr = get_stack_ptr(ctx, 2);
2404 sptr[0] = lbm_enc_i(cid);
2405 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2406 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2407 ctx->app_cont = true1;
2408 yield_ctx(50000);
2409 } else {
2410 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_WAIT(((0x30007) << 4) | 0x00000000u));
2411 }
2412}
2413
2414/* (eval expr)
2415 (eval env expr) */
2416static void apply_eval(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2417 if ( nargs == 1) {
2418 ctx->curr_exp = args[0];
2419 } else if (nargs == 2) {
2420 ctx->curr_exp = args[1];
2421 ctx->curr_env = args[0];
2422 } else {
2423 lbm_set_error_reason((char*)lbm_error_str_num_args);
2424 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL(((0x30008) << 4) | 0x00000000u));
2425 }
2426 lbm_stack_drop(&ctx->K, nargs+1);
2427}
2428
2429static void apply_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2430 int prg_pos = 0;
2431 if (nargs == 2) {
2432 prg_pos = 1;
2433 ctx->curr_env = args[0];
2434 }
2435 if (nargs == 1 || nargs == 2) {
2436 lbm_value prg = args[prg_pos];
2437 lbm_value app_cont;
2438 lbm_value app_cont_prg;
2439 lbm_value new_prg;
2440 lbm_value prg_copy;
2441
2442 int len = -1;
2443 WITH_GC(prg_copy, lbm_list_copy(&len, prg))(prg_copy) = (lbm_list_copy(&len, prg)); if (lbm_is_symbol_merror
((prg_copy))) { gc(); (prg_copy) = (lbm_list_copy(&len, prg
)); if (lbm_is_symbol_merror((prg_copy))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2444 lbm_stack_drop(&ctx->K, nargs+1);
2445
2446 if (ctx->K.sp > nargs+2) { // if there is a continuation
2447 app_cont = cons_with_gc(ENC_SYM_APP_CONT(((0x111) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2448 app_cont_prg = cons_with_gc(app_cont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2449 new_prg = lbm_list_append(app_cont_prg, ctx->program);
2450 new_prg = lbm_list_append(prg_copy, new_prg);
2451 } else {
2452 new_prg = lbm_list_append(prg_copy, ctx->program);
2453 }
2454 if (!lbm_is_list(new_prg)) {
2455 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2456 }
2457 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);
2458 ctx->program = get_cdr(new_prg);
2459 ctx->curr_exp = get_car(new_prg);
2460 } else {
2461 lbm_set_error_reason((char*)lbm_error_str_num_args);
2462 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2463 }
2464}
2465
2466static void apply_send(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2467 if (nargs == 2) {
2468 if (lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2469 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2470 lbm_value msg = args[1];
2471 lbm_value status = lbm_find_receiver_and_send(cid, msg);
2472 /* return the status */
2473 lbm_stack_drop(&ctx->K, nargs+1);
2474 ctx->r = status;
2475 ctx->app_cont = true1;
2476 } else {
2477 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2478 }
2479 } else {
2480 lbm_set_error_reason((char*)lbm_error_str_num_args);
2481 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2482 }
2483}
2484
2485static void apply_ok(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2486 lbm_value ok_val = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2487 if (nargs >= 1) {
2488 ok_val = args[0];
2489 }
2490 ctx->r = ok_val;
2491 ok_ctx();
2492}
2493
2494static void apply_error(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2495 (void) ctx;
2496 lbm_value err_val = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
2497 if (nargs >= 1) {
2498 err_val = args[0];
2499 }
2500 error_at_ctx(err_val, ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
2501}
2502
2503// (map f arg-list)
2504static void apply_map(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2505 if (nargs == 2 && lbm_is_cons(args[1])) {
2506 lbm_value *sptr = get_stack_ptr(ctx, 3);
2507
2508 lbm_value f = args[0];
2509 lbm_value h = get_car(args[1]);
2510 lbm_value t = get_cdr(args[1]);
2511
2512 lbm_value appli_1;
2513 lbm_value appli;
2514 WITH_GC(appli_1, lbm_heap_allocate_list(2))(appli_1) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli_1))) { gc(); (appli_1) = (lbm_heap_allocate_list(2));
if (lbm_is_symbol_merror((appli_1))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2515 WITH_GC_RMBR_1(appli, lbm_heap_allocate_list(2), appli_1)(appli) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli))) { lbm_gc_mark_phase(appli_1); gc(); (appli) = (lbm_heap_allocate_list
(2)); if (lbm_is_symbol_merror((appli))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2516
2517 lbm_value appli_0 = get_cdr(appli_1);
2518
2519 lbm_set_car_and_cdr(appli_0, h, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2520 lbm_set_car(appli_1, ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u));
2521
2522 lbm_set_car_and_cdr(get_cdr(appli), appli_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2523 lbm_set_car(appli, f);
2524
2525 lbm_value elt = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), appli);
2526 sptr[0] = t; // reuse stack space
2527 sptr[1] = ctx->curr_env;
2528 sptr[2] = elt;
2529 lbm_value *rptr = stack_reserve(ctx,4);
2530 rptr[0] = elt;
2531 rptr[1] = appli;
2532 rptr[2] = appli_0;
2533 rptr[3] = MAP(((26) << 2) | 0xF8000001u);
2534 ctx->curr_exp = appli;
2535 } else if (nargs == 2 && lbm_is_symbol_nil(args[1])) {
2536 lbm_stack_drop(&ctx->K, 3);
2537 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2538 ctx->app_cont = true1;
2539 return;
2540 } else {
2541 lbm_set_error_reason((char*)lbm_error_str_num_args);
2542 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_MAP(((0x3000D) << 4) | 0x00000000u));
2543 }
2544}
2545
2546static void apply_reverse(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2547 if (nargs == 1 && lbm_is_list(args[0])) {
2548 lbm_value curr = args[0];
2549
2550 lbm_value new_list = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2551 while (lbm_is_cons(curr)) {
2552 lbm_value tmp = cons_with_gc(get_car(curr), new_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2553 new_list = tmp;
2554 curr = get_cdr(curr);
2555 }
2556 lbm_stack_drop(&ctx->K, 2);
2557 ctx->r = new_list;
2558 ctx->app_cont = true1;
2559 } else {
2560 lbm_set_error_reason("Reverse requires a list argument");
2561 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_REVERSE(((0x3000E) << 4) | 0x00000000u));
2562 }
2563}
2564
2565static void apply_flatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2566 if (nargs == 1) {
2567
2568 lbm_value v = flatten_value(args[0]);
2569 if ( v == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)) {
2570 gc();
2571 v = flatten_value(args[0]);
2572 }
2573
2574 if (lbm_is_symbol(v)) {
2575 error_at_ctx(v, ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2576 } else {
2577 lbm_stack_drop(&ctx->K, 2);
2578 ctx->r = v;
2579 ctx->app_cont = true1;
2580 }
2581 return;
2582 }
2583 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2584}
2585
2586static void apply_unflatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2587 if(nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2588 lbm_array_header_t *array;
2589 array = (lbm_array_header_t *)get_car(args[0]);
2590
2591 lbm_flat_value_t fv;
2592 fv.buf = (uint8_t*)array->data;
2593 fv.buf_size = array->size;
2594 fv.buf_pos = 0;
2595
2596 lbm_value res;
2597
2598 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2599 if (lbm_unflatten_value(&fv, &res)) {
2600 ctx->r = res;
2601 }
2602 lbm_stack_drop(&ctx->K, 2);
2603 ctx->app_cont = true1;
2604 return;
2605 }
2606 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_UNFLATTEN(((0x30010) << 4) | 0x00000000u));
2607}
2608
2609static void apply_kill(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2610 if (nargs == 2 && lbm_is_number(args[0])) {
2611 lbm_cid cid = lbm_dec_as_i32(args[0]);
2612
2613 if (ctx->id == cid) {
2614 ctx->r = args[1];
2615 finish_ctx();
2616 return;
2617 }
2618 mutex_lock(&qmutex);
2619 eval_context_t *found = NULL((void*)0);
2620 found = lookup_ctx_nm(&blocked, cid);
2621 if (found)
2622 drop_ctx_nm(&blocked, found);
2623 else
2624 found = lookup_ctx_nm(&queue, cid);
2625 if (found)
2626 drop_ctx_nm(&queue, found);
2627
2628 if (found) {
2629 found->K.data[found->K.sp - 1] = KILL(((40) << 2) | 0xF8000001u);
2630 found->r = args[1];
2631 found->app_cont = true1;
2632 enqueue_ctx_nm(&queue,found);
2633 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2634 } else {
2635 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2636 }
2637 lbm_stack_drop(&ctx->K, 3);
2638 ctx->app_cont = true1;
2639 mutex_unlock(&qmutex);
2640 return;
2641 }
2642 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_KILL(((0x30011) << 4) | 0x00000000u));
2643}
2644
2645// (merge comparator list1 list2)
2646static void apply_merge(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2647 if (nargs == 3 && lbm_is_list(args[1]) && lbm_is_list(args[2])) {
2648
2649 if (!lbm_is_closure(args[0])) {
2650 lbm_value closure;
2651 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2652 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2653 lbm_value cl1 = lbm_cdr(closure);
2654 lbm_value par;
2655 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2656 lbm_set_car(cl1, par);
2657 lbm_value cl2 = lbm_cdr(cl1);
2658 lbm_value body;
2659 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2660 lbm_set_car(cl2, body);
2661 lbm_value cl3 = lbm_cdr(cl2);
2662 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2663
2664 // Replace operator on stack with closure and rest of the code is
2665 // compatible.
2666 args[0] = closure;
2667 }
2668
2669 // Copy input lists for functional behaviour at top-level
2670 // merge itself is in-place in the copied lists.
2671 lbm_value a;
2672 lbm_value b;
2673 int len_a = -1;
2674 int len_b = -1;
2675 WITH_GC(a, lbm_list_copy(&len_a, args[1]))(a) = (lbm_list_copy(&len_a, args[1])); if (lbm_is_symbol_merror
((a))) { gc(); (a) = (lbm_list_copy(&len_a, args[1])); if
(lbm_is_symbol_merror((a))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } };
2676 WITH_GC_RMBR_1(b, lbm_list_copy(&len_b, args[2]), a)(b) = (lbm_list_copy(&len_b, args[2])); if (lbm_is_symbol_merror
((b))) { lbm_gc_mark_phase(a); gc(); (b) = (lbm_list_copy(&
len_b, args[2])); if (lbm_is_symbol_merror((b))) { error_ctx(
(((0x23) << 4) | 0x00000000u)); } };
2677
2678 if (len_a == 0) {
2679 ctx->r = b;
2680 lbm_stack_drop(&ctx->K, 4);
2681 ctx->app_cont = true1;
2682 return;
2683 }
2684 if (len_b == 0) {
2685 ctx->r = a;
2686 lbm_stack_drop(&ctx->K, 4);
2687 ctx->app_cont = true1;
2688 return;
2689 }
2690
2691 args[1] = a; // keep safe by replacing the original on stack.
2692 args[2] = b;
2693
2694 lbm_value a_1 = a;
2695 lbm_value a_rest = lbm_cdr(a);
2696 lbm_value b_1 = b;
2697 lbm_value b_rest = lbm_cdr(b);
2698
2699 lbm_value cl[3]; // Comparator closure
2700 extract_n(lbm_cdr(args[0]), cl, 3);
2701 lbm_value cmp_env = cl[CLO_ENV2];
2702 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2703 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2704 lbm_uint len = lbm_list_length(cl[CLO_PARAMS0]);
2705 if (len == 2) {
2706 par1 = get_car(cl[CLO_PARAMS0]);
2707 par2 = get_cadr(cl[CLO_PARAMS0]);
2708 lbm_value new_env0;
2709 lbm_value new_env;
2710 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a_1)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a_1))); if (
lbm_is_symbol_merror((new_env0))) { gc(); (new_env0) = (lbm_env_set
(cmp_env, par1, lbm_car(a_1))); if (lbm_is_symbol_merror((new_env0
))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2711 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b_1)),new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1))); if (
lbm_is_symbol_merror((new_env))) { lbm_gc_mark_phase(new_env0
); gc(); (new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1
))); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2712 cmp_env = new_env;
2713 } else {
2714 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2715 }
2716 lbm_set_cdr(a_1, b_1);
2717 lbm_set_cdr(b_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2718 lbm_value cmp = cl[CLO_BODY1];
2719
2720 lbm_stack_drop(&ctx->K, 4); // TODO: Optimize drop 4 alloc 10 into alloc 6
2721 lbm_uint *sptr = stack_reserve(ctx, 10);
2722 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged list
2723 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged list
2724 sptr[2] = a_1;
2725 sptr[3] = a_rest;
2726 sptr[4] = b_rest;
2727 sptr[5] = cmp;
2728 sptr[6] = cmp_env;
2729 sptr[7] = par1;
2730 sptr[8] = par2;
2731 sptr[9] = MERGE_REST(((43) << 2) | 0xF8000001u);
2732 ctx->curr_exp = cl[CLO_BODY1];
2733 ctx->curr_env = cmp_env;
2734 return;
2735 }
2736 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MERGE(((0x30013) << 4) | 0x00000000u));
2737}
2738
2739// (sort comparator list)
2740static void apply_sort(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2741 if (nargs == 2 && lbm_is_list(args[1])) {
2742
2743 if (!lbm_is_closure(args[0])) {
2744 lbm_value closure;
2745 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2746 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2747 lbm_value cl1 = lbm_cdr(closure);
2748 lbm_value par;
2749 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2750 lbm_set_car(cl1, par);
2751 lbm_value cl2 = lbm_cdr(cl1);
2752 lbm_value body;
2753 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2754 lbm_set_car(cl2, body);
2755 lbm_value cl3 = lbm_cdr(cl2);
2756 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2757
2758 // Replace operator on stack with closure and rest of the code is
2759 // compatible.
2760 args[0] = closure;
2761 }
2762
2763 int len = -1;
2764 lbm_value list_copy;
2765 WITH_GC(list_copy, lbm_list_copy(&len, args[1]))(list_copy) = (lbm_list_copy(&len, args[1])); if (lbm_is_symbol_merror
((list_copy))) { gc(); (list_copy) = (lbm_list_copy(&len,
args[1])); if (lbm_is_symbol_merror((list_copy))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2766 if (len <= 1) {
2767 lbm_stack_drop(&ctx->K, 3);
2768 ctx->r = list_copy;
2769 ctx->app_cont = true1;
2770 return;
2771 }
2772
2773 args[1] = list_copy; // Keep safe, original replaced on stack.
2774
2775 // Take the headmost 2, 1-element sublists.
2776 lbm_value a = list_copy;
2777 lbm_value b = lbm_cdr(a);
2778 lbm_value rest = lbm_cdr(b);
2779 // Do not terminate b. keep rest of list safe from GC in the following
2780 // closure extraction.
2781 //lbm_set_cdr(a, b); // This is void
2782
2783 lbm_value cl[3]; // Comparator closure
2784 extract_n(lbm_cdr(args[0]), cl, 3);
2785 lbm_value cmp_env = cl[CLO_ENV2];
2786 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2787 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2788 lbm_uint cl_len = lbm_list_length(cl[CLO_PARAMS0]);
2789 if (cl_len == 2) {
2790 par1 = get_car(cl[CLO_PARAMS0]);
2791 par2 = get_cadr(cl[CLO_PARAMS0]);
2792 lbm_value new_env0;
2793 lbm_value new_env;
2794 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a))); if (lbm_is_symbol_merror
((new_env0))) { gc(); (new_env0) = (lbm_env_set(cmp_env, par1
, lbm_car(a))); if (lbm_is_symbol_merror((new_env0))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2795 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b)), new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { lbm_gc_mark_phase(new_env0); gc(); (new_env) =
(lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { error_ctx((((0x23) << 4) | 0x00000000u))
; } };
2796 cmp_env = new_env;
2797 } else {
2798 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2799 }
2800 lbm_value cmp = cl[CLO_BODY1];
2801
2802 // Terminate the comparator argument list.
2803 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2804
2805 lbm_stack_drop(&ctx->K, 3); //TODO: optimize drop 3, alloc 20 into alloc 17
2806 lbm_uint *sptr = stack_reserve(ctx, 20);
2807 sptr[0] = cmp;
2808 sptr[1] = cmp_env;
2809 sptr[2] = par1;
2810 sptr[3] = par2;
2811 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged accumulation of sublists
2812 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged accumulation of sublists
2813 sptr[6] = rest;
2814 sptr[7] = lbm_enc_i(1);
2815 sptr[8] = lbm_enc_i(len); //TODO: 28 bit i vs 32 bit i
2816 sptr[9] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
2817 sptr[10] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged sublist
2818 sptr[11] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged sublist
2819 sptr[12] = a;
2820 sptr[13] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no a_rest, 1 element lists in layer 1.
2821 sptr[14] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no b_rest, 1 element lists in layer 1.
2822 sptr[15] = cmp;
2823 sptr[16] = cmp_env;
2824 sptr[17] = par1;
2825 sptr[18] = par2;
2826 sptr[19] = MERGE_REST(((43) << 2) | 0xF8000001u);
2827 ctx->curr_exp = cmp;
2828 ctx->curr_env = cmp_env;
2829 return;
2830 }
2831 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
2832}
2833
2834static void apply_rest_args(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2835 lbm_value res;
2836 if (lbm_env_lookup_b(&res, ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ctx->curr_env)) {
2837 if (nargs == 1 && lbm_is_number(args[0])) {
2838 int32_t ix = lbm_dec_as_i32(args[0]);
2839 res = lbm_index_list(res, ix);
2840 }
2841 ctx->r = res;
2842 } else {
2843 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2844 }
2845 lbm_stack_drop(&ctx->K, nargs+1);
2846 ctx->app_cont = true1;
2847}
2848
2849/* (rotate list-expr dist/dir-expr) */
2850static void apply_rotate(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2851 if (nargs == 2 && lbm_is_list(args[0]) && lbm_is_number(args[1])) {
2852 int len = -1;
2853 lbm_value ls = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2854 WITH_GC(ls, lbm_list_copy(&len, args[0]))(ls) = (lbm_list_copy(&len, args[0])); if (lbm_is_symbol_merror
((ls))) { gc(); (ls) = (lbm_list_copy(&len, args[0])); if
(lbm_is_symbol_merror((ls))) { error_ctx((((0x23) << 4
) | 0x00000000u)); } };
2855 int dist = lbm_dec_as_i32(args[1]);
2856 if (len > 0 && dist != 0) {
2857 int d = dist;
2858 if (dist > 0) {
2859 ls = lbm_list_destructive_reverse(ls);
2860 } else {
2861 d = -dist;
2862 }
2863
2864 lbm_value start = ls;
2865 lbm_value end = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2866 lbm_value curr = start;
2867 while (lbm_is_cons(curr)) {
2868 end = curr;
2869 curr = get_cdr(curr);
2870 }
2871
2872 for (int i = 0; i < d; i ++) {
2873 lbm_value a = start;
2874 start = lbm_cdr(start);
2875 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2876 lbm_set_cdr(end, a);
2877 end = a;
2878 }
2879 ls = start;
2880 if (dist > 0) {
2881 ls = lbm_list_destructive_reverse(ls);
2882 }
2883 }
2884 lbm_stack_drop(&ctx->K, nargs+1);
2885 ctx->app_cont = true1;
2886 ctx->r = ls;
2887 return;
2888 }
2889 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2890}
2891
2892/***************************************************/
2893/* Application lookup table */
2894
2895typedef void (*apply_fun)(lbm_value *, lbm_uint, eval_context_t *);
2896static const apply_fun fun_table[] =
2897 {
2898 apply_setvar,
2899 apply_read,
2900 apply_read_program,
2901 apply_read_eval_program,
2902 apply_spawn,
2903 apply_spawn_trap,
2904 apply_yield,
2905 apply_wait,
2906 apply_eval,
2907 apply_eval_program,
2908 apply_send,
2909 apply_ok,
2910 apply_error,
2911 apply_map,
2912 apply_reverse,
2913 apply_flatten,
2914 apply_unflatten,
2915 apply_kill,
2916 apply_sleep,
2917 apply_merge,
2918 apply_sort,
2919 apply_rest_args,
2920 apply_rotate,
2921 };
2922
2923/***************************************************/
2924/* Application of function that takes arguments */
2925/* passed over the stack. */
2926
2927static void application(eval_context_t *ctx, lbm_value *fun_args, lbm_uint arg_count) {
2928 /* If arriving here, we know that the fun is a symbol.
2929 * and can be a built in operation or an extension.
2930 */
2931 lbm_value fun = fun_args[0];
2932
2933 lbm_uint fun_val = lbm_dec_sym(fun);
2934 lbm_uint fun_kind = SYMBOL_KIND(fun_val)((fun_val) >> 16);
2935
2936 switch (fun_kind) {
2937 case SYMBOL_KIND_EXTENSION1: {
2938 extension_fptr f = extension_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)].fptr;
2939
2940 lbm_value ext_res;
2941 WITH_GC(ext_res, f(&fun_args[1], arg_count))(ext_res) = (f(&fun_args[1], arg_count)); if (lbm_is_symbol_merror
((ext_res))) { gc(); (ext_res) = (f(&fun_args[1], arg_count
)); if (lbm_is_symbol_merror((ext_res))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2942 if (lbm_is_error(ext_res)) { //Error other than merror
2943 error_at_ctx(ext_res, fun);
2944 }
2945 lbm_stack_drop(&ctx->K, arg_count + 1);
2946
2947 ctx->app_cont = true1;
2948 ctx->r = ext_res;
2949
2950 if (blocking_extension) {
2951 blocking_extension = false0;
2952 if (blocking_extension_timeout) {
2953 blocking_extension_timeout = false0;
2954 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, blocking_extension_timeout_us,true1);
2955 } else {
2956 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,true1);
2957 }
2958 mutex_unlock(&blocking_extension_mutex);
2959 }
2960 } break;
2961 case SYMBOL_KIND_FUNDAMENTAL2:
2962 call_fundamental(SYMBOL_IX(fun_val)((fun_val) & 0xFFFF), &fun_args[1], arg_count, ctx);
2963 break;
2964 case SYMBOL_KIND_APPFUN3:
2965 fun_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)](&fun_args[1], arg_count, ctx);
2966 break;
2967 default:
2968 // Symbols that are "special" but not in the way caught above
2969 // ends up here.
2970 lbm_set_error_reason("Symbol does not represent a function");
2971 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),fun_args[0]);
2972 break;
2973 }
2974}
2975
2976static void cont_closure_application_args(eval_context_t *ctx) {
2977 lbm_uint* sptr = get_stack_ptr(ctx, 5);
2978
2979 lbm_value arg_env = (lbm_value)sptr[0];
2980 lbm_value exp = (lbm_value)sptr[1];
2981 lbm_value clo_env = (lbm_value)sptr[2];
2982 lbm_value params = (lbm_value)sptr[3];
2983 lbm_value args = (lbm_value)sptr[4];
2984
2985 lbm_value car_params, cdr_params;
2986 get_car_and_cdr(params, &car_params, &cdr_params);
2987
2988 bool_Bool a_nil = lbm_is_symbol_nil(args);
2989 bool_Bool p_nil = lbm_is_symbol_nil(cdr_params);
2990
2991 lbm_value binder = allocate_binding(car_params, ctx->r, clo_env);
2992
2993 if (!a_nil && !p_nil) {
2994 lbm_value car_args, cdr_args;
2995 get_car_and_cdr(args, &car_args, &cdr_args);
2996 sptr[2] = binder;
2997 sptr[3] = cdr_params;
2998 sptr[4] = cdr_args;
2999 stack_reserve(ctx,1)[0] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
3000 ctx->curr_exp = car_args;
3001 ctx->curr_env = arg_env;
3002 } else if (a_nil && p_nil) {
3003 // Arguments and parameters match up in number
3004 lbm_stack_drop(&ctx->K, 5);
3005 ctx->curr_env = binder;
3006 ctx->curr_exp = exp;
3007 } else if (p_nil) {
3008 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), binder);
3009 sptr[2] = rest_binder;
3010 sptr[3] = get_cdr(args);
3011 sptr[4] = get_car(rest_binder); // last element of rest_args so far
3012 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3013 ctx->curr_exp = get_car(args);
3014 ctx->curr_env = arg_env;
3015 } else {
3016 lbm_set_error_reason((char*)lbm_error_str_num_args);
3017 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
3018 }
3019}
3020
3021
3022static void cont_closure_args_rest(eval_context_t *ctx) {
3023 lbm_uint* sptr = get_stack_ptr(ctx, 5);
3024 lbm_value arg_env = (lbm_value)sptr[0];
3025 lbm_value exp = (lbm_value)sptr[1];
3026 lbm_value clo_env = (lbm_value)sptr[2];
3027 lbm_value args = (lbm_value)sptr[3];
3028 lbm_value last = (lbm_value)sptr[4];
3029 lbm_cons_t* heap = lbm_heap_state.heap;
3030
3031 lbm_value binding = lbm_heap_state.freelist;
3032 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3033 gc();
3034 binding = lbm_heap_state.freelist;
3035 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3036 }
3037 lbm_uint binding_ix = lbm_dec_ptr(binding);
3038 lbm_heap_state.freelist = heap[binding_ix].cdr;
3039 lbm_heap_state.num_alloc += 1;
3040 heap[binding_ix].car = ctx->r;
3041 heap[binding_ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3042
3043
3044 lbm_set_cdr(last, binding);
3045 sptr[4] = binding;
3046
3047 if (args == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3048 lbm_stack_drop(&ctx->K, 5);
3049 ctx->curr_env = clo_env;
3050 ctx->curr_exp = exp;
3051 } else {
3052 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3053 sptr[3] = get_cdr(args);
3054 ctx->curr_exp = get_car(args);
3055 ctx->curr_env = arg_env;
3056 }
3057}
3058
3059static void cont_application_args(eval_context_t *ctx) {
3060 lbm_uint *sptr = get_stack_ptr(ctx, 3);
3061
3062 lbm_value env = sptr[0];
3063 lbm_value rest = sptr[1];
3064 lbm_value count = sptr[2];
3065
3066 ctx->curr_env = env;
3067 sptr[0] = ctx->r; // Function 1st then Arguments
3068 if (lbm_is_cons(rest)) {
3069 lbm_cons_t *cell = lbm_ref_cell(rest);
3070 sptr[1] = env;
3071 sptr[2] = cell->cdr;
3072 lbm_value *rptr = stack_reserve(ctx,2);
3073 rptr[0] = count + (1 << LBM_VAL_SHIFT4);
3074 rptr[1] = APPLICATION_ARGS(((5) << 2) | 0xF8000001u);
3075 ctx->curr_exp = cell->car;
3076 } else {
3077 // No more arguments
3078 lbm_stack_drop(&ctx->K, 2);
3079 lbm_uint nargs = lbm_dec_u(count);
3080 lbm_value *args = get_stack_ptr(ctx, (uint32_t)(nargs + 1));
3081 application(ctx,args, nargs);
3082 }
3083}
3084
3085static void cont_and(eval_context_t *ctx) {
3086 lbm_value env;
3087 lbm_value rest;
3088 lbm_value arg = ctx->r;
3089 lbm_pop_2(&ctx->K, &rest, &env);
3090 if (lbm_is_symbol_nil(arg)) {
3091 ctx->app_cont = true1;
3092 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3093 } else if (lbm_is_symbol_nil(rest)) {
3094 ctx->app_cont = true1;
3095 } else {
3096 lbm_value *sptr = stack_reserve(ctx, 3);
3097 sptr[0] = env;
3098 sptr[1] = get_cdr(rest);
3099 sptr[2] = AND(((6) << 2) | 0xF8000001u);
3100 ctx->curr_env = env;
3101 ctx->curr_exp = get_car(rest);
3102 }
3103}
3104
3105static void cont_or(eval_context_t *ctx) {
3106 lbm_value env;
3107 lbm_value rest;
3108 lbm_value arg = ctx->r;
3109 lbm_pop_2(&ctx->K, &rest, &env);
3110 if (!lbm_is_symbol_nil(arg)) {
3111 ctx->app_cont = true1;
3112 } else if (lbm_is_symbol_nil(rest)) {
3113 ctx->app_cont = true1;
3114 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3115 } else {
3116 lbm_value *sptr = stack_reserve(ctx, 3);
3117 sptr[0] = env;
3118 sptr[1] = get_cdr(rest);
3119 sptr[2] = OR(((7) << 2) | 0xF8000001u);
3120 ctx->curr_exp = get_car(rest);
3121 ctx->curr_env = env;
3122 }
3123}
3124
3125static int fill_binding_location(lbm_value key, lbm_value value, lbm_value env) {
3126 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) {
3127 if (key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return FB_OK0;
3128 lbm_env_modify_binding(env,key,value);
3129 return FB_OK0;
3130 } else if (lbm_is_cons(key) &&
3131 lbm_is_cons(value)) {
3132 int r = fill_binding_location(get_car(key), get_car(value), env);
3133 if (r == FB_OK0) {
3134 r = fill_binding_location(get_cdr(key), get_cdr(value), env);
3135 }
3136 return r;
3137 }
3138 return FB_TYPE_ERROR-1;
3139}
3140
3141static void cont_bind_to_key_rest(eval_context_t *ctx) {
3142
3143 lbm_value *sptr = get_stack_ptr(ctx, 4);
3144
3145 lbm_value rest = sptr[1];
3146 lbm_value env = sptr[2];
3147 lbm_value key = sptr[3];
3148
3149 if (fill_binding_location(key, ctx->r, env) < 0) {
3150 lbm_set_error_reason("Incorrect type of name/key in let-binding");
3151 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
3152 }
3153
3154 if (lbm_is_cons(rest)) {
3155 lbm_value car_rest = get_car(rest);
3156 lbm_value key_val[2];
3157 extract_n(car_rest, key_val, 2);
3158
3159 sptr[1] = get_cdr(rest);
3160 sptr[3] = key_val[0];
3161 stack_reserve(ctx,1)[0] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
3162 ctx->curr_exp = key_val[1];
3163 ctx->curr_env = env;
3164 } else {
3165 // Otherwise evaluate the expression in the populated env
3166 ctx->curr_exp = sptr[0];
3167 ctx->curr_env = env;
3168 lbm_stack_drop(&ctx->K, 4);
3169 }
3170}
3171
3172static void cont_if(eval_context_t *ctx) {
3173
3174 lbm_value arg = ctx->r;
3175
3176 lbm_value *sptr = pop_stack_ptr(ctx, 2);
3177
3178 ctx->curr_env = sptr[1];
3179 if (lbm_is_symbol_nil(arg)) {
3180 ctx->curr_exp = get_cadr(sptr[0]); // else branch
3181 } else {
3182 ctx->curr_exp = get_car(sptr[0]); // then branch
3183 }
3184}
3185
3186static void cont_match(eval_context_t *ctx) {
3187 lbm_value e = ctx->r;
3188 bool_Bool do_gc = false0;
3189
3190 lbm_uint *sptr = get_stack_ptr(ctx, 2);
3191 lbm_value patterns = (lbm_value)sptr[0];
3192 lbm_value orig_env = (lbm_value)sptr[1]; // restore enclosing environment.
3193 lbm_value new_env = orig_env;
3194
3195 if (lbm_is_symbol_nil(patterns)) {
3196 // no more patterns
3197 lbm_stack_drop(&ctx->K, 2);
3198 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
3199 ctx->app_cont = true1;
3200 } else if (lbm_is_cons(patterns)) {
3201 lbm_value match_case = get_car(patterns);
3202 lbm_value pattern = get_car(match_case);
3203 lbm_value n1 = get_cadr(match_case);
3204 lbm_value n2 = get_cadr(get_cdr(match_case));
3205 lbm_value body;
3206 bool_Bool check_guard = false0;
3207 if (lbm_is_symbol_nil(n2)) { // TODO: Not a very robust check.
3208 body = n1;
3209 } else {
3210 body = n2;
3211 check_guard = true1;
3212 }
3213
3214 bool_Bool is_match = match(pattern, e, &new_env, &do_gc);
3215 if (do_gc) {
3216 gc();
3217 do_gc = false0;
3218 new_env = orig_env;
3219 is_match = match(pattern, e, &new_env, &do_gc);
3220 if (do_gc) {
3221 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3222 }
3223 }
3224 if (is_match) {
3225 if (check_guard) {
3226 lbm_value *rptr = stack_reserve(ctx,5);
3227 sptr[0] = get_cdr(patterns);
3228 sptr[1] = ctx->curr_env;
3229 rptr[0] = MATCH(((9) << 2) | 0xF8000001u);
3230 rptr[1] = new_env;
3231 rptr[2] = body;
3232 rptr[3] = e;
3233 rptr[4] = MATCH_GUARD(((27) << 2) | 0xF8000001u);
3234 ctx->curr_env = new_env;
3235 ctx->curr_exp = n1; // The guard
3236 } else {
3237 lbm_stack_drop(&ctx->K, 2);
3238 ctx->curr_env = new_env;
3239 ctx->curr_exp = body;
3240 }
3241 } else {
3242 // set up for checking of next pattern
3243 sptr[0] = get_cdr(patterns);
3244 sptr[1] = orig_env;
3245 stack_reserve(ctx,1)[0] = MATCH(((9) << 2) | 0xF8000001u);
3246 // leave r unaltered
3247 ctx->app_cont = true1;
3248 }
3249 } else {
3250 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MATCH(((0x108) << 4) | 0x00000000u));
3251 }
3252}
3253
3254static void cont_exit_atomic(eval_context_t *ctx) {
3255 is_atomic --;
3256 ctx->app_cont = true1;
3257}
3258
3259static void cont_map(eval_context_t *ctx) {
3260 lbm_value *sptr = get_stack_ptr(ctx, 6);
3261
3262 lbm_value ls = sptr[0];
3263 lbm_value env = sptr[1];
3264 lbm_value t = sptr[3];
3265 lbm_set_car(t, ctx->r); // update car field tailmost position.
3266 if (lbm_is_cons(ls)) {
3267 lbm_value next, rest;
3268 get_car_and_cdr(ls, &next, &rest);
3269 sptr[0] = rest;
3270 stack_reserve(ctx,1)[0] = MAP(((26) << 2) | 0xF8000001u);
3271 lbm_set_car(sptr[5], next); // new arguments
3272
3273 lbm_value elt = cons_with_gc(ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3274 lbm_set_cdr(t, elt);
3275 sptr[3] = elt; // (r1 ... rN . (nil . nil))
3276 ctx->curr_exp = sptr[4];
3277 ctx->curr_env = env;
3278 } else {
3279 ctx->r = sptr[2]; //head of result list
3280 ctx->curr_env = env;
3281 lbm_stack_drop(&ctx->K, 6);
3282 ctx->app_cont = true1;
3283 }
3284}
3285
3286static void cont_match_guard(eval_context_t *ctx) {
3287 if (lbm_is_symbol_nil(ctx->r)) {
3288 lbm_value e;
3289 lbm_pop(&ctx->K, &e);
3290 lbm_stack_drop(&ctx->K, 2);
3291 ctx->r = e;
3292 ctx->app_cont = true1;
3293 } else {
3294 lbm_value body;
3295 lbm_value env;
3296 lbm_stack_drop(&ctx->K, 1);
3297 lbm_pop_2(&ctx->K, &body, &env);
3298 lbm_stack_drop(&ctx->K, 3);
3299 ctx->curr_env = env;
3300 ctx->curr_exp = body;
3301 }
3302}
3303
3304static void cont_terminate(eval_context_t *ctx) {
3305 error_ctx(ctx->r);
3306}
3307
3308static void cont_loop(eval_context_t *ctx) {
3309 lbm_value *sptr = get_stack_ptr(ctx, 2);
3310 stack_reserve(ctx,1)[0] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
3311 ctx->curr_exp = sptr[1];
3312}
3313
3314static void cont_loop_condition(eval_context_t *ctx) {
3315 if (lbm_is_symbol_nil(ctx->r)) {
3316 lbm_stack_drop(&ctx->K, 2);
3317 ctx->app_cont = true1; // A loop returns nil? Makes sense to me... but in general?
3318 return;
3319 }
3320 lbm_value *sptr = get_stack_ptr(ctx, 2);
3321 stack_reserve(ctx,1)[0] = LOOP(((41) << 2) | 0xF8000001u);
3322 ctx->curr_exp = sptr[0];
3323}
3324
3325static void cont_merge_rest(eval_context_t *ctx) {
3326 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3327
3328 // If comparator returns true (result is in ctx->r):
3329 // "a" should be moved to the last element position in merged list.
3330 // A new element from "a_rest" should be moved into comparator argument 1 pos.
3331 // else
3332 // "b" should be moved to last element position in merged list.
3333 // A new element from "b_rest" should be moved into comparator argument 2 pos.
3334 //
3335 // If a_rest or b_rest is NIL:
3336 // we are done, the remaining elements of
3337 // non_nil list should be appended to merged list.
3338 // else
3339 // Set up for a new comparator evaluation and recurse.
3340 lbm_value a = sptr[2];
3341 lbm_value b = lbm_cdr(a);
3342 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate 1 element list
3343
3344 if (ctx->r == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) { // Comparison false
3345
3346 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3347 sptr[0] = b;
3348 sptr[1] = b;
3349 } else {
3350 lbm_set_cdr(sptr[1], b);
3351 sptr[1] = b;
3352 }
3353 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3354 lbm_set_cdr(a, sptr[3]);
3355 lbm_set_cdr(sptr[1], a);
3356 ctx->r = sptr[0];
3357 lbm_stack_drop(&ctx->K, 9);
3358 ctx->app_cont = true1;
3359 return;
3360 } else {
3361 b = sptr[4];
3362 sptr[4] = lbm_cdr(sptr[4]);
3363 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3364 }
3365 } else {
3366 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3367 sptr[0] = a;
3368 sptr[1] = a;
3369 } else {
3370 lbm_set_cdr(sptr[1], a);
3371 sptr[1] = a;
3372 }
3373
3374 if (sptr[3] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3375 lbm_set_cdr(b, sptr[4]);
3376 lbm_set_cdr(sptr[1], b);
3377 ctx->r = sptr[0];
3378 lbm_stack_drop(&ctx->K, 9);
3379 ctx->app_cont = true1;
3380 return;
3381 } else {
3382 a = sptr[3];
3383 sptr[3] = lbm_cdr(sptr[3]);
3384 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3385 }
3386 }
3387 lbm_set_cdr(a, b);
3388 sptr[2] = a;
3389
3390 lbm_value par1 = sptr[7];
3391 lbm_value par2 = sptr[8];
3392 lbm_value cmp_body = sptr[5];
3393 lbm_value cmp_env = sptr[6];
3394 // Environment should be preallocated already at this point
3395 // and the operations below should never need GC.
3396 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3397 lbm_value new_env = lbm_env_set(new_env0, par2, lbm_car(b));
3398 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3399 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3400 }
3401 cmp_env = new_env;
3402
3403 stack_reserve(ctx,1)[0] = MERGE_REST(((43) << 2) | 0xF8000001u);
3404 ctx->curr_exp = cmp_body;
3405 ctx->curr_env = cmp_env;
3406}
3407
3408// merge_layer stack contents
3409// s[sp-9] = cmp
3410// s[sp-8] = cmp_env
3411// s[sp-7] = par1
3412// s[sp-6] = par2
3413// s[sp-5] = acc - first cell
3414// s[sp-4] = acc - last cell
3415// s[sp-3] = rest;
3416// s[sp-2] = layer
3417// s[sp-1] = length or original list
3418//
3419// ctx->r merged sublist
3420static void cont_merge_layer(eval_context_t *ctx) {
3421 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3422 lbm_int layer = lbm_dec_i(sptr[7]);
3423 lbm_int len = lbm_dec_i(sptr[8]);
3424
3425 lbm_value r_curr = ctx->r;
3426 while (lbm_is_cons(r_curr)) {
3427 lbm_value next = lbm_cdr(r_curr);
3428 if (next == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3429 break;
3430 }
3431 r_curr = next;
3432 }
3433
3434 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3435 sptr[4] = ctx->r;
3436 sptr[5] = r_curr;
3437 } else {
3438 lbm_set_cdr(sptr[5], ctx->r); // accumulate merged sublists.
3439 sptr[5] = r_curr;
3440 }
3441
3442 lbm_value layer_rest = sptr[6];
3443 // switch layer or done ?
3444 if (layer_rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3445 if (layer * 2 >= len) {
3446 ctx->r = sptr[4];
3447 ctx->app_cont = true1;
3448 lbm_stack_drop(&ctx->K, 9);
3449 return;
3450 } else {
3451 // Setup for merges of the next layer
3452 layer = layer * 2;
3453 sptr[7] = lbm_enc_i(layer);
3454 layer_rest = sptr[4]; // continue on the accumulation of all sublists.
3455 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3456 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3457 }
3458 }
3459 // merge another sublist based on current layer.
3460 lbm_value a_list = layer_rest;
3461 // build sublist a
3462 lbm_value curr = layer_rest;
3463 for (int i = 0; i < layer-1; i ++) {
3464 if (lbm_is_cons(curr)) {
3465 curr = lbm_cdr(curr);
3466 } else {
3467 break;
3468 }
3469 }
3470 layer_rest = lbm_cdr(curr);
3471 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3472
3473 lbm_value b_list = layer_rest;
3474 // build sublist b
3475 curr = layer_rest;
3476 for (int i = 0; i < layer-1; i ++) {
3477 if (lbm_is_cons(curr)) {
3478 curr = lbm_cdr(curr);
3479 } else {
3480 break;
3481 }
3482 }
3483 layer_rest = lbm_cdr(curr);
3484 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3485
3486 sptr[6] = layer_rest;
3487
3488 if (b_list == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3489 stack_reserve(ctx,1)[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3490 ctx->r = a_list;
3491 ctx->app_cont = true1;
3492 return;
3493 }
3494 // Set up for a merge of sublists.
3495
3496 lbm_value a_rest = lbm_cdr(a_list);
3497 lbm_value b_rest = lbm_cdr(b_list);
3498 lbm_value a = a_list;
3499 lbm_value b = b_list;
3500 lbm_set_cdr(a, b);
3501 // Terminating the b list would be incorrect here
3502 // if there was any chance that the environment update below
3503 // performs GC.
3504 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3505
3506 lbm_value cmp_body = sptr[0];
3507 lbm_value cmp_env = sptr[1];
3508 lbm_value par1 = sptr[2];
3509 lbm_value par2 = sptr[3];
3510 // Environment should be preallocated already at this point
3511 // and the operations below should never need GC.
3512 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3513 lbm_value new_env = lbm_env_set(cmp_env, par2, lbm_car(b));
3514 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3515 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3516 }
3517 cmp_env = new_env;
3518
3519 lbm_uint *merge_cont = stack_reserve(ctx, 11);
3520 merge_cont[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3521 merge_cont[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3522 merge_cont[2] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3523 merge_cont[3] = a;
3524 merge_cont[4] = a_rest;
3525 merge_cont[5] = b_rest;
3526 merge_cont[6] = cmp_body;
3527 merge_cont[7] = cmp_env;
3528 merge_cont[8] = par1;
3529 merge_cont[9] = par2;
3530 merge_cont[10] = MERGE_REST(((43) << 2) | 0xF8000001u);
3531 ctx->curr_exp = cmp_body;
3532 ctx->curr_env = cmp_env;
3533 return;
3534}
3535
3536/****************************************************/
3537/* READER */
3538
3539static void read_finish(lbm_char_channel_t *str, eval_context_t *ctx) {
3540
3541 /* Tokenizer reached "end of file"
3542 The parser could be in a state where it needs
3543 more tokens to correctly finish an expression.
3544
3545 Three cases
3546 1. The program / expression is malformed and the context should die.
3547 2. We are finished reading a program and should close off the
3548 internal representation with a closing parenthesis. Then
3549 apply continuation.
3550 3. We are finished reading an expression and should
3551 apply the continuation.
3552
3553 In case 3, we should find the READ_DONE at sp - 1.
3554 In case 2, we should find the READ_DONE at sp - 5.
3555
3556 */
3557
3558 if (lbm_is_symbol(ctx->r)) {
3559 lbm_uint sym_val = lbm_dec_sym(ctx->r);
3560 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
3561 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
3562 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3563 }
3564 }
3565
3566 if (ctx->K.data[ctx->K.sp-1] == READ_DONE(((20) << 2) | 0xF8000001u) &&
3567 lbm_dec_u(ctx->K.data[ctx->K.sp-3]) == 0) {
3568 /* successfully finished reading an expression (CASE 3) */
3569 ctx->app_cont = true1;
3570 } else if (ctx->K.sp > 4 && ctx->K.data[ctx->K.sp - 4] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3571 lbm_value env;
3572 lbm_value s;
3573 lbm_value sym;
3574 lbm_pop_3(&ctx->K, &sym, &env, &s);
3575 ctx->curr_env = env;
3576 ctx->app_cont = true1; // Program evaluated and result is in ctx->r.
3577 } else if (ctx->K.sp > 5 && ctx->K.data[ctx->K.sp - 5] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3578 /* successfully finished reading a program (CASE 2) */
3579 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3580 ctx->app_cont = true1;
3581 } else {
3582 /* Parsing failed */
3583 if (lbm_channel_row(str) == 1 &&
3584 lbm_channel_column(str) == 1 ){
3585 // eof at empty stream.
3586 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3587 ctx->app_cont = true1;
3588 } else {
3589 lbm_set_error_reason((char*)lbm_error_str_parse_eof);
3590 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3591 }
3592 lbm_channel_reader_close(str);
3593 }
3594}
3595
3596/* cont_read_next_token
3597 sp-2 : Stream
3598 sp-1 : Grab row
3599*/
3600static void cont_read_next_token(eval_context_t *ctx) {
3601 lbm_value *sptr = get_stack_ptr(ctx, 2);
3602 lbm_value stream = sptr[0];
3603 lbm_value grab_row0 = sptr[1];
3604
3605 lbm_char_channel_t *chan = lbm_dec_channel(stream);
3606 if (chan == NULL((void*)0) || chan->state == NULL((void*)0)) {
3607 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3608 }
3609
3610 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3611 lbm_stack_drop(&ctx->K, 2);
3612 read_finish(chan, ctx);
3613 return;
3614 }
3615 /* Eat whitespace and comments */
3616 if (!tok_clean_whitespace(chan)) {
3617 sptr[0] = stream;
3618 sptr[1] = lbm_enc_u(0);
3619 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3620 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3621 return;
3622 }
3623 /* After eating whitespace we may be at end of file/stream */
3624 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3625 lbm_stack_drop(&ctx->K, 2);
3626 read_finish(chan, ctx);
3627 return;
3628 }
3629
3630 if (lbm_dec_u(grab_row0)) {
3631 ctx->row0 = (int32_t)lbm_channel_row(chan);
3632 }
3633
3634 /* Attempt to extract tokens from the character stream */
3635 int n = 0;
3636 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3637 unsigned int string_len = 0;
3638
3639 /*
3640 * SYNTAX
3641 */
3642 uint32_t match;
3643 n = tok_syntax(chan, &match);
3644 if (n > 0) {
3645 if (!lbm_channel_drop(chan, (unsigned int)n)) {
3646 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3647 }
3648 ctx->app_cont = true1;
3649 lbm_uint do_next = 0;
3650 switch(match) {
3651 case TOKOPENPAR1u: {
3652 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3653 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3654 lbm_value *rptr = stack_reserve(ctx,5);
3655 rptr[0] = stream;
3656 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3657 rptr[2] = stream;
3658 rptr[3] = lbm_enc_u(0);
3659 rptr[4] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3660 ctx->r = ENC_SYM_OPENPAR(((0x70) << 4) | 0x00000000u);
3661 } return;
3662 case TOKCLOSEPAR2u: {
3663 lbm_stack_drop(&ctx->K, 2);
3664 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3665 } return;
3666 case TOKOPENBRACK3u: {
3667 sptr[0] = stream;
3668 sptr[1] = READ_START_ARRAY(((24) << 2) | 0xF8000001u);
3669 lbm_value *rptr = stack_reserve(ctx, 3);
3670 rptr[0] = stream;
3671 rptr[1] = lbm_enc_u(0);
3672 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3673 ctx->r = ENC_SYM_OPENBRACK(((0x80) << 4) | 0x00000000u);
3674 } return;
3675 case TOKCLOSEBRACK4u:
3676 lbm_stack_drop(&ctx->K, 2);
3677 ctx->r = ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u);
3678 return;
3679 case TOKDOT5u:
3680 lbm_stack_drop(&ctx->K, 2);
3681 ctx->r = ENC_SYM_DOT(((0x76) << 4) | 0x00000000u);
3682 return;
3683 case TOKDONTCARE6u:
3684 lbm_stack_drop(&ctx->K, 2);
3685 ctx->r = ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u);
3686 return;
3687 case TOKQUOTE7u:
3688 do_next = READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u);
3689 break;
3690 case TOKBACKQUOTE8u: {
3691 sptr[0] = QQ_EXPAND_START(((35) << 2) | 0xF8000001u);
3692 sptr[1] = stream;
3693 lbm_value *rptr = stack_reserve(ctx, 2);
3694 rptr[0] = lbm_enc_u(0);
3695 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3696 ctx->app_cont = true1;
3697 } return;
3698 case TOKCOMMAAT9u:
3699 do_next = READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u);
3700 break;
3701 case TOKCOMMA10u:
3702 do_next = READ_COMMA_RESULT(((23) << 2) | 0xF8000001u);
3703 break;
3704 case TOKMATCHANY11u:
3705 lbm_stack_drop(&ctx->K, 2);
3706 ctx->r = ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u);
3707 return;
3708 case TOKOPENCURL12u: {
3709 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3710 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3711 lbm_value *rptr = stack_reserve(ctx,2);
3712 rptr[0] = stream;
3713 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3714 ctx->r = ENC_SYM_PROGN(((0x102) << 4) | 0x00000000u);
3715 } return;
3716 case TOKCLOSECURL13u:
3717 lbm_stack_drop(&ctx->K, 2);
3718 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3719 return;
3720 case TOKCONSTSTART14u: /* fall through */
3721 case TOKCONSTEND15u:
3722 case TOKCONSTSYMSTR16u: {
3723 if (match == TOKCONSTSTART14u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3724 if (match == TOKCONSTEND15u) ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3725 if (match == TOKCONSTSYMSTR16u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04;
3726 sptr[0] = stream;
3727 sptr[1] = lbm_enc_u(0);
3728 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3729 ctx->app_cont = true1;
3730 } return;
3731 default:
3732 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3733 }
3734 sptr[0] = do_next;
3735 sptr[1] = stream;
3736 lbm_value *rptr = stack_reserve(ctx, 2);
3737 rptr[0] = lbm_enc_u(0);
3738 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3739 ctx->app_cont = true1;
3740 return;
3741 } else if (n < 0) goto retry_token;
3742
3743 /*
3744 * STRING
3745 */
3746 n = tok_string(chan, &string_len);
3747 if (n >= 2) {
3748 lbm_channel_drop(chan, (unsigned int)n);
3749 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3750 gc();
3751 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3752 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3753 return; // dead return but static analysis does not know that.
3754 }
3755 }
3756 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(res);
3757 char *data = (char*)arr->data;
3758 memset(data,0, string_len + 1);
3759 memcpy(data, tokpar_sym_str, string_len);
3760 lbm_stack_drop(&ctx->K, 2);
3761 ctx->r = res;
3762 ctx->app_cont = true1;
3763 return;
3764 } else if (n < 0) goto retry_token;
3765
3766 /*
3767 * FLOAT
3768 */
3769 token_float f_val;
3770 n = tok_double(chan, &f_val);
3771 if (n > 0) {
3772 lbm_channel_drop(chan, (unsigned int) n);
3773 switch(f_val.type) {
3774 case TOKTYPEF32107u:
3775 WITH_GC(res, lbm_enc_float((float)f_val.value))(res) = (lbm_enc_float((float)f_val.value)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (lbm_enc_float((float)f_val.value));
if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
3776 break;
3777 case TOKTYPEF64108u:
3778 res = lbm_enc_double(f_val.value);
3779 break;
3780 default:
3781 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3782 }
3783 lbm_stack_drop(&ctx->K, 2);
3784 ctx->r = res;
3785 ctx->app_cont = true1;
3786 return;
3787 } else if (n < 0) goto retry_token;
3788
3789 /*
3790 * INTEGER
3791 */
3792 token_int int_result;
3793 n = tok_integer(chan, &int_result);
3794 if (n > 0) {
3795 lbm_channel_drop(chan, (unsigned int)n);
3796 switch(int_result.type) {
3797 case TOKTYPEBYTE100u:
3798 res = lbm_enc_char((uint8_t)(int_result.negative ? -int_result.value : int_result.value));
3799 break;
3800 case TOKTYPEI101u:
3801 res = lbm_enc_i((lbm_int)(int_result.negative ? -int_result.value : int_result.value));
3802 break;
3803 case TOKTYPEU102u:
3804 res = lbm_enc_u((lbm_uint)(int_result.negative ? -int_result.value : int_result.value));
3805 break;
3806 case TOKTYPEI32103u:
3807 WITH_GC(res, lbm_enc_i32((int32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i32((int32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i32((int32_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3808 break;
3809 case TOKTYPEU32104u:
3810 WITH_GC(res,lbm_enc_u32((uint32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u32((uint32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u32((uint32_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3811 break;
3812 case TOKTYPEI64105u:
3813 WITH_GC(res,lbm_enc_i64((int64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i64((int64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i64((int64_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3814 break;
3815 case TOKTYPEU64106u:
3816 WITH_GC(res,lbm_enc_u64((uint64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u64((uint64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u64((uint64_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3817 break;
3818 default:
3819 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3820 }
3821 lbm_stack_drop(&ctx->K, 2);
3822 ctx->r = res;
3823 ctx->app_cont = true1;
3824 return;
3825 } else if (n < 0) goto retry_token;
3826
3827 /*
3828 * SYMBOL
3829 */
3830 n = tok_symbol(chan);
3831 if (n > 0) {
3832 lbm_channel_drop(chan, (unsigned int) n);
3833 lbm_uint symbol_id;
3834 if (lbm_get_symbol_by_name(tokpar_sym_str, &symbol_id)) {
3835 res = lbm_enc_sym(symbol_id);
3836 } else {
3837 int r = 0;
3838 if (n > 4 &&
3839 tokpar_sym_str[0] == 'e' &&
3840 tokpar_sym_str[1] == 'x' &&
3841 tokpar_sym_str[2] == 't' &&
3842 tokpar_sym_str[3] == '-') {
3843 lbm_uint ext_id;
3844 lbm_uint ext_name_len = (lbm_uint)n + 1;
3845 char *ext_name = lbm_malloc(ext_name_len);
3846 if (!ext_name) {
3847 gc();
3848 ext_name = lbm_malloc(ext_name_len);
3849 }
3850 if (ext_name) {
3851 memcpy(ext_name, tokpar_sym_str, ext_name_len);
3852 r = lbm_add_extension(ext_name, lbm_extensions_default);
3853 if (!lbm_lookup_extension_id(ext_name, &ext_id)) {
3854 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3855 }
3856 symbol_id = ext_id;
3857 } else {
3858 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3859 }
3860 } else {
3861 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04 &&
3862 ctx->flags & EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08) {
3863 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id, true1); //flash
3864 if (!r) {
3865 lbm_set_error_reason((char*)lbm_error_str_flash_error);
3866 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3867 }
3868 } else {
3869 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3870 if (!r) {
3871 gc();
3872 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3873 }
3874 }
3875 }
3876 if (r) {
3877 res = lbm_enc_sym(symbol_id);
3878 } else {
3879 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3880 }
3881 }
3882 lbm_stack_drop(&ctx->K, 2);
3883 ctx->r = res;
3884 ctx->app_cont = true1;
3885 return;
3886 } else if (n == TOKENIZER_NEED_MORE-1) {
3887 goto retry_token;
3888 } else if (n <= TOKENIZER_STRING_ERROR-2) {
3889 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3890 }
3891
3892 /*
3893 * CHAR
3894 */
3895 char c_val;
3896 n = tok_char(chan, &c_val);
3897 if(n > 0) {
3898 lbm_channel_drop(chan,(unsigned int) n);
3899 lbm_stack_drop(&ctx->K, 2);
3900 ctx->r = lbm_enc_char((uint8_t)c_val);
3901 ctx->app_cont = true1;
3902 return;
3903 }else if (n < 0) goto retry_token;
3904
3905 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3906
3907 retry_token:
3908 if (n == TOKENIZER_NEED_MORE-1) {
3909 sptr[0] = stream;
3910 sptr[1] = lbm_enc_u(0);
3911 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3912 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3913 return;
3914 }
3915 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3916}
3917
3918static void cont_read_start_array(eval_context_t *ctx) {
3919 lbm_value *sptr = get_stack_ptr(ctx, 1);
3920 lbm_value stream = sptr[0];
3921
3922 lbm_char_channel_t *str = lbm_dec_channel(stream);
3923 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
3924 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3925 }
3926
3927 lbm_uint num_free = lbm_memory_longest_free();
3928 lbm_uint initial_size = (lbm_uint)((float)num_free * 0.9);
3929 if (initial_size == 0) {
3930 gc();
3931 num_free = lbm_memory_longest_free();
3932 initial_size = (lbm_uint)((float)num_free * 0.9);
3933 if (initial_size == 0) {
3934 lbm_channel_reader_close(str);
3935 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3936 }
3937 }
3938
3939 if (lbm_is_number(ctx->r)) {
3940 lbm_value array;
3941 initial_size = sizeof(lbm_uint) * initial_size;
3942
3943 if (!lbm_heap_allocate_array(&array, initial_size)) {
3944 lbm_set_error_reason("Out of memory while reading.");
3945 lbm_channel_reader_close(str);
3946 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3947 // NOTE: If array is not created evaluation ends here.
3948 // Static analysis seems unaware.
3949 }
3950
3951 sptr[0] = array;
3952 lbm_value *rptr = stack_reserve(ctx, 4);
3953 rptr[0] = lbm_enc_u(initial_size);
3954 rptr[1] = lbm_enc_u(0);
3955 rptr[2] = stream;
3956 rptr[3] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3957 ctx->app_cont = true1;
3958 } else {
3959 lbm_channel_reader_close(str);
3960 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3961 }
3962}
3963
3964static void cont_read_append_array(eval_context_t *ctx) {
3965 lbm_uint *sptr = get_stack_ptr(ctx, 4);
3966
3967 lbm_value array = sptr[0];
1
'array' initialized here
→
3968 lbm_value size = lbm_dec_as_u32(sptr[1]);
3969 lbm_value ix = lbm_dec_as_u32(sptr[2]);
3970 lbm_value stream = sptr[3];
3971
3972 if (ix >= (size - 1)) {
2
←
Assuming the condition is false
→
3
←
Taking false branch
→
3973 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3974 }
3975
3976 // get_car can return nil. Whose value is 0!
3977 // So static Analysis is right about this being a potential NULL pointer.
3978 // However, if the array was created correcly to begin with, it should be fine.
3979 lbm_value arr_car = get_car(array);
4
←
Passing value via 1st parameter 'a'
→
5
←
Calling 'get_car'
→
14
←
Returning from 'get_car'
→
15
←
'arr_car' initialized to 0
→
3980 lbm_array_header_t *arr = (lbm_array_header_t*)arr_car;
16
←
'arr' initialized to a null pointer value
→
3981
3982 if (lbm_is_number(ctx->r)) {
17
←
Calling 'lbm_is_number'
→
21
←
Returning from 'lbm_is_number'
→
22
←
Assuming the condition is true
→
23
←
Taking true branch
→
3983 ((uint8_t*)arr->data)[ix] = (uint8_t)lbm_dec_as_u32(ctx->r);
24
←
Access to field 'data' results in a dereference of a null pointer (loaded from variable 'arr')
3984
3985 sptr[2] = lbm_enc_u(ix + 1);
3986 lbm_value *rptr = stack_reserve(ctx, 4);
3987 rptr[0] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3988 rptr[1] = stream;
3989 rptr[2] = lbm_enc_u(0);
3990 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3991 ctx->app_cont = true1;
3992 } else if (lbm_is_symbol(ctx->r) && ctx->r == ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u)) {
3993 lbm_uint array_size = ix / sizeof(lbm_uint);
3994
3995 if (ix % sizeof(lbm_uint) != 0) {
3996 array_size = array_size + 1;
3997 }
3998 lbm_memory_shrink((lbm_uint*)arr->data, array_size);
3999 arr->size = ix;
4000 lbm_stack_drop(&ctx->K, 4);
4001 ctx->r = array;
4002 ctx->app_cont = true1;
4003 } else {
4004 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
4005 }
4006}
4007
4008static void cont_read_append_continue(eval_context_t *ctx) {
4009 lbm_value *sptr = get_stack_ptr(ctx, 3);
4010
4011 lbm_value first_cell = sptr[0];
4012 lbm_value last_cell = sptr[1];
4013 lbm_value stream = sptr[2];
4014
4015 lbm_char_channel_t *str = lbm_dec_channel(stream);
4016 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4017 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4018 }
4019
4020 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4021
4022 switch(ctx->r) {
4023 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4024 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4025 lbm_set_cdr(last_cell, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate the list
4026 ctx->r = first_cell;
4027 } else {
4028 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4029 }
4030 lbm_stack_drop(&ctx->K, 3);
4031 /* Skip reading another token and apply the continuation */
4032 ctx->app_cont = true1;
4033 return;
4034 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4035 lbm_value *rptr = stack_reserve(ctx, 4);
4036 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4037 rptr[1] = stream;
4038 rptr[2] = lbm_enc_u(0);
4039 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4040 ctx->app_cont = true1;
4041 } return;
4042 }
4043 }
4044 lbm_value new_cell = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4045 if (lbm_is_symbol_merror(new_cell)) {
4046 lbm_channel_reader_close(str);
4047 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4048 return;
4049 }
4050 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4051 lbm_set_cdr(last_cell, new_cell);
4052 last_cell = new_cell;
4053 } else {
4054 first_cell = last_cell = new_cell;
4055 }
4056 sptr[0] = first_cell;
4057 sptr[1] = last_cell;
4058 sptr[2] = stream; // unchanged.
4059 lbm_value *rptr = stack_reserve(ctx, 4);
4060 rptr[0] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
4061 rptr[1] = stream;
4062 rptr[2] = lbm_enc_u(0);
4063 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4064 ctx->app_cont = true1;
4065}
4066
4067static void cont_read_eval_continue(eval_context_t *ctx) {
4068 lbm_value env;
4069 lbm_value stream;
4070 lbm_pop_2(&ctx->K, &env, &stream);
4071
4072 lbm_char_channel_t *str = lbm_dec_channel(stream);
4073 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4074 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4075 }
4076
4077 ctx->row1 = (lbm_int)str->row(str);
4078
4079 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4080
4081 switch(ctx->r) {
4082 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4083 ctx->app_cont = true1;
4084 return;
4085 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4086 // This case is a bit mysterious.
4087 // A dot, may in reality be an error in this location.
4088 lbm_value *rptr = stack_reserve(ctx, 4);
4089 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4090 rptr[1] = stream;
4091 rptr[2] = lbm_enc_u(0);
4092 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4093 ctx->app_cont = true1;
4094 } return;
4095 }
4096 }
4097
4098 lbm_value *rptr = stack_reserve(ctx, 6);
4099 rptr[0] = stream;
4100 rptr[1] = env;
4101 rptr[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
4102 rptr[3] = stream;
4103 rptr[4] = lbm_enc_u(1);
4104 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4105 rptr[6] = lbm_enc_u(ctx->flags);
4106 rptr[7] = POP_READER_FLAGS(((47) << 2) | 0xF8000001u);
4107 ctx->curr_env = env;
4108 ctx->curr_exp = ctx->r;
4109}
4110
4111static void cont_read_expect_closepar(eval_context_t *ctx) {
4112 lbm_value res;
4113 lbm_value stream;
4114
4115 lbm_pop_2(&ctx->K, &res, &stream);
4116
4117 lbm_char_channel_t *str = lbm_dec_channel(stream);
4118 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4119 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4120 }
4121
4122 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4123 ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u)) {
4124 ctx->r = res;
4125 ctx->app_cont = true1;
4126 } else {
4127 lbm_channel_reader_close(str);
4128 lbm_set_error_reason((char*)lbm_error_str_parse_close);
4129 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4130 }
4131}
4132
4133static void cont_read_dot_terminate(eval_context_t *ctx) {
4134 lbm_value *sptr = get_stack_ptr(ctx, 3);
4135
4136 lbm_value first_cell = sptr[0];
4137 lbm_value last_cell = sptr[1];
4138 lbm_value stream = sptr[2];
4139
4140 lbm_char_channel_t *str = lbm_dec_channel(stream);
4141 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4142 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4143 }
4144
4145 lbm_stack_drop(&ctx->K ,3);
4146
4147 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4148 (ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u) ||
4149 ctx->r == ENC_SYM_DOT(((0x76) << 4) | 0x00000000u))) {
4150 lbm_channel_reader_close(str);
4151 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4152 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4153 } else {
4154 if (lbm_is_cons(last_cell)) {
4155 lbm_set_cdr(last_cell, ctx->r);
4156 ctx->r = first_cell;
4157 lbm_value *rptr = stack_reserve(ctx, 6);
4158 rptr[0] = stream;
4159 rptr[1] = ctx->r;
4160 rptr[2] = READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u);
4161 rptr[3] = stream;
4162 rptr[4] = lbm_enc_u(0);
4163 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4164 ctx->app_cont = true1;
4165 } else {
4166 lbm_channel_reader_close(str);
4167 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4168 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4169 }
4170 }
4171}
4172
4173static void cont_read_done(eval_context_t *ctx) {
4174 lbm_value stream;
4175 lbm_value f_val;
4176 lbm_pop_2(&ctx->K, &stream ,&f_val);
4177
4178 uint32_t flags = lbm_dec_as_u32(f_val);
4179 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4180 ctx->flags |= (flags & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4181
4182 lbm_char_channel_t *str = lbm_dec_channel(stream);
4183 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4184 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4185 }
4186
4187 lbm_channel_reader_close(str);
4188 if (lbm_is_symbol(ctx->r)) {
4189 lbm_uint sym_val = lbm_dec_sym(ctx->r);
4190 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
4191 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
4192 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4193 }
4194 }
4195
4196 ctx->row0 = -1;
4197 ctx->row1 = -1;
4198 ctx->app_cont = true1;
4199}
4200
4201static void cont_read_quote_result(eval_context_t *ctx) {
4202 lbm_value cell;
4203 WITH_GC(cell, lbm_heap_allocate_list_init(2,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4204 ENC_SYM_QUOTE,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4205 ctx->r))(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
};
4206 ctx->r = cell;
4207 ctx->app_cont = true1;
4208}
4209
4210static void cont_read_commaat_result(eval_context_t *ctx) {
4211 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4212 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4213 ctx->r = cell1;
4214 ctx->app_cont = true1;
4215}
4216
4217static void cont_read_comma_result(eval_context_t *ctx) {
4218 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u),ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4219 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4220 ctx->r = cell1;
4221 ctx->app_cont = true1;
4222}
4223
4224static void cont_application_start(eval_context_t *ctx) {
4225
4226 /* sptr[0] = env
4227 * sptr[1] = args
4228 * ctx->r = function
4229 */
4230
4231 if (lbm_is_symbol(ctx->r)) {
4232 stack_reserve(ctx,1)[0] = lbm_enc_u(0);
4233 cont_application_args(ctx);
4234 } else if (lbm_is_cons(ctx->r)) {
4235 lbm_uint *sptr = get_stack_ptr(ctx, 2);
4236 lbm_value args = (lbm_value)sptr[1];
4237 switch (get_car(ctx->r)) {
4238 case ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u): {
4239 lbm_value cl[3];
4240 extract_n(get_cdr(ctx->r), cl, 3);
4241 lbm_value arg_env = (lbm_value)sptr[0];
4242 lbm_value arg0, arg_rest;
4243 get_car_and_cdr(args, &arg0, &arg_rest);
4244 sptr[1] = cl[CLO_BODY1];
4245 bool_Bool a_nil = lbm_is_symbol_nil(args);
4246 bool_Bool p_nil = lbm_is_symbol_nil(cl[CLO_PARAMS0]);
4247 lbm_value *reserved = stack_reserve(ctx, 4);
4248
4249 if (!a_nil && !p_nil) {
4250 reserved[0] = cl[CLO_ENV2];
4251 reserved[1] = cl[CLO_PARAMS0];
4252 reserved[2] = arg_rest;
4253 reserved[3] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
4254 ctx->curr_exp = arg0;
4255 ctx->curr_env = arg_env;
4256 } else if (a_nil && p_nil) {
4257 // No params, No args
4258 lbm_stack_drop(&ctx->K, 6);
4259 ctx->curr_exp = cl[CLO_BODY1];
4260 ctx->curr_env = cl[CLO_ENV2];
4261 } else if (p_nil) {
4262 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), cl[CLO_ENV2]);
4263 reserved[0] = rest_binder;
4264 reserved[1] = get_cdr(args);
4265 reserved[2] = get_car(rest_binder);
4266 reserved[3] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
4267 ctx->curr_exp = get_car(args);
4268 ctx->curr_env = arg_env;
4269 } else {
4270 lbm_set_error_reason((char*)lbm_error_str_num_args);
4271 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->r);
4272 }
4273 } break;
4274 case ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u):{
4275 /* Continuation created using call-cc.
4276 * ((SYM_CONT . cont-array) arg0 )
4277 */
4278 lbm_value c = get_cdr(ctx->r); /* should be the continuation array*/
4279
4280 if (!lbm_is_lisp_array_r(c)) {
4281 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4282 }
4283
4284 lbm_uint arg_count = lbm_list_length(args);
4285 lbm_value arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4286 switch (arg_count) {
4287 case 0:
4288 arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4289 break;
4290 case 1:
4291 arg = get_car(args);
4292 break;
4293 default:
4294 lbm_set_error_reason((char*)lbm_error_str_num_args);
4295 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4296 }
4297 lbm_stack_clear(&ctx->K);
4298
4299 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(c);
4300
4301 ctx->K.sp = arr->size / sizeof(lbm_uint);
4302 memcpy(ctx->K.data, arr->data, arr->size);
4303
4304 ctx->curr_exp = arg;
4305 break;
4306 }
4307 case ENC_SYM_MACRO(((0x10D) << 4) | 0x00000000u):{
4308 /*
4309 * Perform macro expansion.
4310 * Macro expansion is really just evaluation in an
4311 * environment augmented with the unevaluated expressions passed
4312 * as arguments.
4313 */
4314 lbm_value env = (lbm_value)sptr[0];
4315
4316 lbm_value curr_param = get_cadr(ctx->r);
4317 lbm_value curr_arg = args;
4318 lbm_value expand_env = env;
4319 while (lbm_is_cons(curr_param) &&
4320 lbm_is_cons(curr_arg)) {
4321 lbm_value car_curr_param, cdr_curr_param;
4322 lbm_value car_curr_arg, cdr_curr_arg;
4323 get_car_and_cdr(curr_param, &car_curr_param, &cdr_curr_param);
4324 get_car_and_cdr(curr_arg, &car_curr_arg, &cdr_curr_arg);
4325
4326 lbm_value entry = cons_with_gc(car_curr_param, car_curr_arg, expand_env);
4327 lbm_value aug_env = cons_with_gc(entry, expand_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4328 expand_env = aug_env;
4329
4330 curr_param = cdr_curr_param;
4331 curr_arg = cdr_curr_arg;
4332 }
4333 /* Two rounds of evaluation is performed.
4334 * First to instantiate the arguments into the macro body.
4335 * Second to evaluate the resulting program.
4336 */
4337 sptr[1] = EVAL_R(((11) << 2) | 0xF8000001u);
4338 lbm_value exp = get_cadr(get_cdr(ctx->r));
4339 ctx->curr_exp = exp;
4340 ctx->curr_env = expand_env;
4341 } break;
4342 default:
4343 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4344 }
4345 } else {
4346 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4347 }
4348}
4349
4350static void cont_eval_r(eval_context_t* ctx) {
4351 lbm_value env;
4352 lbm_pop(&ctx->K, &env);
4353 ctx->curr_exp = ctx->r;
4354 ctx->curr_env = env;
4355}
4356
4357static void cont_progn_var(eval_context_t* ctx) {
4358
4359 lbm_value key;
4360 lbm_value env;
4361
4362 lbm_pop_2(&ctx->K, &key, &env);
4363
4364 if (fill_binding_location(key, ctx->r, env) < 0) {
4365 lbm_set_error_reason("Incorrect type of name/key in let-binding");
4366 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
4367 }
4368
4369 ctx->app_cont = true1;
4370}
4371
4372static void cont_setq(eval_context_t *ctx) {
4373 lbm_value sym;
4374 lbm_value env;
4375 lbm_pop_2(&ctx->K, &sym, &env);
4376 lbm_value res;
4377 WITH_GC(res, perform_setvar(sym, ctx->r, env))(res) = (perform_setvar(sym, ctx->r, env)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (perform_setvar(sym, ctx->r, env)
); if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
4378 ctx->r = res;
4379 ctx->app_cont = true1;
4380}
4381
4382lbm_flash_status request_flash_storage_cell(lbm_value val, lbm_value *res) {
4383
4384 lbm_value flash_cell;
4385 lbm_flash_status s = lbm_allocate_const_cell(&flash_cell);
4386 if (s != LBM_FLASH_WRITE_OK)
4387 return s;
4388 lbm_value new_val = val;
4389 new_val &= ~LBM_PTR_VAL_MASK0x03FFFFFCu; // clear the value part of the ptr
4390 new_val |= (flash_cell & LBM_PTR_VAL_MASK0x03FFFFFCu);
4391 new_val |= LBM_PTR_TO_CONSTANT_BIT0x04000000u;
4392 *res = new_val;
4393 return s;
4394}
4395
4396static void cont_move_to_flash(eval_context_t *ctx) {
4397
4398 lbm_value args;
4399 lbm_pop(&ctx->K, &args);
4400
4401 if (lbm_is_symbol_nil(args)) {
4402 // Done looping over arguments. return true.
4403 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
4404 ctx->app_cont = true1;
4405 return;
4406 }
4407
4408 lbm_value first_arg, rest;
4409 get_car_and_cdr(args, &first_arg, &rest);
4410
4411 lbm_value val;
4412 if (lbm_is_symbol(first_arg) && lbm_global_env_lookup(&val, first_arg)) {
4413 // Prepare to copy the rest of the arguments when done with first.
4414 lbm_value *rptr = stack_reserve(ctx, 2);
4415 rptr[0] = rest;
4416 rptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
4417 if (lbm_is_ptr(val) &&
4418 (!(val & LBM_PTR_TO_CONSTANT_BIT0x04000000u))) {
4419 lbm_value * rptr1 = stack_reserve(ctx, 3);
4420 rptr1[0] = first_arg;
4421 rptr1[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
4422 rptr1[2] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4423 ctx->r = val;
4424 }
4425 ctx->app_cont = true1;
4426 return;
4427 }
4428 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4429}
4430
4431static void cont_move_val_to_flash_dispatch(eval_context_t *ctx) {
4432
4433 lbm_value val = ctx->r;
4434
4435 if (lbm_is_cons(val)) {
4436 lbm_value *rptr = stack_reserve(ctx, 5);
4437 rptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // fst cell of list
4438 rptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last cell of list
4439 rptr[2] = get_cdr(val);
4440 rptr[3] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4441 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4442 ctx->r = get_car(val);
4443 ctx->app_cont = true1;
4444 return;
4445 }
4446
4447 if (lbm_is_ptr(val) && (val & LBM_PTR_TO_CONSTANT_BIT0x04000000u)) {
4448 ctx->r = val;
4449 ctx->app_cont = true1;
4450 return;
4451 }
4452
4453 if (lbm_is_ptr(val)) {
4454 lbm_cons_t *ref = lbm_ref_cell(val);
4455 if (lbm_type_of(ref->cdr) == LBM_TYPE_SYMBOL0x00000000u) {
4456 switch (ref->cdr) {
4457 case ENC_SYM_RAW_I_TYPE(((0x31) << 4) | 0x00000000u): /* fall through */
4458 case ENC_SYM_RAW_U_TYPE(((0x32) << 4) | 0x00000000u):
4459 case ENC_SYM_RAW_F_TYPE(((0x33) << 4) | 0x00000000u): {
4460 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4461 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4462 handle_flash_status(write_const_car(flash_cell, ref->car));
4463 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4464 ctx->r = flash_cell;
4465 } break;
4466 case ENC_SYM_IND_I_TYPE(((0x34) << 4) | 0x00000000u): /* fall through */
4467 case ENC_SYM_IND_U_TYPE(((0x35) << 4) | 0x00000000u):
4468 case ENC_SYM_IND_F_TYPE(((0x36) << 4) | 0x00000000u): {
4469#ifndef LBM64
4470 /* 64 bit values are in lbm mem on 32bit platforms. */
4471 lbm_uint *lbm_mem_ptr = (lbm_uint*)ref->car;
4472 lbm_uint flash_ptr;
4473
4474 handle_flash_status(lbm_write_const_raw(lbm_mem_ptr, 2, &flash_ptr));
4475 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4476 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4477 handle_flash_status(write_const_car(flash_cell, flash_ptr));
4478 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4479 ctx->r = flash_cell;
4480#else
4481 // There are no indirect types in LBM64
4482 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4483#endif
4484 } break;
4485 case ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u): {
4486 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4487 lbm_uint size = arr->size / sizeof(lbm_uint);
4488 lbm_uint flash_addr;
4489 lbm_value *arrdata = (lbm_value *)arr->data;
4490 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4491 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4492 handle_flash_status(lbm_allocate_const_raw(size, &flash_addr));
4493 lift_array_flash(flash_cell,
4494 false0,
4495 (char *)flash_addr,
4496 arr->size);
4497 // Move array contents to flash recursively
4498 lbm_value *rptr = stack_reserve(ctx, 5);
4499 rptr[0] = flash_cell;
4500 rptr[1] = lbm_enc_u(0);
4501 rptr[2] = val;
4502 rptr[3] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4503 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4504 ctx->r = arrdata[0];
4505 ctx->app_cont = true1;
4506 return;
4507 }
4508 case ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u): {
4509 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4510 // arbitrary address: flash_arr.
4511 lbm_uint flash_arr;
4512 handle_flash_status(lbm_write_const_array_padded((uint8_t*)arr->data, arr->size, &flash_arr));
4513 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4514 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4515 lift_array_flash(flash_cell,
4516 true1,
4517 (char *)flash_arr,
4518 arr->size);
4519 ctx->r = flash_cell;
4520 } break;
4521 case ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u): /* fall through */
4522 case ENC_SYM_CUSTOM_TYPE(((0x38) << 4) | 0x00000000u):
4523 lbm_set_error_reason((char *)lbm_error_str_flash_not_possible);
4524 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4525 }
4526 } else {
4527 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4528 }
4529 ctx->app_cont = true1;
4530 return;
4531 }
4532 ctx->r = val;
4533 ctx->app_cont = true1;
4534}
4535
4536static void cont_move_list_to_flash(eval_context_t *ctx) {
4537
4538 // ctx->r holds the value that should go in car
4539
4540 lbm_value *sptr = get_stack_ptr(ctx, 3);
4541
4542 lbm_value fst = sptr[0];
4543 lbm_value lst = sptr[1];
4544 lbm_value val = sptr[2];
4545
4546
4547 lbm_value new_lst = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4548 // Allocate element ptr storage after storing the element to flash.
4549 handle_flash_status(request_flash_storage_cell(lbm_enc_cons_ptr(LBM_PTR_NULL(0x03FFFFFCu >> 2)), &new_lst));
4550
4551 if (lbm_is_symbol_nil(fst)) {
4552 lst = new_lst;
4553 fst = new_lst;
4554 handle_flash_status(write_const_car(lst, ctx->r));
4555 } else {
4556 handle_flash_status(write_const_cdr(lst, new_lst)); // low before high
4557 handle_flash_status(write_const_car(new_lst, ctx->r));
4558 lst = new_lst;
4559 }
4560
4561 if (lbm_is_cons(val)) {
4562 sptr[0] = fst;
4563 sptr[1] = lst;//rest_cell;
4564 sptr[2] = get_cdr(val);
4565 lbm_value *rptr = stack_reserve(ctx, 2);
4566 rptr[0] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4567 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4568 ctx->r = get_car(val);
4569 } else {
4570 sptr[0] = fst;
4571 sptr[1] = lst;
4572 sptr[2] = CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u);
4573 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4574 ctx->r = val;
4575 }
4576 ctx->app_cont = true1;
4577}
4578
4579static void cont_close_list_in_flash(eval_context_t *ctx) {
4580 lbm_value fst;
4581 lbm_value lst;
4582 lbm_pop_2(&ctx->K, &lst, &fst);
4583 lbm_value val = ctx->r;
4584 handle_flash_status(write_const_cdr(lst, val));
4585 ctx->r = fst;
4586 ctx->app_cont = true1;
4587}
4588
4589static void cont_move_array_elts_to_flash(eval_context_t *ctx) {
4590 lbm_value *sptr = get_stack_ptr(ctx, 3);
4591 // sptr[2] = source array in RAM
4592 // sptr[1] = current index
4593 // sptr[0] = target array in flash
4594 lbm_array_header_t *src_arr = (lbm_array_header_t*)get_car(sptr[2]);
4595 lbm_uint size = src_arr->size / sizeof(lbm_uint);
4596 lbm_value *srcdata = (lbm_value *)src_arr->data;
4597
4598 lbm_array_header_t *tgt_arr = (lbm_array_header_t*)get_car(sptr[0]);
4599 lbm_uint *tgtdata = (lbm_value *)tgt_arr->data;
4600 lbm_uint ix = lbm_dec_as_u32(sptr[1]);
4601 handle_flash_status(lbm_const_write(&tgtdata[ix], ctx->r));
4602 if (ix >= size-1) {
4603 ctx->r = sptr[0];
4604 lbm_stack_drop(&ctx->K, 3);
4605 ctx->app_cont = true1;
4606 return;
4607 }
4608 sptr[1] = lbm_enc_u(ix + 1);
4609 lbm_value *rptr = stack_reserve(ctx, 2);
4610 rptr[0] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4611 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4612 ctx->r = srcdata[ix+1];
4613 ctx->app_cont = true1;
4614 return;
4615}
4616
4617static void cont_qq_expand_start(eval_context_t *ctx) {
4618 lbm_value *rptr = stack_reserve(ctx, 2);
4619 rptr[0] = ctx->r;
4620 rptr[1] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4621 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4622 ctx->app_cont = true1;
4623}
4624
4625lbm_value quote_it(lbm_value qquoted) {
4626 if (lbm_is_symbol(qquoted) &&
4627 lbm_is_special(qquoted)) return qquoted;
4628
4629 lbm_value val = cons_with_gc(qquoted, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4630 return cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4631}
4632
4633bool_Bool is_append(lbm_value a) {
4634 return (lbm_is_cons(a) &&
4635 lbm_is_symbol(get_car(a)) &&
4636 (get_car(a) == ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u)));
4637}
4638
4639lbm_value append(lbm_value front, lbm_value back) {
4640 if (lbm_is_symbol_nil(front)) return back;
4641 if (lbm_is_symbol_nil(back)) return front;
4642
4643 if (lbm_is_quoted_list(front) &&
4644 lbm_is_quoted_list(back)) {
4645 lbm_value f = get_cadr(front);
4646 lbm_value b = get_cadr(back);
4647 return quote_it(lbm_list_append(f, b));
4648 }
4649
4650 if (is_append(back) &&
4651 lbm_is_quoted_list(get_cadr(back)) &&
4652 lbm_is_quoted_list(front)) {
4653 lbm_value ql = get_cadr(back);
4654 lbm_value f = get_cadr(front);
4655 lbm_value b = get_cadr(ql);
4656
4657 lbm_value v = lbm_list_append(f, b);
4658 lbm_set_car(get_cdr(ql), v);
4659 return back;
4660 }
4661
4662 if (is_append(back)) {
4663 back = get_cdr(back);
4664 lbm_value new = cons_with_gc(front, back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4665 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), new, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4666 }
4667
4668 lbm_value t0, t1;
4669
4670 t0 = cons_with_gc(back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), front);
4671 t1 = cons_with_gc(front, t0, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4672 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), t1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4673}
4674
4675/* Bawden's qq-expand implementation
4676(define (qq-expand x)
4677 (cond ((tag-comma? x)
4678 (tag-data x))
4679 ((tag-comma-atsign? x)
4680 (error "Illegal"))
4681 ((tag-backquote? x)
4682 (qq-expand
4683 (qq-expand (tag-data x))))
4684 ((pair? x)
4685 `(append
4686 ,(qq-expand-list (car x))
4687 ,(qq-expand (cdr x))))
4688 (else `',x)))
4689 */
4690static void cont_qq_expand(eval_context_t *ctx) {
4691 lbm_value qquoted;
4692 lbm_pop(&ctx->K, &qquoted);
4693
4694 switch(lbm_type_of(qquoted)) {
4695 case LBM_TYPE_CONS0x10000000u: {
4696 lbm_value car_val = get_car(qquoted);
4697 lbm_value cdr_val = get_cdr(qquoted);
4698 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4699 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4700 ctx->r = append(ctx->r, get_car(cdr_val));
4701 ctx->app_cont = true1;
4702 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4703 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4704 error_ctx(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u));
4705 } else {
4706 lbm_value *rptr = stack_reserve(ctx, 6);
4707 rptr[0] = ctx->r;
4708 rptr[1] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4709 rptr[2] = cdr_val;
4710 rptr[3] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4711 rptr[4] = car_val;
4712 rptr[5] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4713 ctx->app_cont = true1;
4714 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4715 }
4716
4717 } break;
4718 default: {
4719 lbm_value res = quote_it(qquoted);
4720 ctx->r = append(ctx->r, res);
4721 ctx->app_cont = true1;
4722 }
4723 }
4724}
4725
4726static void cont_qq_append(eval_context_t *ctx) {
4727 lbm_value head;
4728 lbm_pop(&ctx->K, &head);
4729 ctx->r = append(head, ctx->r);
4730 ctx->app_cont = true1;
4731}
4732
4733/* Bawden's qq-expand-list implementation
4734(define (qq-expand-list x)
4735 (cond ((tag-comma? x)
4736 `(list ,(tag-data x)))
4737 ((tag-comma-atsign? x)
4738 (tag-data x))
4739 ((tag-backquote? x)
4740 (qq-expand-list
4741 (qq-expand (tag-data x))))
4742 ((pair? x)
4743 `(list
4744 (append
4745 ,(qq-expand-list (car x))
4746 ,(qq-expand (cdr x)))))
4747 (else `'(,x))))
4748*/
4749
4750static void cont_qq_expand_list(eval_context_t* ctx) {
4751 lbm_value l;
4752 lbm_pop(&ctx->K, &l);
4753
4754 ctx->app_cont = true1;
4755 switch(lbm_type_of(l)) {
4756 case LBM_TYPE_CONS0x10000000u: {
4757 lbm_value car_val = get_car(l);
4758 lbm_value cdr_val = get_cdr(l);
4759 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4760 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4761 lbm_value tl = cons_with_gc(get_car(cdr_val), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4762 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4763 ctx->r = append(ctx->r, tmp);
4764 return;
4765 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4766 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4767 ctx->r = get_car(cdr_val);
4768 return;
4769 } else {
4770 lbm_value *rptr = stack_reserve(ctx, 7);
4771 rptr[0] = QQ_LIST(((39) << 2) | 0xF8000001u);
4772 rptr[1] = ctx->r;
4773 rptr[2] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4774 rptr[3] = cdr_val;
4775 rptr[4] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4776 rptr[5] = car_val;
4777 rptr[6] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4778 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4779 }
4780
4781 } break;
4782 default: {
4783 lbm_value a_list = cons_with_gc(l, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4784 lbm_value tl = cons_with_gc(a_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4785 lbm_value tmp = cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4786 ctx->r = append(ctx->r, tmp);
4787 }
4788 }
4789}
4790
4791static void cont_qq_list(eval_context_t *ctx) {
4792 lbm_value val = ctx->r;
4793 lbm_value apnd_app = cons_with_gc(val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4794 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), apnd_app, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4795 ctx->r = tmp;
4796 ctx->app_cont = true1;
4797}
4798
4799static void cont_kill(eval_context_t *ctx) {
4800 (void) ctx;
4801 finish_ctx();
4802}
4803
4804static void cont_pop_reader_flags(eval_context_t *ctx) {
4805 lbm_value flags;
4806 lbm_pop(&ctx->K, &flags);
4807 ctx->flags = ctx->flags & ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4808 ctx->flags |= (lbm_dec_as_u32(flags) & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4809 // r is unchanged.
4810 ctx->app_cont = true1;
4811}
4812
4813static void cont_exception_handler(eval_context_t *ctx) {
4814 lbm_value *sptr = pop_stack_ptr(ctx, 2);
4815 lbm_value retval = sptr[0];
4816 lbm_value flags = sptr[1];
4817 lbm_set_car(get_cdr(retval), ctx->r);
4818 ctx->flags = flags;
4819 ctx->r = retval;
4820 ctx->app_cont = true1;
4821}
4822
4823/*********************************************************/
4824/* Continuations table */
4825typedef void (*cont_fun)(eval_context_t *);
4826
4827static const cont_fun continuations[NUM_CONTINUATIONS49] =
4828 { advance_ctx, // CONT_DONE
4829 cont_set_global_env,
4830 cont_bind_to_key_rest,
4831 cont_if,
4832 cont_progn_rest,
4833 cont_application_args,
4834 cont_and,
4835 cont_or,
4836 cont_wait,
4837 cont_match,
4838 cont_application_start,
4839 cont_eval_r,
4840 cont_resume,
4841 cont_closure_application_args,
4842 cont_exit_atomic,
4843 cont_read_next_token,
4844 cont_read_append_continue,
4845 cont_read_eval_continue,
4846 cont_read_expect_closepar,
4847 cont_read_dot_terminate,
4848 cont_read_done,
4849 cont_read_quote_result,
4850 cont_read_commaat_result,
4851 cont_read_comma_result,
4852 cont_read_start_array,
4853 cont_read_append_array,
4854 cont_map,
4855 cont_match_guard,
4856 cont_terminate,
4857 cont_progn_var,
4858 cont_setq,
4859 cont_move_to_flash,
4860 cont_move_val_to_flash_dispatch,
4861 cont_move_list_to_flash,
4862 cont_close_list_in_flash,
4863 cont_qq_expand_start,
4864 cont_qq_expand,
4865 cont_qq_append,
4866 cont_qq_expand_list,
4867 cont_qq_list,
4868 cont_kill,
4869 cont_loop,
4870 cont_loop_condition,
4871 cont_merge_rest,
4872 cont_merge_layer,
4873 cont_closure_args_rest,
4874 cont_move_array_elts_to_flash,
4875 cont_pop_reader_flags,
4876 cont_exception_handler
4877 };
4878
4879/*********************************************************/
4880/* Evaluators lookup table (special forms) */
4881typedef void (*evaluator_fun)(eval_context_t *);
4882
4883static const evaluator_fun evaluators[] =
4884 {
4885 eval_quote,
4886 eval_define,
4887 eval_progn,
4888 eval_lambda,
4889 eval_if,
4890 eval_let,
4891 eval_and,
4892 eval_or,
4893 eval_match,
4894 eval_receive,
4895 eval_receive_timeout,
4896 eval_callcc,
4897 eval_atomic,
4898 eval_selfevaluating, // macro
4899 eval_selfevaluating, // cont
4900 eval_selfevaluating, // closure
4901 eval_cond,
4902 eval_app_cont,
4903 eval_var,
4904 eval_setq,
4905 eval_move_to_flash,
4906 eval_loop,
4907 eval_trap
4908 };
4909
4910
4911/*********************************************************/
4912/* Evaluator step function */
4913
4914static void evaluation_step(void){
4915 eval_context_t *ctx = ctx_running;
4916#ifdef VISUALIZE_HEAP
4917 heap_vis_gen_image();
4918#endif
4919
4920 if (ctx->app_cont) {
4921 lbm_value k;
4922 lbm_pop(&ctx->K, &k);
4923 ctx->app_cont = false0;
4924
4925 lbm_uint decoded_k = DEC_CONTINUATION(k)(((k) & ~0xF8000001u) >> 2);
4926
4927 if (decoded_k < NUM_CONTINUATIONS49) {
4928 continuations[decoded_k](ctx);
4929 } else {
4930 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4931 }
4932 return;
4933 }
4934
4935 if (lbm_is_symbol(ctx->curr_exp)) {
4936 eval_symbol(ctx);
4937 return;
4938 }
4939 if (lbm_is_cons(ctx->curr_exp)) {
4940 lbm_cons_t *cell = lbm_ref_cell(ctx->curr_exp);
4941 lbm_value h = cell->car;
4942 if (lbm_is_symbol(h) && ((h & ENC_SPECIAL_FORMS_MASK0xFFFFF000) == ENC_SPECIAL_FORMS_BIT0x00001000)) {
4943 lbm_uint eval_index = lbm_dec_sym(h) & SPECIAL_FORMS_INDEX_MASK0x000000FF;
4944 evaluators[eval_index](ctx);
4945 return;
4946 }
4947 /*
4948 * At this point head can be anything. It should evaluate
4949 * into a form that can be applied (closure, symbol, ...) though.
4950 */
4951 lbm_value *reserved = stack_reserve(ctx, 3);
4952 reserved[0] = ctx->curr_env;
4953 reserved[1] = cell->cdr;
4954 reserved[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
4955 ctx->curr_exp = h; // evaluate the function
4956 return;
4957 }
4958
4959 eval_selfevaluating(ctx);
4960 return;
4961}
4962
4963void lbm_pause_eval(void ) {
4964 eval_cps_next_state_arg = 0;
4965 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4966 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4967}
4968
4969void lbm_pause_eval_with_gc(uint32_t num_free) {
4970 eval_cps_next_state_arg = num_free;
4971 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4972 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4973}
4974
4975void lbm_continue_eval(void) {
4976 eval_cps_next_state = EVAL_CPS_STATE_RUNNING2;
4977 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4978}
4979
4980void lbm_kill_eval(void) {
4981 eval_cps_next_state = EVAL_CPS_STATE_KILL4;
4982 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4983}
4984
4985uint32_t lbm_get_eval_state(void) {
4986 return eval_cps_run_state;
4987}
4988
4989// Will wake up thread that is sleeping as well.
4990// Not sure this is good behavior.
4991static void handle_event_unblock_ctx(lbm_cid cid, lbm_value v) {
4992 eval_context_t *found = NULL((void*)0);
4993 mutex_lock(&qmutex);
4994
4995 found = lookup_ctx_nm(&blocked, cid);
4996 if (found) {
4997 drop_ctx_nm(&blocked,found);
4998 if (lbm_is_error(v)) {
4999 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
5000 found->app_cont = true1;
5001 }
5002 found->r = v;
5003 enqueue_ctx_nm(&queue,found);
5004 }
5005 mutex_unlock(&qmutex);
5006}
5007
5008static void handle_event_define(lbm_value key, lbm_value val) {
5009 lbm_uint dec_key = lbm_dec_sym(key);
5010 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
5011 lbm_value *global_env = lbm_get_global_env();
5012 lbm_uint orig_env = global_env[ix_key];
5013 lbm_value new_env;
5014 // A key is a symbol and should not need to be remembered.
5015 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
5016
5017 global_env[ix_key] = new_env;
5018}
5019
5020static lbm_value get_event_value(lbm_event_t *e) {
5021 lbm_value v;
5022 if (e->buf_len > 0) {
5023 lbm_flat_value_t fv;
5024 fv.buf = (uint8_t*)e->buf_ptr;
5025 fv.buf_size = e->buf_len;
5026 fv.buf_pos = 0;
5027 if (!lbm_unflatten_value(&fv, &v)) {
5028 lbm_set_flags(LBM_FLAG_HANDLER_EVENT_DELIVERY_FAILED(1 << 1));
5029 v = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
5030 }
5031 // Free the flat value buffer. GC is unaware of its existence.
5032 lbm_free(fv.buf);
5033 } else {
5034 v = (lbm_value)e->buf_ptr;
5035 }
5036 return v;
5037}
5038
5039static void process_events(void) {
5040
5041 if (!lbm_events) return;
5042 lbm_event_t e;
5043
5044 while (lbm_event_pop(&e)) {
5045
5046 lbm_value event_val = get_event_value(&e);
5047 switch(e.type) {
5048 case LBM_EVENT_UNBLOCK_CTX:
5049 handle_event_unblock_ctx((lbm_cid)e.parameter, event_val);
5050 break;
5051 case LBM_EVENT_DEFINE:
5052 handle_event_define((lbm_value)e.parameter, event_val);
5053 break;
5054 case LBM_EVENT_FOR_HANDLER:
5055 if (lbm_event_handler_pid >= 0) {
5056 lbm_find_receiver_and_send(lbm_event_handler_pid, event_val);
5057 }
5058 break;
5059 }
5060 }
5061}
5062
5063/* eval_cps_run can be paused
5064 I think it would be better use a mailbox for
5065 communication between other threads and the run_eval
5066 but for now a set of variables will be used. */
5067void lbm_run_eval(void){
5068
5069 if (setjmp(critical_error_jmp_buf)_setjmp (critical_error_jmp_buf) > 0) {
5070 printf_callback("GC stack overflow!\n");
5071 critical_error_callback();
5072 // terminate evaluation thread.
5073 return;
5074 }
5075
5076 setjmp(error_jmp_buf)_setjmp (error_jmp_buf);
5077
5078 while (eval_running) {
5079 if (eval_cps_state_changed || eval_cps_run_state == EVAL_CPS_STATE_PAUSED1) {
5080 eval_cps_state_changed = false0;
5081 switch (eval_cps_next_state) {
5082 case EVAL_CPS_STATE_PAUSED1:
5083 if (eval_cps_run_state != EVAL_CPS_STATE_PAUSED1) {
5084 if (lbm_heap_num_free() < eval_cps_next_state_arg) {
5085 gc();
5086 }
5087 eval_cps_next_state_arg = 0;
5088 }
5089 eval_cps_run_state = EVAL_CPS_STATE_PAUSED1;
5090 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5091 continue; /* jump back to start of eval_running loop */
5092 case EVAL_CPS_STATE_KILL4:
5093 eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
5094 eval_running = false0;
5095 continue;
5096 default: // running state
5097 eval_cps_run_state = eval_cps_next_state;
5098 break;
5099 }
5100 }
5101 while (true1) {
5102 if (eval_steps_quota && ctx_running) {
5103 eval_steps_quota--;
5104 evaluation_step();
5105 } else {
5106 if (eval_cps_state_changed) break;
5107 eval_steps_quota = eval_steps_refill;
5108 if (is_atomic) {
5109 if (!ctx_running) {
5110 lbm_set_flags(LBM_FLAG_ATOMIC_MALFUNCTION(1 << 0));
5111 is_atomic = 0;
5112 }
5113 } else {
5114 if (gc_requested) {
5115 gc();
5116 }
5117 process_events();
5118 mutex_lock(&qmutex);
5119 if (ctx_running) {
5120 enqueue_ctx_nm(&queue, ctx_running);
5121 ctx_running = NULL((void*)0);
5122 }
5123 wake_up_ctxs_nm();
5124 ctx_running = dequeue_ctx_nm(&queue);
5125 mutex_unlock(&qmutex);
5126 if (!ctx_running) {
5127 lbm_system_sleeping = true1;
5128 //Fixed sleep interval to poll events regularly.
5129 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5130 lbm_system_sleeping = false0;
5131 }
5132 }
5133 }
5134 }
5135 }
5136}
5137
5138lbm_cid lbm_eval_program(lbm_value lisp) {
5139 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), 256, NULL((void*)0));
5140}
5141
5142lbm_cid lbm_eval_program_ext(lbm_value lisp, unsigned int stack_size) {
5143 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), stack_size, NULL((void*)0));
5144}
5145
5146int lbm_eval_init() {
5147 if (!qmutex_initialized) {
5148 mutex_init(&qmutex);
5149 qmutex_initialized = true1;
5150 }
5151 if (!lbm_events_mutex_initialized) {
5152 mutex_init(&lbm_events_mutex);
5153 lbm_events_mutex_initialized = true1;
5154 }
5155 if (!blocking_extension_mutex_initialized) {
5156 mutex_init(&blocking_extension_mutex);
5157 blocking_extension_mutex_initialized = true1;
5158 }
5159
5160 mutex_lock(&qmutex);
5161 mutex_lock(&lbm_events_mutex);
5162
5163 blocked.first = NULL((void*)0);
5164 blocked.last = NULL((void*)0);
5165 queue.first = NULL((void*)0);
5166 queue.last = NULL((void*)0);
5167 ctx_running = NULL((void*)0);
5168
5169 eval_cps_run_state = EVAL_CPS_STATE_RUNNING2;
5170
5171 mutex_unlock(&lbm_events_mutex);
5172 mutex_unlock(&qmutex);
5173
5174 if (!lbm_init_env()) return 0;
5175 eval_running = true1;
5176 return 1;
5177}
5178
5179bool_Bool lbm_eval_init_events(unsigned int num_events) {
5180
5181 mutex_lock(&lbm_events_mutex);
5182 lbm_events = (lbm_event_t*)lbm_malloc(num_events * sizeof(lbm_event_t));
5183 bool_Bool r = false0;
5184 if (lbm_events) {
5185 lbm_events_max = num_events;
5186 lbm_events_head = 0;
5187 lbm_events_tail = 0;
5188 lbm_events_full = false0;
5189 lbm_event_handler_pid = -1;
5190 r = true1;
5191 }
5192 mutex_unlock(&lbm_events_mutex);
5193 return r;
5194}
+
+
←

./include/heap.h

+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1
2/*
3 Copyright 2018, 2024 Joel Svensson svenssonjoel@yahoo.se
4
5 This program is free software: you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation, either version 3 of the License, or
8 (at your option) any later version.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
14
15 You should have received a copy of the GNU General Public License
16 along with this program. If not, see <http://www.gnu.org/licenses/>.
17*/
18/** \file heap.h */
19
20#ifndef HEAP_H_
21#define HEAP_H_
22
23#include <string.h>
24#include <stdarg.h>
25
26#include "lbm_types.h"
27#include "symrepr.h"
28#include "stack.h"
29#include "lbm_memory.h"
30#include "lbm_defines.h"
31#include "lbm_channel.h"
32
33#ifdef __cplusplus
34extern "C" {
35#endif
36
37/*
38Planning for a more space efficient heap representation.
39TODO: Need to find a good reference to read up on this.
40 - List based heap
41 - Easy to implement and somewhat efficient
42
430000 0000 Size Free bits
44003F FFFF 4MB 10
45007F FFFF 8MB 9
4600FF FFFF 16MB 8
4701FF FFFF 32MB 7
4803FF FFFF 64MB 6 * Kind of heap size I am looking for
4907FF FFFF 128MB 5
500FFF FFFF 256MB 4
511FFF FFFF 512MB 3
52
53
54--- May 9 2021 ---
55Actually now I am much more interested in way smaller memories ;)
56
570000 0000 Size Free bits
580000 0FFF 4KB 20 |
590000 1FFF 8KB 19 |
600000 3FFF 16KB 18 |
610000 7FFF 32KB 17 |
620000 FFFF 64KB 16 |
630001 FFFF 128KB 15 |
640003 FFFF 256KB 14 | - This range is very interesting.
650007 FFFF 512KB 13
66000F FFFF 1MB 12
67001F FFFF 2MB 11
68003F FFFF 4MB 10
69007F FFFF 8MB 9
7000FF FFFF 16MB 8
7101FF FFFF 32MB 7
7203FF FFFF 64MB 6
7307FF FFFF 128MB 5
740FFF FFFF 256MB 4
751FFF FFFF 512MB 3
76
77Those are the kind of platforms that are fun... so a bunch of
78wasted bits in heap pointers if we run on small MCUs.
79
80-----------------
81
82it is also the case that not all addresses will be used if all "cells" are
83of the same size, 8 bytes...
84
85value 0: 0000 0000
86value 1: 0000 0008
87value 3: 0000 0010
88value 4: 0000 0018
89
90Means bits 0,1,2 will always be empty in a valid address.
91
92Cons cells also need to be have room for 2 pointers. So each ted cell from
93memory should be 8bytes.
94
95Things that needs to be represented within these bits:
96
97 - GC MARK one per cell
98 - TYPE: type of CAR and type of cons
99
100Types I would want:
101 - Full 32bit integer. Does not leave room for identification of type
102 - Float values. Same problem
103
104
105Free bits in pointers 64MB heap:
10631 30 29 28 27 26 2 1 0
1070 0 0 0 0 0 XX XXXX XXXX XXXX XXXX XXXX X 0 0 0
108
109
110Information needed for each cell:
111 Meaning | bits total | bits per car | bits per cdr
112 GC mark | 2 | 1 | 1 - only one of them will be used (the other is wasted)
113 Type | 2x | x | x
114 Ptr/!ptr | 2 | 1 | 1
115
116
117Types (unboxed):
118 - Symbols
119 - 28bit integer ( will need signed shift right functionality )
120 - 28bit unsigned integer
121 - Character
122
123If four types is all that should be possible (unboxed). then 2 bits are needed to differentiate.
1242 + 1 + 1 = 4 => 28bits for data.
125
126bit 0: ptr/!ptr
127bit 1: gc
128bit 2-3: type (if not ptr)
129bit 3 - 24 ptr (if ptr)
130bit 4 - 31 value (if value)
131
132An unboxed value can occupy a car or cdr field in a cons cell.
133
134types (boxed) extra information in pointer to cell can contain information
135 - 32 bit integer
136 - 32 bit unsigned integer
137 - 32 bit float
138
139boxed representation:
140 [ptr| cdr]
141 |
142 [Value | Aux + GC_MARK]
143
144Kinds of pointers:
145 - Pointer to cons cell.
146 - Pointer to unboxed value (fixnums not in a list, I hope this is so rare that it can be removed )
147 - integer
148 - unsigned integer
149 - symbol
150 - float
151 - Pointer to boxed value.
152 - 32 bit integer
153 - 32 bit unsigned integer
154 - 32 bit float
155 - (Maybe something else ? Vectors/strings allocated in memory not occupied by heap?)
156 - vector of int
157 - vector of uint
158 - vector of float
159 - vector of double
160 - String
161
16213 pointer"types" -> needs 4 bits
163for 64MB heap there are 6 free bits. So with this scheme going to 128MB or 256MB heap
164is also possible
165
166 a pointer to some off heap vector/string could be represented by
167
168 [ptr | cdr]
169 |
170 [full pointer | Aux + GC_MARK]
171 |
172 [VECTOR]
173
174Aux bits could be used for storing vector size. Up to 30bits should be available there
175>> This is problematic. Now the information that something is a vector is split up
176>> between 2 cons cells. This means GC needs both of these intact to be able to make
177>> proper decision.
178>> Will try to resolve this by adding some special symbols. But these must be symbols
179>> that cannot occur normally in programs. Then an array could be:
180
181 [Full pointer | ARRAY_SYM + GC_MARK]
182 |
183 [VECTOR]
184
185>> Boxed values same treatment as above.
186>> TODO: Could this be simpler?
187
188[ VALUE | TYPE_SYM + GC_MARK]
189
190
1910000 00XX XXXX XXXX XXXX XXXX XXXX X000 : 0x03FF FFF8
1921111 AA00 0000 0000 0000 0000 0000 0000 : 0xFC00 0000 (AA bits left unused for now, future heap growth?)
193 */
194
195typedef enum {
196 LBM_FLASH_WRITE_OK,
197 LBM_FLASH_FULL,
198 LBM_FLASH_WRITE_ERROR
199} lbm_flash_status;
200
201/** Struct representing a heap cons-cell.
202 *
203 */
204typedef struct {
205 lbm_value car;
206 lbm_value cdr;
207} lbm_cons_t;
208
209/**
210 * Heap state
211 */
212typedef struct {
213 lbm_cons_t *heap;
214 lbm_value freelist; // list of free cons cells.
215 lbm_stack_t gc_stack;
216
217 lbm_uint heap_size; // In number of cells.
218 lbm_uint heap_bytes; // In bytes.
219
220 lbm_uint num_alloc; // Number of cells allocated.
221 lbm_uint num_alloc_arrays; // Number of arrays allocated.
222
223 lbm_uint gc_num; // Number of times gc has been performed.
224 lbm_uint gc_marked; // Number of cells marked by mark phase.
225 lbm_uint gc_recovered; // Number of cells recovered by sweep phase.
226 lbm_uint gc_recovered_arrays;// Number of arrays recovered by sweep.
227 lbm_uint gc_least_free; // The smallest length of the freelist.
228 lbm_uint gc_last_free; // Number of elements on the freelist
229 // after most recent GC.
230} lbm_heap_state_t;
231
232extern lbm_heap_state_t lbm_heap_state;
233
234typedef bool_Bool (*const_heap_write_fun)(lbm_uint ix, lbm_uint w);
235
236typedef struct {
237 lbm_uint *heap;
238 lbm_uint next; // next free index.
239 lbm_uint size; // in lbm_uint words. (cons-cells = words / 2)
240} lbm_const_heap_t;
241
242/**
243 * The header portion of an array stored in array and symbol memory.
244 * An array is always a byte array. use the array-extensions for
245 * storing and reading larger values from arrays.
246 */
247typedef struct {
248 lbm_uint size; /// Number of elements
249 lbm_uint *data; /// pointer to lbm_memory array or C array.
250} lbm_array_header_t;
251
252typedef struct {
253 lbm_uint size;
254 lbm_uint *data;
255 uint32_t index; // Limits arrays to max 2^32-1 elements.
256} lbm_array_header_extended_t;
257
258/** Lock GC mutex
259 * Locks a mutex during GC marking when using the pointer reversal algorithm.
260 * Does nothing when using stack based GC mark.
261 */
262void lbm_gc_lock(void);
263/* Unlock GC mutex
264 */
265void lbm_gc_unlock(void);
266
267/** Initialize heap storage.
268 * \param addr Pointer to an array of lbm_cons_t elements. This array must at least be aligned 4.
269 * \param num_cells Number of lbm_cons_t elements in the array.
270 * \param gc_stack_size Size of the gc_stack in number of words.
271 * \return 1 on success or 0 for failure.
272 */
273int lbm_heap_init(lbm_cons_t *addr, lbm_uint num_cells,
274 lbm_uint gc_stack_size);
275
276/** Add GC time statistics to heap_stats
277 *
278 * \param dur Duration as reported by the timestamp callback.
279 */
280void lbm_heap_new_gc_time(lbm_uint dur);
281/** Add a new free_list length to the heap_stats.
282 * Calculates a new freelist length and updates
283 * the GC statistics.
284 */
285void lbm_heap_new_freelist_length(void);
286/** Check how many lbm_cons_t cells are on the free-list
287 *
288 * \return Number of free lbm_cons_t cells.
289 */
290lbm_uint lbm_heap_num_free(void);
291/** Check how many lbm_cons_t cells are allocated.
292 *
293 * \return Number of lbm_cons_t cells that are currently allocated.
294 */
295lbm_uint lbm_heap_num_allocated(void);
296/** Size of the heap in number of lbm_cons_t cells.
297 *
298 * \return Size of the heap in number of lbm_cons_t cells.
299 */
300lbm_uint lbm_heap_size(void);
301/** Size of the heap in bytes.
302 *
303 * \return Size of heap in bytes.
304 */
305lbm_uint lbm_heap_size_bytes(void);
306/** Allocate an lbm_cons_t cell from the heap.
307 *
308 * \param type A type that can be encoded onto the cell (most often LBM_PTR_TYPE_CONS).
309 * \param car Value to write into car position of allocated cell.
310 * \param cdr Value to write into cdr position of allocated cell.
311 * \return An lbm_value referring to a cons_cell or enc_sym(SYM_MERROR) in case the heap is full.
312 */
313lbm_value lbm_heap_allocate_cell(lbm_type type, lbm_value car, lbm_value cdr);
314/** Allocate a list of n heap-cells.
315 * \param n The number of heap-cells to allocate.
316 * \return A list of heap-cells of Memory error if unable to allocate.
317 */
318lbm_value lbm_heap_allocate_list(lbm_uint n);
319/** Allocate a list of n heap-cells and initialize the values.
320 * \pram ls The result list is passed through this ptr.
321 * \param n The length of list to allocate.
322 * \param valist The values in a va_list to initialize the list with.
323 * \return True of False depending on success of allocation.
324 */
325lbm_value lbm_heap_allocate_list_init_va(unsigned int n, va_list valist);
326/** Allocate a list of n heap-cells and initialize the values.
327 * \param n The length of list to allocate.
328 * \param ... The values to initialize the list with.
329 * \return allocated list or error symbol.
330 */
331lbm_value lbm_heap_allocate_list_init(unsigned int n, ...);
332/** Decode an lbm_value representing a string into a C string
333 *
334 * \param val Value
335 * \return allocated list or error symbol
336 */
337char *lbm_dec_str(lbm_value val);
338/** Decode an lbm_value representing a char channel into an lbm_char_channel_t pointer.
339 *
340 * \param val Value
341 * \return A pointer to an lbm_char_channel_t or NULL if the value does not encode a channel.
342 */
343lbm_char_channel_t *lbm_dec_channel(lbm_value val);
344/** Decode an lbm_value representing a custom type into a lbm_uint value.
345 *
346 * \param val Value.
347 * \return The custom type payload.
348 */
349lbm_uint lbm_dec_custom(lbm_value val);
350/** Decode a numerical value as if it is char
351 *
352 * \param val Value to decode
353 * \return The value encoded in val casted to a char. Returns 0 if val does not encode a number.
354 */
355uint8_t lbm_dec_as_char(lbm_value a);
356/** Decode a numerical value as if it is unsigned
357 *
358 * \param val Value to decode
359 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
360 */
361uint32_t lbm_dec_as_u32(lbm_value val);
362/** Decode a numerical value as a signed integer.
363 *
364 * \param val Value to decode
365 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
366 */
367int32_t lbm_dec_as_i32(lbm_value val);
368/** Decode a numerical value as a float.
369 *
370 * \param val Value to decode.
371 * \return The value encoded in val casted to a float. Returns 0 if val does not encode a number.
372 */
373float lbm_dec_as_float(lbm_value val);
374/** Decode a numerical value as if it is a 64bit unsigned
375 *
376 * \param val Value to decode
377 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
378 */
379uint64_t lbm_dec_as_u64(lbm_value val);
380/** Decode a numerical value as a 64bit signed integer.
381 *
382 * \param val Value to decode
383 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
384 */
385int64_t lbm_dec_as_i64(lbm_value val);
386/** Decode a numerical value as a float.
387 *
388 * \param val Value to decode.
389 * \return The value encoded in val casted to a float. Returns 0 if val does not encode a number.
390 */
391double lbm_dec_as_double(lbm_value val);
392
393/** Decode a numerical value into the architecture defined unsigned integer type.
394 *
395 * \param val Value to decode
396 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
397 */
398lbm_uint lbm_dec_as_uint(lbm_value val);
399
400/** Decode a numerical value into the architecture defined signed integer type.
401 *
402 * \param val Value to decode
403 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
404 */
405lbm_int lbm_dec_as_int(lbm_value val);
406
407lbm_uint lbm_dec_raw(lbm_value v);
408/** Allocates an lbm_cons_t cell from the heap and populates it.
409 *
410 * \param car The value to put in the car field of the allocated lbm_cons_t.
411 * \param cdr The value to put in the cdr field of the allocated lbm_cons_t.
412 * \return A value referencing the lbm_cons_t or enc_sym(SYM_MERROR) if heap is full.
413 */
414lbm_value lbm_cons(lbm_value car, lbm_value cdr);
415
416/** Accesses the car field of an lbm_cons_t.
417 *
418 * \param cons Value
419 * \return The car field of the lbm_cons_t if cons is a reference to a heap cell.
420 * If cons is nil, the return value is nil. If the value
421 * is not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
422 */
423lbm_value lbm_car(lbm_value cons);
424/** Accesses the car field the car field of an lbm_cons_t.
425 *
426 * \param cons Value
427 * \return The car of car field or nil.
428 */
429lbm_value lbm_caar(lbm_value c);
430/** Accesses the car of the cdr of an cons cell
431 *
432 * \param c Value
433 * \return the cdr field or type error.
434 */
435lbm_value lbm_cadr(lbm_value c);
436/** Accesses the cdr field of an lbm_cons_t.
437 *
438 * \param cons Value
439 * \return The cdr field of the lbm_cons_t if cons is a reference to a heap cell.
440 * If cons is nil, the return value is nil. If the value
441 * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
442 */
443lbm_value lbm_cdr(lbm_value cons);
444/** Accesses the cdr of an cdr field of an lbm_cons_t.
445 *
446 * \param cons Value
447 * \return The cdr of the cdr field of the lbm_cons_t if cons is a reference to a heap cell.
448 * If cons is nil, the return value is nil. If the value
449 * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
450 */
451lbm_value lbm_cddr(lbm_value c);
452/** Update the value stored in the car field of a heap cell.
453 *
454 * \param c Value referring to a heap cell.
455 * \param v Value to replace the car field with.
456 * \return 1 on success and 0 if the c value does not refer to a heap cell.
457 */
458int lbm_set_car(lbm_value c, lbm_value v);
459/** Update the value stored in the cdr field of a heap cell.
460 *
461 * \param c Value referring to a heap cell.
462 * \param v Value to replace the cdr field with.
463 * \return 1 on success and 0 if the c value does not refer to a heap cell.
464 */
465int lbm_set_cdr(lbm_value c, lbm_value v);
466/** Update the value stored in the car and cdr fields of a heap cell.
467 *
468 * \param c Value referring to a heap cell.
469 * \param car_val Value to replace the car field with.
470 * \param cdr_val Value to replace the cdr field with.
471 * \return 1 on success and 0 if the c value does not refer to a heap cell.
472 */
473int lbm_set_car_and_cdr(lbm_value c, lbm_value car_val, lbm_value cdr_val);
474// List functions
475/** Calculate the length of a proper list
476 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
477 * may lead to the function not terminating.
478 *
479 * \param c A list
480 * \return The length of the list. Unless the value is a cyclic structure on the heap, this function will terminate.
481 */
482lbm_uint lbm_list_length(lbm_value c);
483
484/** Calculate the length of a proper list and evaluate a predicate for each element.
485 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
486 * may lead to the function not terminating.
487 *
488 * \param c A list
489 * \param pres Boolean result of predicate, false if predicate is false for any of the elements in the list, otherwise true.
490 * \param pred Predicate to evaluate for each element of the list.
491 */
492unsigned int lbm_list_length_pred(lbm_value c, bool_Bool *pres, bool_Bool (*pred)(lbm_value));
493/** Reverse a proper list
494 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
495 * may lead to the function not terminating.
496 *
497 * \param list A list
498 * \return The list reversed or enc_sym(SYM_MERROR) if heap is full.
499 */
500lbm_value lbm_list_reverse(lbm_value list);
501/** Reverse a proper list destroying the original.
502 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
503 * may lead to the function not terminating.
504 *
505 * \param list A list
506 * \return The list reversed
507 */
508lbm_value lbm_list_destructive_reverse(lbm_value list);
509/** Copy a list
510 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
511 * may lead to the function not terminating.
512 *
513 * \param m Number of elements to copy or -1 for all. If 1, m will be updated with the length of the list
514 * \param list A list.
515 * \return Reversed list or enc_sym(SYM_MERROR) if heap is full.
516 */
517lbm_value lbm_list_copy(int *m, lbm_value list);
518
519/** A destructive append of two lists
520 *
521 * \param list1 A list
522 * \param list2 A list
523 * \return list1 with list2 appended at the end.
524 */
525lbm_value lbm_list_append(lbm_value list1, lbm_value list2);
526
527/** Drop values from the head of a list.
528 * \param n Number of values to drop.
529 * \param ls List to drop values from.
530 * \return The list with the n first elements removed.
531 */
532lbm_value lbm_list_drop(unsigned int n, lbm_value ls);
533/** Index into a list.
534 * \param l List to index into.
535 * \param n Position to read out of the list.
536 * \return Value at position n of l or nil if out of bounds.
537 */
538lbm_value lbm_index_list(lbm_value l, int32_t n);
539
540// State and statistics
541/** Get a copy of the heap statistics structure.
542 *
543 * \param A pointer to an lbm_heap_state_t to populate
544 * with the current statistics.
545 */
546void lbm_get_heap_state(lbm_heap_state_t *);
547/** Get the maximum stack level of the GC stack
548 * \return maximum value the gc stack sp reached so far.
549 */
550lbm_uint lbm_get_gc_stack_max(void);
551/** Get the size of the GC stack.
552 * \return the size of the gc stack.
553 */
554lbm_uint lbm_get_gc_stack_size(void);
555// Garbage collection
556/** Increment the counter that is counting the number of times GC ran
557 *
558 */
559void lbm_gc_state_inc(void);
560/** Set the freelist to NIL. Means that no memory will be available
561 * until after a garbage collection.
562 */
563void lbm_nil_freelist(void);
564/** Mark all heap cells reachable from an environment.
565 * \param environment.
566 */
567void lbm_gc_mark_env(lbm_value);
568/** Mark heap cells reachable from the lbm_value v.
569 * \param root
570 */
571void lbm_gc_mark_phase(lbm_value root);
572/** Performs lbm_gc_mark_phase on all the values of an array.
573 * This function is similar to lbm_gc_mark_roots but performs
574 * extra checks to not traverse into non-standard values.
575 * TODO: Check if this function is really needed.
576 * \param data Array of roots to traverse from.
577 * \param n Number of elements in roots-array.
578 */
579void lbm_gc_mark_aux(lbm_uint *data, lbm_uint n);
580/** Performs lbm_gc_mark_phase on all the values in the roots array.
581 * \param roots pointer to array of roots.
582 * \param num_roots size of array of roots.
583 */
584void lbm_gc_mark_roots(lbm_uint *roots, lbm_uint num_roots);
585/** Sweep up all non marked heap cells and place them on the free list.
586 *
587 * \return 1
588 */
589int lbm_gc_sweep_phase(void);
590
591// Array functionality
592/** Allocate an bytearray in symbols and arrays memory (lispbm_memory.h)
593 * and create a heap cell that refers to this bytearray.
594 * \param res The resulting lbm_value is returned through this argument.
595 * \param size Array size in number of 32 bit words.
596 * \return 1 for success of 0 for failure.
597 */
598int lbm_heap_allocate_array(lbm_value *res, lbm_uint size);
599/** Allocate an array in symbols and arrays memory (lispbm_memory.h)
600 * and create a heap cell that refers to this array.
601 * \param res The resulting lbm_value is returned through this argument.
602 * \param size Array size in number of 32 bit words.
603 * \return 1 for success of 0 for failure.
604 */
605int lbm_heap_allocate_lisp_array(lbm_value *res, lbm_uint size);
606/** Convert a C array into an lbm array. If the C array is allocated in LBM MEMORY
607 * the lifetime of the array will be managed by GC.
608 * \param res lbm_value result pointer for storage of the result array.
609 * \param data C array.
610 * \param type The type tag to assign to the resulting LBM array.
611 * \param num_elt Number of elements in the array.
612 * \return 1 for success and 0 for failure.
613 */
614int lbm_lift_array(lbm_value *value, char *data, lbm_uint num_elt);
615/** Get the size of an array value.
616 * \param arr lbm_value array to get size of.
617 * \return -1 for failure or length of array.
618 */
619lbm_int lbm_heap_array_get_size(lbm_value arr);
620/** Get a pointer to the data of an array for read only purposes.
621 * \param arr lbm_value array to get pointer from.
622 * \return NULL or valid pointer.
623 */
624const uint8_t *lbm_heap_array_get_data_ro(lbm_value arr);
625/** Get a pointer to the data of an array for read/write purposes.
626 * \param arr lbm_value array to get pointer from.
627 * \return NULL or valid pointer.
628 */
629uint8_t *lbm_heap_array_get_data_rw(lbm_value arr);
630/** Explicitly free an array.
631 * This function needs to be used with care and knowledge.
632 * \param arr Array value.
633 */
634int lbm_heap_explicit_free_array(lbm_value arr);
635/** Query the size in bytes of an lbm_type.
636 * \param t Type
637 * \return Size in bytes of type or 0 if the type represents a composite.
638 */
639lbm_uint lbm_size_of(lbm_type t);
640
641int lbm_const_heap_init(const_heap_write_fun w_fun,
642 lbm_const_heap_t *heap,
643 lbm_uint *addr,
644 lbm_uint num_words);
645
646lbm_flash_status lbm_allocate_const_cell(lbm_value *res);
647lbm_flash_status lbm_write_const_raw(lbm_uint *data, lbm_uint n, lbm_uint *res);
648lbm_flash_status lbm_allocate_const_raw(lbm_uint nwords, lbm_uint *res);
649lbm_flash_status write_const_cdr(lbm_value cell, lbm_value val);
650lbm_flash_status write_const_car(lbm_value cell, lbm_value val);
651lbm_flash_status lbm_const_write(lbm_uint *tgt, lbm_uint val);
652lbm_uint lbm_flash_memory_usage(void);
653
654/** Query the type information of a value.
655 *
656 * \param x Value to check the type of.
657 * \return The type information.
658 */
659static inline lbm_type lbm_type_of(lbm_value x) {
660 return (x & LBM_PTR_BIT0x00000001u) ? (x & LBM_PTR_TYPE_MASK0xFC000000u) : (x & LBM_VAL_TYPE_MASK0x0000000Cu);
661}
662
663// type-of check that is safe in functional code
664static inline lbm_type lbm_type_of_functional(lbm_value x) {
665 return (x & LBM_PTR_BIT0x00000001u) ?
666 (x & (LBM_PTR_TO_CONSTANT_MASK~0x04000000u & LBM_PTR_TYPE_MASK0xFC000000u)) :
667 (x & LBM_VAL_TYPE_MASK0x0000000Cu);
668}
669
670static inline lbm_value lbm_enc_cons_ptr(lbm_uint x) {
671 return ((x << LBM_ADDRESS_SHIFT2) | LBM_TYPE_CONS0x10000000u | LBM_PTR_BIT0x00000001u);
672}
673
674static inline lbm_uint lbm_dec_ptr(lbm_value p) {
675 return ((LBM_PTR_VAL_MASK0x03FFFFFCu & p) >> LBM_ADDRESS_SHIFT2);
676}
677
678extern lbm_cons_t *lbm_heaps[2];
679
680static inline lbm_uint lbm_dec_cons_cell_ptr(lbm_value p) {
681 lbm_uint h = (p & LBM_PTR_TO_CONSTANT_BIT0x04000000u) >> LBM_PTR_TO_CONSTANT_SHIFT26;
682 return lbm_dec_ptr(p) >> h;
683}
684
685static inline lbm_cons_t *lbm_dec_heap(lbm_value p) {
686 lbm_uint h = (p & LBM_PTR_TO_CONSTANT_BIT0x04000000u) >> LBM_PTR_TO_CONSTANT_SHIFT26;
687 return lbm_heaps[h];
688}
689
690static inline lbm_value lbm_set_ptr_type(lbm_value p, lbm_type t) {
691 return ((LBM_PTR_VAL_MASK0x03FFFFFCu & p) | t | LBM_PTR_BIT0x00000001u);
692}
693
694static inline lbm_value lbm_enc_sym(lbm_uint s) {
695 return (s << LBM_VAL_SHIFT4) | LBM_TYPE_SYMBOL0x00000000u;
696}
697
698static inline lbm_value lbm_enc_i(lbm_int x) {
699 return ((lbm_uint)x << LBM_VAL_SHIFT4) | LBM_TYPE_I0x00000008u;
700}
701
702static inline lbm_value lbm_enc_u(lbm_uint x) {
703 return (x << LBM_VAL_SHIFT4) | LBM_TYPE_U0x0000000Cu;
704}
705
706/** Encode 32 bit integer into an lbm_value.
707 * \param x Value to encode.
708 * \return result encoded value.
709 */
710extern lbm_value lbm_enc_i32(int32_t x);
711
712/** Encode 32 bit unsigned integer into an lbm_value.
713 * \param x Value to encode.
714 * \return result encoded value.
715 */
716extern lbm_value lbm_enc_u32(uint32_t x);
717
718/** Encode a float into an lbm_value.
719 * \param x float value to encode.
720 * \return result encoded value.
721 */
722extern lbm_value lbm_enc_float(float x);
723
724/** Encode a 64 bit integer into an lbm_value.
725 * \param x 64 bit integer to encode.
726 * \return result encoded value.
727 */
728extern lbm_value lbm_enc_i64(int64_t x);
729
730/** Encode a 64 bit unsigned integer into an lbm_value.
731 * \param x 64 bit unsigned integer to encode.
732 * \return result encoded value.
733 */
734extern lbm_value lbm_enc_u64(uint64_t x);
735
736/** Encode a double into an lbm_value.
737 * \param x double to encode.
738 * \return result encoded value.
739 */
740extern lbm_value lbm_enc_double(double x);
741
742static inline lbm_value lbm_enc_char(uint8_t x) {
743 return ((lbm_uint)x << LBM_VAL_SHIFT4) | LBM_TYPE_CHAR0x00000004u;
744}
745
746static inline lbm_int lbm_dec_i(lbm_value x) {
747 return (lbm_int)x >> LBM_VAL_SHIFT4;
748}
749
750static inline lbm_uint lbm_dec_u(lbm_value x) {
751 return x >> LBM_VAL_SHIFT4;
752}
753
754static inline uint8_t lbm_dec_char(lbm_value x) {
755 return (uint8_t)(x >> LBM_VAL_SHIFT4);
756}
757
758static inline lbm_uint lbm_dec_sym(lbm_value x) {
759 return x >> LBM_VAL_SHIFT4;
760}
761
762/** Decode an lbm_value representing a float.
763 * \param x Value to decode.
764 * \return decoded float.
765 */
766extern float lbm_dec_float(lbm_value x);
767
768/** Decode an lbm_value representing a double.
769 * \param x Value to decode.
770 * \return decoded float.
771 */
772extern double lbm_dec_double(lbm_value x);
773
774
775static inline uint32_t lbm_dec_u32(lbm_value x) {
776#ifndef LBM64
777 return (uint32_t)lbm_car(x);
778#else
779 return (uint32_t)(x >> LBM_VAL_SHIFT4);
780#endif
781}
782
783/** Decode an lbm_value representing a 64 bit unsigned integer.
784 * \param x Value to decode.
785 * \return decoded uint64_t.
786 */
787extern uint64_t lbm_dec_u64(lbm_value x);
788
789static inline int32_t lbm_dec_i32(lbm_value x) {
790#ifndef LBM64
791 return (int32_t)lbm_car(x);
792#else
793 return (int32_t)(x >> LBM_VAL_SHIFT4);
794#endif
795}
796
797/** Decode an lbm_value representing a 64 bit integer.
798 * \param x Value to decode.
799 * \return decoded int64_t.
800 */
801extern int64_t lbm_dec_i64(lbm_value x);
802
803/**
804 * Check if a value is a heap pointer
805 * \param x Value to check
806 * \return true if x is a pointer to a heap cell, false otherwise.
807 */
808static inline bool_Bool lbm_is_ptr(lbm_value x) {
809 return (x & LBM_PTR_BIT0x00000001u);
810}
811
812/**
813 * Check if a value is a Read/Writeable cons cell
814 * \param x Value to check
815 * \return true if x is a Read/Writeable cons cell, false otherwise.
816 */
817static inline bool_Bool lbm_is_cons_rw(lbm_value x) {
818 return (lbm_type_of(x) == LBM_TYPE_CONS0x10000000u);
819}
820
821/**
822 * Check if a value is a Readable cons cell
823 * \param x Value to check
824 * \return true if x is a readable cons cell, false otherwise.
825 */
826static inline bool_Bool lbm_is_cons(lbm_value x) {
827 return lbm_is_ptr(x) && ((x & LBM_CONS_TYPE_MASK0xF0000000u) == LBM_TYPE_CONS0x10000000u);
828}
829
830/** Check if a value represents a number
831 * \param x Value to check.
832 * \return true is x represents a number and false otherwise.
833 */
834static inline bool_Bool lbm_is_number(lbm_value x) {
835 return
20
←
Returning value, which participates in a condition later
→
836 (x & LBM_PTR_BIT0x00000001u) ?
18
←
Assuming the condition is false
→
19
←
'?' condition is false
→
837 ((x & LBM_NUMBER_MASK0x08000000u) == LBM_NUMBER_MASK0x08000000u) :
838 (x & LBM_VAL_TYPE_MASK0x0000000Cu);
839}
840
841/** Check if value is an array that can be READ
842 * \param x Value to check.
843 * \return true if x represents a readable array and false otherwise.
844 */
845static inline bool_Bool lbm_is_array_r(lbm_value x) {
846 lbm_type t = lbm_type_of(x);
847 return ((t & LBM_PTR_TO_CONSTANT_MASK~0x04000000u) == LBM_TYPE_ARRAY0x80000000u);
848}
849
850static inline bool_Bool lbm_is_array_rw(lbm_value x) {
851 return( (lbm_type_of(x) == LBM_TYPE_ARRAY0x80000000u) && !(x & LBM_PTR_TO_CONSTANT_BIT0x04000000u));
852}
853
854static inline bool_Bool lbm_is_lisp_array_r(lbm_value x) {
855 lbm_type t = lbm_type_of(x);
856 return ((t & LBM_PTR_TO_CONSTANT_MASK~0x04000000u) == LBM_TYPE_LISPARRAY0xB0000000u);
857}
858
859static inline bool_Bool lbm_is_lisp_array_rw(lbm_value x) {
860 return( (lbm_type_of(x) == LBM_TYPE_LISPARRAY0xB0000000u) && !(x & LBM_PTR_TO_CONSTANT_BIT0x04000000u));
861}
862
863
864static inline bool_Bool lbm_is_channel(lbm_value x) {
865 return (lbm_type_of(x) == LBM_TYPE_CHANNEL0x90000000u &&
866 lbm_type_of(lbm_cdr(x)) == LBM_TYPE_SYMBOL0x00000000u &&
867 lbm_cdr(x) == ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
868}
869static inline bool_Bool lbm_is_char(lbm_value x) {
870 return (lbm_type_of(x) == LBM_TYPE_CHAR0x00000004u);
871}
872
873static inline bool_Bool lbm_is_special(lbm_value symrep) {
874 return ((lbm_type_of(symrep) == LBM_TYPE_SYMBOL0x00000000u) &&
875 (lbm_dec_sym(symrep) < SPECIAL_SYMBOLS_END0xFFFF));
876}
877
878static inline bool_Bool lbm_is_closure(lbm_value exp) {
879 return ((lbm_is_cons(exp)) &&
880 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
881 (lbm_car(exp) == ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u)));
882}
883
884static inline bool_Bool lbm_is_continuation(lbm_value exp) {
885 return ((lbm_type_of(exp) == LBM_TYPE_CONS0x10000000u) &&
886 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
887 (lbm_car(exp) == ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u)));
888}
889
890static inline bool_Bool lbm_is_macro(lbm_value exp) {
891 return ((lbm_type_of(exp) == LBM_TYPE_CONS0x10000000u) &&
892 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
893 (lbm_car(exp) == ENC_SYM_MACRO(((0x10D) << 4) | 0x00000000u)));
894}
895
896static inline bool_Bool lbm_is_match_binder(lbm_value exp) {
897 return (lbm_is_cons(exp) &&
898 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
899 (lbm_car(exp) == ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u)));
900}
901
902static inline bool_Bool lbm_is_comma_qualified_symbol(lbm_value exp) {
903 return (lbm_is_cons(exp) &&
904 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
905 (lbm_car(exp) == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) &&
906 (lbm_type_of(lbm_cadr(exp)) == LBM_TYPE_SYMBOL0x00000000u));
907}
908
909static inline bool_Bool lbm_is_symbol(lbm_value exp) {
910 return !(exp & LBM_LOW_RESERVED_BITS0x0000000Fu);
911}
912
913static inline bool_Bool lbm_is_symbol_nil(lbm_value exp) {
914 return !exp;
9
←
Assuming 'exp' is 0
→
10
←
Returning the value 1, which participates in a condition later
→
915}
916
917static inline bool_Bool lbm_is_symbol_true(lbm_value exp) {
918 return (lbm_is_symbol(exp) && exp == ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u));
919}
920
921static inline bool_Bool lbm_is_symbol_eval(lbm_value exp) {
922 return (lbm_is_symbol(exp) && exp == ENC_SYM_EVAL(((0x30008) << 4) | 0x00000000u));
923}
924
925static inline bool_Bool lbm_is_symbol_merror(lbm_value exp) {
926 return lbm_is_symbol(exp) && (exp == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
927}
928
929static inline bool_Bool lbm_is_list(lbm_value x) {
930 return (lbm_is_cons(x) || lbm_is_symbol_nil(x));
931}
932
933static inline bool_Bool lbm_is_list_rw(lbm_value x) {
934 return (lbm_is_cons_rw(x) || lbm_is_symbol_nil(x));
935}
936
937static inline bool_Bool lbm_is_quoted_list(lbm_value x) {
938 return (lbm_is_cons(x) &&
939 lbm_is_symbol(lbm_car(x)) &&
940 (lbm_car(x) == ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u)) &&
941 lbm_is_cons(lbm_cdr(x)) &&
942 lbm_is_cons(lbm_cadr(x)));
943}
944
945#ifndef LBM64
946#define ERROR_SYMBOL_MASK0xFFFFFFF0 0xFFFFFFF0
947#else
948#define ERROR_SYMBOL_MASK0xFFFFFFF0 0xFFFFFFFFFFFFFFF0
949#endif
950
951/* all error signaling symbols are in the range 0x20 - 0x2F */
952static inline bool_Bool lbm_is_error(lbm_value v){
953 return (lbm_is_symbol(v) &&
954 ((lbm_dec_sym(v) & ERROR_SYMBOL_MASK0xFFFFFFF0) == 0x20));
955}
956
957// ref_cell: returns a reference to the cell addressed by bits 3 - 26
958// Assumes user has checked that is_ptr was set
959static inline lbm_cons_t* lbm_ref_cell(lbm_value addr) {
960 return &lbm_dec_heap(addr)[lbm_dec_cons_cell_ptr(addr)];
961 //return &lbm_heap_state.heap[lbm_dec_ptr(addr)];
962}
963
964
965// lbm_uint a = lbm_heaps[0];
966// lbm_uint b = lbm_heaps[1];
967// lbm_uint i = (addr & LBM_PTR_TO_CONSTANT_BIT) >> LBM_PTR_TO_CONSTANT_SHIFT) - 1;
968// lbm_uint h = (a & i) | (b & ~i);
969
970#ifdef __cplusplus
971}
972#endif
973#endif
diff --git a/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-ce8d59.html b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-ce8d59.html new file mode 100644 index 00000000..85e2513a --- /dev/null +++ b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-ce8d59.html @@ -0,0 +1,2797 @@ + + + +src/heap.c + + + + + + + + + + + + + + + + + + + + + + + + + + +

Bug Summary

+ + + + +
File:heap.c
Warning:line 234, column 19
Access to field 'data' results in a dereference of a null pointer (loaded from variable 'array')
+ +

Annotated Source Code

+

Press '?' + to see keyboard shortcuts

+ + +
clang -cc1 -triple i386-pc-linux-gnu -analyze -disable-free -disable-llvm-verifier -discard-value-names -main-file-name heap.c -analyzer-store=region -analyzer-opt-analyze-nested-blocks -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -mrelocation-model static -mthread-model posix -mframe-pointer=none -fmath-errno -fno-rounding-math -masm-verbose -mconstructor-aliases -target-cpu i686 -dwarf-column-info -fno-split-dwarf-inlining -debugger-tuning=gdb -resource-dir /usr/lib/llvm-10/lib/clang/10.0.0 -I ./include -I ./include/extensions -I platform/linux/include -D _PRELUDE -internal-isystem /usr/local/include -internal-isystem /usr/lib/llvm-10/lib/clang/10.0.0/include -internal-externc-isystem /usr/include/i386-linux-gnu -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -std=c99 -fdebug-compilation-dir /home/joels/Current/lispbm -ferror-limit 19 -fmessage-length 0 -fgnuc-version=4.2.1 -fobjc-runtime=gcc -fdiagnostics-show-option -vectorize-loops -vectorize-slp -analyzer-output=html -faddrsig -o /home/joels/Current/lispbm/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1 -x c src/heap.c +
+ + + +
+ + +
+ + + + +
+

src/heap.c

+
→
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1/*
2 Copyright 2018, 2020, 2022 - 2024 Joel Svensson svenssonjoel@yahoo.se
3 2022 Benjamin Vedder
4
5 This program is free software: you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation, either version 3 of the License, or
8 (at your option) any later version.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
14
15 You should have received a copy of the GNU General Public License
16 along with this program. If not, see <http://www.gnu.org/licenses/>.
17*/
18
19#include <stdio.h>
20#include <stdlib.h>
21#include <stdint.h>
22#include <stdarg.h>
23#include <inttypes.h>
24#include <lbm_memory.h>
25#include <lbm_custom_type.h>
26
27#include "heap.h"
28#include "symrepr.h"
29#include "stack.h"
30#include "lbm_channel.h"
31#include "platform_mutex.h"
32#include "eval_cps.h"
33#ifdef VISUALIZE_HEAP
34#include "heap_vis.h"
35#endif
36
37
38static inline lbm_value lbm_set_gc_mark(lbm_value x) {
39 return x | LBM_GC_MARKED0x00000002u;
40}
41
42static inline lbm_value lbm_clr_gc_mark(lbm_value x) {
43 return x & ~LBM_GC_MASK0x00000002u;
44}
45
46static inline bool_Bool lbm_get_gc_mark(lbm_value x) {
47 return x & LBM_GC_MASK0x00000002u;
48}
49
50// flag is the same bit as mark, but in car
51static inline bool_Bool lbm_get_gc_flag(lbm_value x) {
52 return x & LBM_GC_MARKED0x00000002u;
53}
54
55static inline lbm_value lbm_set_gc_flag(lbm_value x) {
56 return x | LBM_GC_MARKED0x00000002u;
57}
58
59static inline lbm_value lbm_clr_gc_flag(lbm_value x) {
60 return x & ~LBM_GC_MASK0x00000002u;
61}
62
63
64lbm_heap_state_t lbm_heap_state;
65
66lbm_const_heap_t *lbm_const_heap_state;
67
68lbm_cons_t *lbm_heaps[2] = {NULL((void*)0), NULL((void*)0)};
69
70static mutex_t lbm_const_heap_mutex;
71static bool_Bool lbm_const_heap_mutex_initialized = false0;
72
73static mutex_t lbm_mark_mutex;
74static bool_Bool lbm_mark_mutex_initialized = false0;
75
76#ifdef USE_GC_PTR_REV
77void lbm_gc_lock(void) {
78 mutex_lock(&lbm_mark_mutex);
79}
80void lbm_gc_unlock(void) {
81 mutex_unlock(&lbm_mark_mutex);
82}
83#else
84void lbm_gc_lock(void) {
85}
86void lbm_gc_unlock(void) {
87}
88#endif
89
90/****************************************************/
91/* ENCODERS DECODERS */
92
93lbm_value lbm_enc_i32(int32_t x) {
94#ifndef LBM64
95 lbm_value i = lbm_cons((lbm_uint)x, ENC_SYM_RAW_I_TYPE(((0x31) << 4) | 0x00000000u));
96 if (lbm_type_of(i) == LBM_TYPE_SYMBOL0x00000000u) return i;
97 return lbm_set_ptr_type(i, LBM_TYPE_I320x28000000u);
98#else
99 return (((lbm_uint)x) << LBM_VAL_SHIFT4) | LBM_TYPE_I320x28000000u;
100#endif
101}
102
103lbm_value lbm_enc_u32(uint32_t x) {
104#ifndef LBM64
105 lbm_value u = lbm_cons(x, ENC_SYM_RAW_U_TYPE(((0x32) << 4) | 0x00000000u));
106 if (lbm_type_of(u) == LBM_TYPE_SYMBOL0x00000000u) return u;
107 return lbm_set_ptr_type(u, LBM_TYPE_U320x38000000u);
108#else
109 return (((lbm_uint)x) << LBM_VAL_SHIFT4) | LBM_TYPE_U320x38000000u;
110#endif
111}
112
113lbm_value lbm_enc_float(float x) {
114#ifndef LBM64
115 lbm_uint t;
116 memcpy(&t, &x, sizeof(lbm_float));
117 lbm_value f = lbm_cons(t, ENC_SYM_RAW_F_TYPE(((0x33) << 4) | 0x00000000u));
118 if (lbm_type_of(f) == LBM_TYPE_SYMBOL0x00000000u) return f;
119 return lbm_set_ptr_type(f, LBM_TYPE_FLOAT0x68000000u);
120#else
121 lbm_uint t = 0;
122 memcpy(&t, &x, sizeof(float));
123 return (((lbm_uint)t) << LBM_VAL_SHIFT4) | LBM_TYPE_FLOAT0x68000000u;
124#endif
125}
126
127static lbm_value enc_64_on_32(uint8_t *source, lbm_uint type_qual, lbm_uint type) {
128 lbm_value res = ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u);
129 res = lbm_cons(ENC_SYM_NIL(((0x0) << 4) | 0x00000000u),ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
130 if (lbm_type_of(res) != LBM_TYPE_SYMBOL0x00000000u) {
131 uint8_t* storage = lbm_malloc(sizeof(uint64_t));
132 if (storage) {
133 memcpy(storage,source, sizeof(uint64_t));
134 lbm_set_car_and_cdr(res, (lbm_uint)storage, type_qual);
135 res = lbm_set_ptr_type(res, type);
136 } else {
137 res = ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u);
138 }
139 }
140 return res;
141}
142
143lbm_value lbm_enc_i64(int64_t x) {
144#ifndef LBM64
145 return enc_64_on_32((uint8_t *)&x, ENC_SYM_IND_I_TYPE(((0x34) << 4) | 0x00000000u), LBM_TYPE_I640x48000000u);
146#else
147 lbm_value u = lbm_cons((uint64_t)x, ENC_SYM_RAW_I_TYPE(((0x31) << 4) | 0x00000000u));
148 if (lbm_type_of(u) == LBM_TYPE_SYMBOL0x00000000u) return u;
149 return lbm_set_ptr_type(u, LBM_TYPE_I640x48000000u);
150#endif
151}
152
153lbm_value lbm_enc_u64(uint64_t x) {
154#ifndef LBM64
155 return enc_64_on_32((uint8_t *)&x, ENC_SYM_IND_U_TYPE(((0x35) << 4) | 0x00000000u), LBM_TYPE_U640x58000000u);
156#else
157 lbm_value u = lbm_cons(x, ENC_SYM_RAW_U_TYPE(((0x32) << 4) | 0x00000000u));
158 if (lbm_type_of(u) == LBM_TYPE_SYMBOL0x00000000u) return u;
159 return lbm_set_ptr_type(u, LBM_TYPE_U640x58000000u);
160#endif
161}
162
163lbm_value lbm_enc_double(double x) {
164#ifndef LBM64
165 return enc_64_on_32((uint8_t *)&x, ENC_SYM_IND_F_TYPE(((0x36) << 4) | 0x00000000u), LBM_TYPE_DOUBLE0x78000000u);
166#else
167 lbm_uint t;
168 memcpy(&t, &x, sizeof(double));
169 lbm_value f = lbm_cons(t, ENC_SYM_RAW_F_TYPE(((0x33) << 4) | 0x00000000u));
170 if (lbm_type_of(f) == LBM_TYPE_SYMBOL0x00000000u) return f;
171 return lbm_set_ptr_type(f, LBM_TYPE_DOUBLE0x78000000u);
172#endif
173}
174
175// Type specific (as opposed to the dec_as_X) functions
176// should only be run on values KNOWN to represent a value of the type
177// that the decoder decodes.
178
179float lbm_dec_float(lbm_value x) {
180#ifndef LBM64
181 float f_tmp;
182 lbm_uint tmp = lbm_car(x);
183 memcpy(&f_tmp, &tmp, sizeof(float));
184 return f_tmp;
185#else
186 uint32_t tmp = (uint32_t)(x >> LBM_VAL_SHIFT4);
187 float f_tmp;
188 memcpy(&f_tmp, &tmp, sizeof(float));
189 return f_tmp;
190#endif
191}
192
193double lbm_dec_double(lbm_value x) {
194#ifndef LBM64
195 double d;
196 uint32_t *data = (uint32_t*)lbm_car(x);
197 memcpy(&d, data, sizeof(double));
198 return d;
199#else
200 double f_tmp;
201 lbm_uint tmp = lbm_car(x);
202 memcpy(&f_tmp, &tmp, sizeof(double));
203 return f_tmp;
204#endif
205}
206
207uint64_t lbm_dec_u64(lbm_value x) {
208#ifndef LBM64
209 uint64_t u;
210 uint32_t *data = (uint32_t*)lbm_car(x);
211 memcpy(&u, data, 8);
212 return u;
213#else
214 return (uint64_t)lbm_car(x);
215#endif
216}
217
218int64_t lbm_dec_i64(lbm_value x) {
219#ifndef LBM64
220 int64_t i;
221 uint32_t *data = (uint32_t*)lbm_car(x);
222 memcpy(&i, data, 8);
223 return i;
224#else
225 return (int64_t)lbm_car(x);
226#endif
227}
228
229char *lbm_dec_str(lbm_value val) {
230 char *res = 0;
231 // If val is an array, car of val will be non-null.
232 if (lbm_is_array_r(val)) {
1
Calling 'lbm_is_array_r'
→
4
←
Returning from 'lbm_is_array_r'
→
5
←
Taking true branch
→
233 lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(val);
6
←
Calling 'lbm_car'
→
12
←
Returning from 'lbm_car'
→
13
←
'array' initialized to a null pointer value
→
234 res = (char *)array->data;
14
←
Access to field 'data' results in a dereference of a null pointer (loaded from variable 'array')
235 }
236 return res;
237}
238
239lbm_char_channel_t *lbm_dec_channel(lbm_value val) {
240 lbm_char_channel_t *res = NULL((void*)0);
241
242 if (lbm_type_of(val) == LBM_TYPE_CHANNEL0x90000000u) {
243 res = (lbm_char_channel_t *)lbm_car(val);
244 }
245 return res;
246}
247
248lbm_uint lbm_dec_custom(lbm_value val) {
249 lbm_uint res = 0;
250 if (lbm_type_of(val) == LBM_TYPE_CUSTOM0xA0000000u) {
251 res = (lbm_uint)lbm_car(val);
252 }
253 return res;
254}
255
256uint8_t lbm_dec_as_char(lbm_value a) {
257 switch (lbm_type_of_functional(a)) {
258 case LBM_TYPE_CHAR0x00000004u:
259 return (uint8_t) lbm_dec_char(a);
260 case LBM_TYPE_I0x00000008u:
261 return (uint8_t) lbm_dec_i(a);
262 case LBM_TYPE_U0x0000000Cu:
263 return (uint8_t) lbm_dec_u(a);
264 case LBM_TYPE_I320x28000000u:
265 return (uint8_t) lbm_dec_i32(a);
266 case LBM_TYPE_U320x38000000u:
267 return (uint8_t) lbm_dec_u32(a);
268 case LBM_TYPE_FLOAT0x68000000u:
269 return (uint8_t)lbm_dec_float(a);
270 case LBM_TYPE_I640x48000000u:
271 return (uint8_t) lbm_dec_i64(a);
272 case LBM_TYPE_U640x58000000u:
273 return (uint8_t) lbm_dec_u64(a);
274 case LBM_TYPE_DOUBLE0x78000000u:
275 return (uint8_t) lbm_dec_double(a);
276 }
277 return 0;
278}
279
280uint32_t lbm_dec_as_u32(lbm_value a) {
281 switch (lbm_type_of_functional(a)) {
282 case LBM_TYPE_CHAR0x00000004u:
283 return (uint32_t) lbm_dec_char(a);
284 case LBM_TYPE_I0x00000008u:
285 return (uint32_t) lbm_dec_i(a);
286 case LBM_TYPE_U0x0000000Cu:
287 return (uint32_t) lbm_dec_u(a);
288 case LBM_TYPE_I320x28000000u: /* fall through */
289 case LBM_TYPE_U320x38000000u:
290 return (uint32_t) lbm_dec_u32(a);
291 case LBM_TYPE_FLOAT0x68000000u:
292 return (uint32_t)lbm_dec_float(a);
293 case LBM_TYPE_I640x48000000u:
294 return (uint32_t) lbm_dec_i64(a);
295 case LBM_TYPE_U640x58000000u:
296 return (uint32_t) lbm_dec_u64(a);
297 case LBM_TYPE_DOUBLE0x78000000u:
298 return (uint32_t) lbm_dec_double(a);
299 }
300 return 0;
301}
302
303int32_t lbm_dec_as_i32(lbm_value a) {
304 switch (lbm_type_of_functional(a)) {
305 case LBM_TYPE_CHAR0x00000004u:
306 return (int32_t) lbm_dec_char(a);
307 case LBM_TYPE_I0x00000008u:
308 return (int32_t) lbm_dec_i(a);
309 case LBM_TYPE_U0x0000000Cu:
310 return (int32_t) lbm_dec_u(a);
311 case LBM_TYPE_I320x28000000u:
312 return (int32_t) lbm_dec_i32(a);
313 case LBM_TYPE_U320x38000000u:
314 return (int32_t) lbm_dec_u32(a);
315 case LBM_TYPE_FLOAT0x68000000u:
316 return (int32_t) lbm_dec_float(a);
317 case LBM_TYPE_I640x48000000u:
318 return (int32_t) lbm_dec_i64(a);
319 case LBM_TYPE_U640x58000000u:
320 return (int32_t) lbm_dec_u64(a);
321 case LBM_TYPE_DOUBLE0x78000000u:
322 return (int32_t) lbm_dec_double(a);
323
324 }
325 return 0;
326}
327
328int64_t lbm_dec_as_i64(lbm_value a) {
329 switch (lbm_type_of_functional(a)) {
330 case LBM_TYPE_CHAR0x00000004u:
331 return (int64_t) lbm_dec_char(a);
332 case LBM_TYPE_I0x00000008u:
333 return lbm_dec_i(a);
334 case LBM_TYPE_U0x0000000Cu:
335 return (int64_t) lbm_dec_u(a);
336 case LBM_TYPE_I320x28000000u:
337 return (int64_t) lbm_dec_i32(a);
338 case LBM_TYPE_U320x38000000u:
339 return (int64_t) lbm_dec_u32(a);
340 case LBM_TYPE_FLOAT0x68000000u:
341 return (int64_t) lbm_dec_float(a);
342 case LBM_TYPE_I640x48000000u:
343 return (int64_t) lbm_dec_i64(a);
344 case LBM_TYPE_U640x58000000u:
345 return (int64_t) lbm_dec_u64(a);
346 case LBM_TYPE_DOUBLE0x78000000u:
347 return (int64_t) lbm_dec_double(a);
348 }
349 return 0;
350}
351
352uint64_t lbm_dec_as_u64(lbm_value a) {
353 switch (lbm_type_of_functional(a)) {
354 case LBM_TYPE_CHAR0x00000004u:
355 return (uint64_t) lbm_dec_char(a);
356 case LBM_TYPE_I0x00000008u:
357 return (uint64_t) lbm_dec_i(a);
358 case LBM_TYPE_U0x0000000Cu:
359 return lbm_dec_u(a);
360 case LBM_TYPE_I320x28000000u:
361 return (uint64_t) lbm_dec_i32(a);
362 case LBM_TYPE_U320x38000000u:
363 return (uint64_t) lbm_dec_u32(a);
364 case LBM_TYPE_FLOAT0x68000000u:
365 return (uint64_t)lbm_dec_float(a);
366 case LBM_TYPE_I640x48000000u:
367 return (uint64_t) lbm_dec_i64(a);
368 case LBM_TYPE_U640x58000000u:
369 return (uint64_t) lbm_dec_u64(a);
370 case LBM_TYPE_DOUBLE0x78000000u:
371 return (uint64_t) lbm_dec_double(a);
372 }
373 return 0;
374}
375
376lbm_uint lbm_dec_as_uint(lbm_value a) {
377 switch (lbm_type_of_functional(a)) {
378 case LBM_TYPE_CHAR0x00000004u:
379 return (lbm_uint) lbm_dec_char(a);
380 case LBM_TYPE_I0x00000008u:
381 return (lbm_uint) lbm_dec_i(a);
382 case LBM_TYPE_U0x0000000Cu:
383 return (lbm_uint) lbm_dec_u(a);
384 case LBM_TYPE_I320x28000000u:
385 return (lbm_uint) lbm_dec_i32(a);
386 case LBM_TYPE_U320x38000000u:
387 return (lbm_uint) lbm_dec_u32(a);
388 case LBM_TYPE_FLOAT0x68000000u:
389 return (lbm_uint) lbm_dec_float(a);
390 case LBM_TYPE_I640x48000000u:
391 return (lbm_uint) lbm_dec_i64(a);
392 case LBM_TYPE_U640x58000000u:
393 return (lbm_uint) lbm_dec_u64(a);
394 case LBM_TYPE_DOUBLE0x78000000u:
395 return (lbm_uint) lbm_dec_double(a);
396 }
397 return 0;
398}
399
400lbm_int lbm_dec_as_int(lbm_value a) {
401 switch (lbm_type_of_functional(a)) {
402 case LBM_TYPE_CHAR0x00000004u:
403 return (lbm_int) lbm_dec_char(a);
404 case LBM_TYPE_I0x00000008u:
405 return (lbm_int) lbm_dec_i(a);
406 case LBM_TYPE_U0x0000000Cu:
407 return (lbm_int) lbm_dec_u(a);
408 case LBM_TYPE_I320x28000000u:
409 return (lbm_int) lbm_dec_i32(a);
410 case LBM_TYPE_U320x38000000u:
411 return (lbm_int) lbm_dec_u32(a);
412 case LBM_TYPE_FLOAT0x68000000u:
413 return (lbm_int)lbm_dec_float(a);
414 case LBM_TYPE_I640x48000000u:
415 return (lbm_int) lbm_dec_i64(a);
416 case LBM_TYPE_U640x58000000u:
417 return (lbm_int) lbm_dec_u64(a);
418 case LBM_TYPE_DOUBLE0x78000000u:
419 return (lbm_int) lbm_dec_double(a);
420 }
421 return 0;
422}
423
424float lbm_dec_as_float(lbm_value a) {
425
426 switch (lbm_type_of_functional(a)) {
427 case LBM_TYPE_CHAR0x00000004u:
428 return (float) lbm_dec_char(a);
429 case LBM_TYPE_I0x00000008u:
430 return (float) lbm_dec_i(a);
431 case LBM_TYPE_U0x0000000Cu:
432 return (float) lbm_dec_u(a);
433 case LBM_TYPE_I320x28000000u:
434 return (float) lbm_dec_i32(a);
435 case LBM_TYPE_U320x38000000u:
436 return (float) lbm_dec_u32(a);
437 case LBM_TYPE_FLOAT0x68000000u:
438 return (float) lbm_dec_float(a);
439 case LBM_TYPE_I640x48000000u:
440 return (float) lbm_dec_i64(a);
441 case LBM_TYPE_U640x58000000u:
442 return (float) lbm_dec_u64(a);
443 case LBM_TYPE_DOUBLE0x78000000u:
444 return (float) lbm_dec_double(a);
445 }
446 return 0;
447}
448
449double lbm_dec_as_double(lbm_value a) {
450
451 switch (lbm_type_of_functional(a)) {
452 case LBM_TYPE_CHAR0x00000004u:
453 return (double) lbm_dec_char(a);
454 case LBM_TYPE_I0x00000008u:
455 return (double) lbm_dec_i(a);
456 case LBM_TYPE_U0x0000000Cu:
457 return (double) lbm_dec_u(a);
458 case LBM_TYPE_I320x28000000u:
459 return (double) lbm_dec_i32(a);
460 case LBM_TYPE_U320x38000000u:
461 return (double) lbm_dec_u32(a);
462 case LBM_TYPE_FLOAT0x68000000u:
463 return (double) lbm_dec_float(a);
464 case LBM_TYPE_I640x48000000u:
465 return (double) lbm_dec_i64(a);
466 case LBM_TYPE_U640x58000000u:
467 return (double) lbm_dec_u64(a);
468 case LBM_TYPE_DOUBLE0x78000000u:
469 return (double) lbm_dec_double(a);
470 }
471 return 0;
472}
473
474/****************************************************/
475/* HEAP MANAGEMENT */
476
477static int generate_freelist(size_t num_cells) {
478 size_t i = 0;
479
480 if (!lbm_heap_state.heap) return 0;
481
482 lbm_heap_state.freelist = lbm_enc_cons_ptr(0);
483
484 lbm_cons_t *t;
485
486 // Add all cells to free list
487 for (i = 1; i < num_cells; i ++) {
488 t = lbm_ref_cell(lbm_enc_cons_ptr(i-1));
489 t->car = ENC_SYM_RECOVERED(((0x28) << 4) | 0x00000000u); // all cars in free list are "RECOVERED"
490 t->cdr = lbm_enc_cons_ptr(i);
491 }
492
493 // Replace the incorrect pointer at the last cell.
494 t = lbm_ref_cell(lbm_enc_cons_ptr(num_cells-1));
495 t->cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
496
497 return 1;
498}
499
500void lbm_nil_freelist(void) {
501 lbm_heap_state.freelist = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
502 lbm_heap_state.num_alloc = lbm_heap_state.heap_size;
503}
504
505static void heap_init_state(lbm_cons_t *addr, lbm_uint num_cells,
506 lbm_uint* gc_stack_storage, lbm_uint gc_stack_size) {
507 lbm_heap_state.heap = addr;
508 lbm_heap_state.heap_bytes = (unsigned int)(num_cells * sizeof(lbm_cons_t));
509 lbm_heap_state.heap_size = num_cells;
510
511 lbm_stack_create(&lbm_heap_state.gc_stack, gc_stack_storage, gc_stack_size);
512
513 lbm_heap_state.num_alloc = 0;
514 lbm_heap_state.num_alloc_arrays = 0;
515 lbm_heap_state.gc_num = 0;
516 lbm_heap_state.gc_marked = 0;
517 lbm_heap_state.gc_recovered = 0;
518 lbm_heap_state.gc_recovered_arrays = 0;
519 lbm_heap_state.gc_least_free = num_cells;
520 lbm_heap_state.gc_last_free = num_cells;
521}
522
523void lbm_heap_new_freelist_length(void) {
524 lbm_uint l = lbm_heap_state.heap_size - lbm_heap_state.num_alloc;
525 lbm_heap_state.gc_last_free = l;
526 if (l < lbm_heap_state.gc_least_free)
527 lbm_heap_state.gc_least_free = l;
528}
529
530int lbm_heap_init(lbm_cons_t *addr, lbm_uint num_cells,
531 lbm_uint gc_stack_size) {
532
533 if (((uintptr_t)addr % 8) != 0) return 0;
534
535 memset(addr,0, sizeof(lbm_cons_t) * num_cells);
536
537 lbm_uint *gc_stack_storage = (lbm_uint*)lbm_malloc(gc_stack_size * sizeof(lbm_uint));
538 if (gc_stack_storage == NULL((void*)0)) return 0;
539
540 heap_init_state(addr, num_cells,
541 gc_stack_storage, gc_stack_size);
542
543 lbm_heaps[0] = addr;
544
545 return generate_freelist(num_cells);
546}
547
548lbm_uint lbm_heap_num_free(void) {
549 return lbm_heap_state.heap_size - lbm_heap_state.num_alloc;
550}
551
552lbm_value lbm_heap_allocate_cell(lbm_type ptr_type, lbm_value car, lbm_value cdr) {
553 lbm_value res;
554 // it is a ptr replace freelist with cdr of freelist;
555 res = lbm_heap_state.freelist;
556 if (lbm_type_of(res) == LBM_TYPE_CONS0x10000000u) {
557 lbm_uint heap_ix = lbm_dec_ptr(res);
558 lbm_heap_state.freelist = lbm_heap_state.heap[heap_ix].cdr;
559 lbm_heap_state.num_alloc++;
560 lbm_heap_state.heap[heap_ix].car = car;
561 lbm_heap_state.heap[heap_ix].cdr = cdr;
562 res = lbm_set_ptr_type(res, ptr_type);
563 return res;
564 }
565 return ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u);
566}
567
568lbm_value lbm_heap_allocate_list(lbm_uint n) {
569 if (n == 0) return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
570 if (lbm_heap_num_free() < n) return ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u);
571
572 lbm_value curr = lbm_heap_state.freelist;
573 lbm_value res = curr;
574 if (lbm_type_of(curr) == LBM_TYPE_CONS0x10000000u) {
575
576 lbm_cons_t *c_cell = NULL((void*)0);
577 lbm_uint count = 0;
578 do {
579 c_cell = lbm_ref_cell(curr);
580 c_cell->car = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
581 curr = c_cell->cdr;
582 count ++;
583 } while (count < n);
584 lbm_heap_state.freelist = curr;
585 c_cell->cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
586 lbm_heap_state.num_alloc+=count;
587 return res;
588 }
589 return ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u);
590}
591
592lbm_value lbm_heap_allocate_list_init_va(unsigned int n, va_list valist) {
593 if (n == 0) return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
594 if (lbm_heap_num_free() < n) return ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u);
595
596 lbm_value curr = lbm_heap_state.freelist;
597 lbm_value res = curr;
598 if (lbm_type_of(curr) == LBM_TYPE_CONS0x10000000u) {
599
600 lbm_cons_t *c_cell = NULL((void*)0);
601 unsigned int count = 0;
602 do {
603 c_cell = lbm_ref_cell(curr);
604 c_cell->car = va_arg(valist, lbm_value)__builtin_va_arg(valist, lbm_value);
605 curr = c_cell->cdr;
606 count ++;
607 } while (count < n);
608 lbm_heap_state.freelist = curr;
609 c_cell->cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
610 lbm_heap_state.num_alloc+=count;
611 return res;
612 }
613 return ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u);
614}
615
616lbm_value lbm_heap_allocate_list_init(unsigned int n, ...) {
617 va_list valist;
618 va_start(valist, n)__builtin_va_start(valist, n);
619 lbm_value r = lbm_heap_allocate_list_init_va(n, valist);
620 va_end(valist)__builtin_va_end(valist);
621 return r;
622}
623
624lbm_uint lbm_heap_num_allocated(void) {
625 return lbm_heap_state.num_alloc;
626}
627lbm_uint lbm_heap_size(void) {
628 return lbm_heap_state.heap_size;
629}
630
631lbm_uint lbm_heap_size_bytes(void) {
632 return lbm_heap_state.heap_bytes;
633}
634
635void lbm_get_heap_state(lbm_heap_state_t *res) {
636 *res = lbm_heap_state;
637}
638
639lbm_uint lbm_get_gc_stack_max(void) {
640 return lbm_heap_state.gc_stack.max_sp;
641}
642
643lbm_uint lbm_get_gc_stack_size(void) {
644 return lbm_heap_state.gc_stack.size;
645}
646
647#ifdef USE_GC_PTR_REV
648static inline void value_assign(lbm_value *a, lbm_value b) {
649 lbm_value a_old = *a & LBM_GC_MASK0x00000002u;
650 *a = a_old | (b & ~LBM_GC_MASK0x00000002u);
651}
652
653void lbm_gc_mark_phase(lbm_value root) {
654 bool_Bool work_to_do = true1;
655
656 if (!lbm_is_ptr(root)) return;
657
658 mutex_lock(&lbm_const_heap_mutex);
659 lbm_value curr = root;
660 lbm_value prev = lbm_enc_cons_ptr(LBM_PTR_NULL(0x03FFFFFCu >> 2));
661
662 while (work_to_do) {
663 // follow leftwards pointers
664 while (lbm_is_ptr(curr) &&
665 (lbm_dec_ptr(curr) != LBM_PTR_NULL(0x03FFFFFCu >> 2)) &&
666 ((curr & LBM_PTR_TO_CONSTANT_BIT0x04000000u) == 0) &&
667 !lbm_get_gc_mark(lbm_cdr(curr))) {
668 // Mark the cell if not a constant cell
669 lbm_cons_t *cell = lbm_ref_cell(curr);
670 cell->cdr = lbm_set_gc_mark(cell->cdr);
671 if (lbm_is_cons_rw(curr)) {
672 lbm_value next = 0;
673 value_assign(&next, cell->car);
674 value_assign(&cell->car, prev);
675 value_assign(&prev,curr);
676 value_assign(&curr, next);
677 }
678 // Will jump out next iteration as gc mark is set in curr.
679 }
680 while (lbm_is_ptr(prev) &&
681 (lbm_dec_ptr(prev) != LBM_PTR_NULL(0x03FFFFFCu >> 2)) &&
682 lbm_get_gc_flag(lbm_car(prev)) ) {
683 // clear the flag
684 lbm_cons_t *cell = lbm_ref_cell(prev);
685 cell->car = lbm_clr_gc_flag(cell->car);
686 lbm_value next = 0;
687 value_assign(&next, cell->cdr);
688 value_assign(&cell->cdr, curr);
689 value_assign(&curr, prev);
690 value_assign(&prev, next);
691 }
692 if (lbm_is_ptr(prev) &&
693 lbm_dec_ptr(prev) == LBM_PTR_NULL(0x03FFFFFCu >> 2)) {
694 work_to_do = false0;
695 } else if (lbm_is_ptr(prev)) {
696 // set the flag
697 lbm_cons_t *cell = lbm_ref_cell(prev);
698 cell->car = lbm_set_gc_flag(cell->car);
699 lbm_value next = 0;
700 value_assign(&next, cell->car);
701 value_assign(&cell->car, curr);
702 value_assign(&curr, cell->cdr);
703 value_assign(&cell->cdr, next);
704 }
705 }
706 mutex_unlock(&lbm_const_heap_mutex);
707}
708
709#else
710extern eval_context_t *ctx_running;
711void lbm_gc_mark_phase(lbm_value root) {
712 lbm_value t_ptr;
713 lbm_stack_t *s = &lbm_heap_state.gc_stack;
714 s->data[s->sp++] = root;
715
716 while (!lbm_stack_is_empty(s)) {
717 lbm_value curr;
718 lbm_pop(s, &curr);
719
720 mark_shortcut:
721
722 if (!lbm_is_ptr(curr) ||
723 (curr & LBM_PTR_TO_CONSTANT_BIT0x04000000u)) {
724 continue;
725 }
726
727 lbm_cons_t *cell = &lbm_heap_state.heap[lbm_dec_ptr(curr)];
728
729 if (lbm_get_gc_mark(cell->cdr)) {
730 continue;
731 }
732
733 t_ptr = lbm_type_of(curr);
734
735 // An array is marked in O(N) time using an additional 32bit
736 // value per array that keeps track of how far into the array GC
737 // has progressed.
738 if (t_ptr == LBM_TYPE_LISPARRAY0xB0000000u) {
739 lbm_push(s, curr); // put array back as bookkeeping.
740 lbm_array_header_extended_t *arr = (lbm_array_header_extended_t*)cell->car;
741 lbm_value *arrdata = (lbm_value *)arr->data;
742 uint32_t index = arr->index;
743
744 // Potential optimization.
745 // 1. CONS pointers are set to curr and recurse.
746 // 2. Any other ptr is marked immediately and index is increased.
747 if (lbm_is_ptr(arrdata[index]) && ((arrdata[index] & LBM_PTR_TO_CONSTANT_BIT0x04000000u) == 0) &&
748 !((arrdata[index] & LBM_CONTINUATION_INTERNAL0xF8000001u) == LBM_CONTINUATION_INTERNAL0xF8000001u)) {
749 lbm_cons_t *elt = &lbm_heap_state.heap[lbm_dec_ptr(arrdata[index])];
750 if (!lbm_get_gc_mark(elt->cdr)) {
751 curr = arrdata[index];
752 goto mark_shortcut;
753 }
754 }
755 if (index < ((arr->size/(sizeof(lbm_value))) - 1)) {
756 arr->index++;
757 continue;
758 }
759
760 arr->index = 0;
761 cell->cdr = lbm_set_gc_mark(cell->cdr);
762 lbm_heap_state.gc_marked ++;
763 lbm_pop(s, &curr); // Remove array from GC stack as we are done marking it.
764 continue;
765 }
766
767 cell->cdr = lbm_set_gc_mark(cell->cdr);
768 lbm_heap_state.gc_marked ++;
769
770 if (t_ptr == LBM_TYPE_CONS0x10000000u) {
771 if (lbm_is_ptr(cell->cdr)) {
772 if (!lbm_push(s, cell->cdr)) {
773 lbm_critical_error();
774 break;
775 }
776 }
777 curr = cell->car;
778 goto mark_shortcut; // Skip a push/pop
779 }
780 }
781}
782#endif
783
784//Environments are proper lists with a 2 element list stored in each car.
785void lbm_gc_mark_env(lbm_value env) {
786 lbm_value curr = env;
787 lbm_cons_t *c;
788
789 while (lbm_is_ptr(curr)) {
790 c = lbm_ref_cell(curr);
791 c->cdr = lbm_set_gc_mark(c->cdr); // mark the environent list structure.
792 lbm_cons_t *b = lbm_ref_cell(c->car);
793 b->cdr = lbm_set_gc_mark(b->cdr); // mark the binding list head cell.
794 lbm_gc_mark_phase(b->cdr); // mark the bound object.
795 lbm_heap_state.gc_marked +=2;
796 curr = c->cdr;
797 }
798}
799
800
801void lbm_gc_mark_aux(lbm_uint *aux_data, lbm_uint aux_size) {
802 for (lbm_uint i = 0; i < aux_size; i ++) {
803 if (lbm_is_ptr(aux_data[i])) {
804 lbm_type pt_t = lbm_type_of(aux_data[i]);
805 lbm_uint pt_v = lbm_dec_ptr(aux_data[i]);
806 if( pt_t >= LBM_POINTER_TYPE_FIRST0x10000000u &&
807 pt_t <= LBM_POINTER_TYPE_LAST0xBC000000u &&
808 pt_v < lbm_heap_state.heap_size) {
809 lbm_gc_mark_phase(aux_data[i]);
810 }
811 }
812 }
813}
814
815void lbm_gc_mark_roots(lbm_uint *roots, lbm_uint num_roots) {
816 for (lbm_uint i = 0; i < num_roots; i ++) {
817 lbm_gc_mark_phase(roots[i]);
818 }
819}
820
821// Sweep moves non-marked heap objects to the free list.
822int lbm_gc_sweep_phase(void) {
823 unsigned int i = 0;
824 lbm_cons_t *heap = (lbm_cons_t *)lbm_heap_state.heap;
825
826 for (i = 0; i < lbm_heap_state.heap_size; i ++) {
827 if ( lbm_get_gc_mark(heap[i].cdr)) {
828 heap[i].cdr = lbm_clr_gc_mark(heap[i].cdr);
829 } else {
830 // Check if this cell is a pointer to an array
831 // and free it.
832 if (lbm_type_of(heap[i].cdr) == LBM_TYPE_SYMBOL0x00000000u) {
833 switch(heap[i].cdr) {
834
835 case ENC_SYM_IND_I_TYPE(((0x34) << 4) | 0x00000000u): /* fall through */
836 case ENC_SYM_IND_U_TYPE(((0x35) << 4) | 0x00000000u):
837 case ENC_SYM_IND_F_TYPE(((0x36) << 4) | 0x00000000u):
838 lbm_memory_free((lbm_uint*)heap[i].car);
839 break;
840 case ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u): /* fall through */
841 case ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u):{
842 lbm_array_header_t *arr = (lbm_array_header_t*)heap[i].car;
843 if (lbm_memory_ptr_inside((lbm_uint*)arr->data)) {
844 lbm_memory_free((lbm_uint *)arr->data);
845 lbm_heap_state.gc_recovered_arrays++;
846 }
847 lbm_memory_free((lbm_uint *)arr);
848 } break;
849 case ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u):{
850 lbm_char_channel_t *chan = (lbm_char_channel_t*)heap[i].car;
851 if (lbm_memory_ptr_inside((lbm_uint*)chan)) {
852 lbm_memory_free((lbm_uint*)chan->state);
853 lbm_memory_free((lbm_uint*)chan);
854 }
855 } break;
856 case ENC_SYM_CUSTOM_TYPE(((0x38) << 4) | 0x00000000u): {
857 lbm_uint *t = (lbm_uint*)heap[i].car;
858 lbm_custom_type_destroy(t);
859 lbm_memory_free(t);
860 } break;
861 default:
862 break;
863 }
864 }
865 // create pointer to use as new freelist
866 lbm_uint addr = lbm_enc_cons_ptr(i);
867
868 // Clear the "freed" cell.
869 heap[i].car = ENC_SYM_RECOVERED(((0x28) << 4) | 0x00000000u);
870 heap[i].cdr = lbm_heap_state.freelist;
871 lbm_heap_state.freelist = addr;
872 lbm_heap_state.num_alloc --;
873 lbm_heap_state.gc_recovered ++;
874 }
875 }
876 return 1;
877}
878
879void lbm_gc_state_inc(void) {
880 lbm_heap_state.gc_num ++;
881 lbm_heap_state.gc_recovered = 0;
882 lbm_heap_state.gc_marked = 0;
883}
884
885// construct, alter and break apart
886lbm_value lbm_cons(lbm_value car, lbm_value cdr) {
887 return lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, car, cdr);
888}
889
890lbm_value lbm_car(lbm_value c){
891
892 if (lbm_is_ptr(c) ){
7
←
Taking false branch
→
893 lbm_cons_t *cell = lbm_ref_cell(c);
894 return cell->car;
895 }
896
897 if (lbm_type_of(c) == LBM_TYPE_SYMBOL0x00000000u &&
8
←
Assuming the condition is true
→
10
←
Taking true branch
→
898 c == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
9
←
Assuming the condition is true
→
899 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // if nil, return nil.
11
←
Returning zero
→
900 }
901
902 return ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u);
903}
904
905// TODO: Many comparisons "is this the nil symbol" can be
906// streamlined a bit. NIL is 0 and cannot be confused with any other
907// lbm_value.
908
909lbm_value lbm_caar(lbm_value c) {
910
911 lbm_value tmp;
912
913 if (lbm_is_ptr(c)) {
914 tmp = lbm_ref_cell(c)->car;
915
916 if (lbm_is_ptr(tmp)) {
917 return lbm_ref_cell(tmp)->car;
918 } else if (lbm_is_symbol(tmp) && tmp == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
919 return tmp;
920 }
921 } else if (lbm_is_symbol(c) && c == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
922 return c;
923 }
924 return ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u);
925}
926
927
928lbm_value lbm_cadr(lbm_value c) {
929
930 lbm_value tmp;
931
932 if (lbm_is_ptr(c)) {
933 tmp = lbm_ref_cell(c)->cdr;
934
935 if (lbm_is_ptr(tmp)) {
936 return lbm_ref_cell(tmp)->car;
937 } else if (lbm_is_symbol(tmp) && tmp == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
938 return tmp;
939 }
940 } else if (lbm_is_symbol(c) && c == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
941 return c;
942 }
943 return ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u);
944}
945
946lbm_value lbm_cdr(lbm_value c){
947
948 if (lbm_type_of(c) == LBM_TYPE_SYMBOL0x00000000u &&
949 c == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
950 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // if nil, return nil.
951 }
952
953 if (lbm_is_ptr(c)) {
954 lbm_cons_t *cell = lbm_ref_cell(c);
955 return cell->cdr;
956 }
957 return ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u);
958}
959
960lbm_value lbm_cddr(lbm_value c) {
961
962 if (lbm_is_ptr(c)) {
963 lbm_value tmp = lbm_ref_cell(c)->cdr;
964 if (lbm_is_ptr(tmp)) {
965 return lbm_ref_cell(tmp)->cdr;
966 }
967 }
968 if (lbm_is_symbol(c) && c == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
969 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
970 }
971 return ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u);
972}
973
974int lbm_set_car(lbm_value c, lbm_value v) {
975 int r = 0;
976
977 if (lbm_type_of(c) == LBM_TYPE_CONS0x10000000u) {
978 lbm_cons_t *cell = lbm_ref_cell(c);
979 cell->car = v;
980 r = 1;
981 }
982 return r;
983}
984
985int lbm_set_cdr(lbm_value c, lbm_value v) {
986 int r = 0;
987 if (lbm_is_cons_rw(c)){
988 lbm_cons_t *cell = lbm_ref_cell(c);
989 cell->cdr = v;
990 r = 1;
991 }
992 return r;
993}
994
995int lbm_set_car_and_cdr(lbm_value c, lbm_value car_val, lbm_value cdr_val) {
996 int r = 0;
997 if (lbm_is_cons_rw(c)) {
998 lbm_cons_t *cell = lbm_ref_cell(c);
999 cell->car = car_val;
1000 cell->cdr = cdr_val;
1001 r = 1;
1002 }
1003 return r;
1004}
1005
1006/* calculate length of a proper list */
1007lbm_uint lbm_list_length(lbm_value c) {
1008 lbm_uint len = 0;
1009
1010 while (lbm_is_cons(c)){
1011 len ++;
1012 c = lbm_cdr(c);
1013 }
1014 return len;
1015}
1016
1017/* calculate the length of a list and check that each element
1018 fullfills the predicate pred */
1019unsigned int lbm_list_length_pred(lbm_value c, bool_Bool *pres, bool_Bool (*pred)(lbm_value)) {
1020 bool_Bool res = true1;
1021 unsigned int len = 0;
1022
1023 while (lbm_is_cons(c)){
1024 len ++;
1025 res = res && pred(lbm_car(c));
1026 c = lbm_cdr(c);
1027 }
1028 *pres = res;
1029 return len;
1030}
1031
1032/* reverse a proper list */
1033lbm_value lbm_list_reverse(lbm_value list) {
1034 if (lbm_type_of(list) == LBM_TYPE_SYMBOL0x00000000u) {
1035 return list;
1036 }
1037
1038 lbm_value curr = list;
1039
1040 lbm_value new_list = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1041 while (lbm_is_cons(curr)) {
1042
1043 new_list = lbm_cons(lbm_car(curr), new_list);
1044 if (lbm_type_of(new_list) == LBM_TYPE_SYMBOL0x00000000u) {
1045 return ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u);
1046 }
1047 curr = lbm_cdr(curr);
1048 }
1049 return new_list;
1050}
1051
1052lbm_value lbm_list_destructive_reverse(lbm_value list) {
1053 if (lbm_type_of(list) == LBM_TYPE_SYMBOL0x00000000u) {
1054 return list;
1055 }
1056 lbm_value curr = list;
1057 lbm_value last_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1058
1059 while (lbm_is_cons_rw(curr)) {
1060 lbm_value next = lbm_cdr(curr);
1061 lbm_set_cdr(curr, last_cell);
1062 last_cell = curr;
1063 curr = next;
1064 }
1065 return last_cell;
1066}
1067
1068
1069lbm_value lbm_list_copy(int *m, lbm_value list) {
1070 lbm_value curr = list;
1071 lbm_uint n = lbm_list_length(list);
1072 lbm_uint copy_n = n;
1073 if (*m >= 0 && (lbm_uint)*m < n) {
1074 copy_n = (lbm_uint)*m;
1075 } else if (*m == -1) {
1076 *m = (int)n; // TODO: smaller range in target variable.
1077 }
1078 if (copy_n == 0) return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1079 lbm_uint new_list = lbm_heap_allocate_list(copy_n);
1080 if (lbm_is_symbol(new_list)) return new_list;
1081 lbm_value curr_targ = new_list;
1082
1083 while (lbm_is_cons(curr) && copy_n > 0) {
1084 lbm_value v = lbm_car(curr);
1085 lbm_set_car(curr_targ, v);
1086 curr_targ = lbm_cdr(curr_targ);
1087 curr = lbm_cdr(curr);
1088 copy_n --;
1089 }
1090
1091 return new_list;
1092}
1093
1094// Append for proper lists only
1095// Destructive update of list1.
1096lbm_value lbm_list_append(lbm_value list1, lbm_value list2) {
1097
1098 if(lbm_is_list_rw(list1) &&
1099 lbm_is_list(list2)) {
1100
1101 lbm_value curr = list1;
1102 while(lbm_type_of(lbm_cdr(curr)) == LBM_TYPE_CONS0x10000000u) {
1103 curr = lbm_cdr(curr);
1104 }
1105 if (lbm_is_symbol_nil(curr)) return list2;
1106 lbm_set_cdr(curr, list2);
1107 return list1;
1108 }
1109 return ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
1110}
1111
1112lbm_value lbm_list_drop(unsigned int n, lbm_value ls) {
1113 lbm_value curr = ls;
1114 while (lbm_type_of_functional(curr) == LBM_TYPE_CONS0x10000000u &&
1115 n > 0) {
1116 curr = lbm_cdr(curr);
1117 n --;
1118 }
1119 return curr;
1120}
1121
1122lbm_value lbm_index_list(lbm_value l, int32_t n) {
1123 lbm_value curr = l;
1124
1125 if (n < 0) {
1126 int32_t len = (int32_t)lbm_list_length(l);
1127 n = len + n;
1128 if (n < 0) return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1129 }
1130
1131 while (lbm_is_cons(curr) &&
1132 n > 0) {
1133 curr = lbm_cdr(curr);
1134 n --;
1135 }
1136 if (lbm_is_cons(curr)) {
1137 return lbm_car(curr);
1138 } else {
1139 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1140 }
1141}
1142
1143// High-level arrays are just bytearrays but with a different tag and pointer type.
1144// These arrays will be inspected by GC and the elements of the array will be marked.
1145
1146// Arrays are part of the heap module because their lifespan is managed
1147// by the garbage collector. The data in the array is not stored
1148// in the "heap of cons cells".
1149int lbm_heap_allocate_array_base(lbm_value *res, bool_Bool byte_array, lbm_uint size){
1150
1151 lbm_array_header_t *array = NULL((void*)0);
1152
1153 if (byte_array) {
1154 array = (lbm_array_header_t*)lbm_malloc(sizeof(lbm_array_header_t));
1155 } else {
1156 // an extra 32bit quantity for a GC index.
1157 array = (lbm_array_header_t*)lbm_malloc(sizeof(lbm_array_header_extended_t));
1158 }
1159
1160 if (array == NULL((void*)0)) {
1161 *res = ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u);
1162 return 0;
1163 }
1164
1165 lbm_uint tag = ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u);
1166 lbm_uint type = LBM_TYPE_ARRAY0x80000000u;
1167 if (!byte_array) {
1168 tag = ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u);
1169 type = LBM_TYPE_LISPARRAY0xB0000000u;
1170 size = sizeof(lbm_value) * size;
1171 lbm_array_header_extended_t *ext_array = (lbm_array_header_extended_t*)array;
1172 ext_array->index = 0;
1173 }
1174
1175 array->data = (lbm_uint*)lbm_malloc(size);
1176
1177 if (array->data == NULL((void*)0)) {
1178 lbm_memory_free((lbm_uint*)array);
1179 *res = ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u);
1180 return 0;
1181 }
1182 // It is more important to zero out high-level arrays.
1183 // 0 is symbol NIL which is perfectly safe for the GC to inspect.
1184 memset(array->data, 0, size);
1185 array->size = size;
1186
1187 // allocating a cell for array's heap-presence
1188 lbm_value cell = lbm_heap_allocate_cell(type, (lbm_uint) array, tag);
1189
1190 *res = cell;
1191
1192 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) { // Out of heap memory
1193 lbm_memory_free((lbm_uint*)array->data);
1194 lbm_memory_free((lbm_uint*)array);
1195 *res = ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u);
1196 return 0;
1197 }
1198
1199 lbm_heap_state.num_alloc_arrays ++;
1200
1201 return 1;
1202}
1203
1204int lbm_heap_allocate_array(lbm_value *res, lbm_uint size){
1205 return lbm_heap_allocate_array_base(res, true1, size);
1206}
1207
1208int lbm_heap_allocate_lisp_array(lbm_value *res, lbm_uint size) {
1209 return lbm_heap_allocate_array_base(res, false0, size);
1210}
1211
1212// Convert a C array into an lbm_array.
1213// if the array is in LBM_MEMORY, the lifetime will be managed by the GC after lifting.
1214int lbm_lift_array(lbm_value *value, char *data, lbm_uint num_elt) {
1215
1216 lbm_array_header_t *array = NULL((void*)0);
1217 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u));
1218
1219 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) { // Out of heap memory
1220 *value = cell;
1221 return 0;
1222 }
1223
1224 array = (lbm_array_header_t*)lbm_malloc(sizeof(lbm_array_header_t));
1225
1226 if (array == NULL((void*)0)) {
1227 lbm_set_car_and_cdr(cell, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1228 *value = ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u);
1229 return 0;
1230 }
1231
1232 array->data = (lbm_uint*)data;
1233 array->size = num_elt;
1234
1235 lbm_set_car(cell, (lbm_uint)array);
1236
1237 cell = lbm_set_ptr_type(cell, LBM_TYPE_ARRAY0x80000000u);
1238 *value = cell;
1239 return 1;
1240}
1241
1242lbm_int lbm_heap_array_get_size(lbm_value arr) {
1243
1244 lbm_int r = -1;
1245 if (lbm_is_array_r(arr)) {
1246 lbm_array_header_t *header = (lbm_array_header_t*)lbm_car(arr);
1247 if (header == NULL((void*)0)) {
1248 return r;
1249 }
1250 r = (lbm_int)header->size;
1251 }
1252 return r;
1253}
1254
1255const uint8_t *lbm_heap_array_get_data_ro(lbm_value arr) {
1256 uint8_t *r = NULL((void*)0);
1257 if (lbm_is_array_r(arr)) {
1258 lbm_array_header_t *header = (lbm_array_header_t*)lbm_car(arr);
1259 r = (uint8_t*)header->data;
1260 }
1261 return r;
1262}
1263
1264uint8_t *lbm_heap_array_get_data_rw(lbm_value arr) {
1265 uint8_t *r = NULL((void*)0);
1266 if (lbm_is_array_rw(arr)) {
1267 lbm_array_header_t *header = (lbm_array_header_t*)lbm_car(arr);
1268 r = (uint8_t*)header->data;
1269 }
1270 return r;
1271}
1272
1273
1274/* Explicitly freeing an array.
1275
1276 This is a highly unsafe operation and can only be safely
1277 used if the heap cell that points to the array has not been made
1278 accessible to the program.
1279
1280 So This function can be used to free an array in case an array
1281 is being constructed and some error case appears while doing so
1282 If the array still have not become available it can safely be
1283 "explicitly" freed.
1284
1285 The problem is that if the "array" heap-cell is made available to
1286 the program, this cell can easily be duplicated and we would have
1287 to search the entire heap to find all cells pointing to the array
1288 memory in question and "null"-them out before freeing the memory
1289*/
1290
1291int lbm_heap_explicit_free_array(lbm_value arr) {
1292
1293 int r = 0;
1294 if (lbm_is_array_rw(arr)) {
1295
1296 lbm_array_header_t *header = (lbm_array_header_t*)lbm_car(arr);
1297 if (header == NULL((void*)0)) {
1298 return 0;
1299 }
1300 lbm_memory_free((lbm_uint*)header->data);
1301 lbm_memory_free((lbm_uint*)header);
1302
1303 arr = lbm_set_ptr_type(arr, LBM_TYPE_CONS0x10000000u);
1304 lbm_set_car(arr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1305 lbm_set_cdr(arr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1306 r = 1;
1307 }
1308
1309 return r;
1310}
1311
1312lbm_uint lbm_size_of(lbm_type t) {
1313 lbm_uint s = 0;
1314 switch(t) {
1315 case LBM_TYPE_BYTE0x00000004u:
1316 s = 1;
1317 break;
1318 case LBM_TYPE_I0x00000008u: /* fall through */
1319 case LBM_TYPE_U0x0000000Cu:
1320 case LBM_TYPE_SYMBOL0x00000000u:
1321 s = sizeof(lbm_uint);
1322 break;
1323 case LBM_TYPE_I320x28000000u: /* fall through */
1324 case LBM_TYPE_U320x38000000u:
1325 case LBM_TYPE_FLOAT0x68000000u:
1326 s = 4;
1327 break;
1328 case LBM_TYPE_I640x48000000u: /* fall through */
1329 case LBM_TYPE_U640x58000000u:
1330 case LBM_TYPE_DOUBLE0x78000000u:
1331 s = 8;
1332 break;
1333 }
1334 return s;
1335}
1336
1337static bool_Bool dummy_flash_write(lbm_uint ix, lbm_uint val) {
1338 (void)ix;
1339 (void)val;
1340 return false0;
1341}
1342
1343static const_heap_write_fun const_heap_write = dummy_flash_write;
1344
1345int lbm_const_heap_init(const_heap_write_fun w_fun,
1346 lbm_const_heap_t *heap,
1347 lbm_uint *addr,
1348 lbm_uint num_words) {
1349 if (((uintptr_t)addr % 4) != 0) return 0;
1350 if ((num_words % 2) != 0) return 0;
1351
1352 if (!lbm_const_heap_mutex_initialized) {
1353 mutex_init(&lbm_const_heap_mutex);
1354 lbm_const_heap_mutex_initialized = true1;
1355 }
1356
1357 if (!lbm_mark_mutex_initialized) {
1358 mutex_init(&lbm_mark_mutex);
1359 lbm_mark_mutex_initialized = true1;
1360 }
1361
1362 const_heap_write = w_fun;
1363
1364 heap->heap = addr;
1365 heap->size = num_words;
1366 heap->next = 0;
1367
1368 lbm_const_heap_state = heap;
1369 // ref_cell views the lbm_uint array as an lbm_cons_t array
1370 lbm_heaps[1] = (lbm_cons_t*)addr;
1371 return 1;
1372}
1373
1374lbm_flash_status lbm_allocate_const_cell(lbm_value *res) {
1375 lbm_flash_status r = LBM_FLASH_FULL;
1376
1377 mutex_lock(&lbm_const_heap_mutex);
1378 // waste a cell if we have ended up unaligned after writing an array to flash.
1379 if (lbm_const_heap_state->next % 2 == 1) {
1380 lbm_const_heap_state->next++;
1381 }
1382
1383 if (lbm_const_heap_state &&
1384 (lbm_const_heap_state->next+1) < lbm_const_heap_state->size) {
1385 // A cons cell uses two words.
1386 lbm_value cell = lbm_const_heap_state->next;
1387 lbm_const_heap_state->next += 2;
1388 *res = (cell << LBM_ADDRESS_SHIFT2) | LBM_PTR_BIT0x00000001u | LBM_TYPE_CONS0x10000000u | LBM_PTR_TO_CONSTANT_BIT0x04000000u;
1389 r = LBM_FLASH_WRITE_OK;
1390 }
1391 mutex_unlock(&lbm_const_heap_mutex);
1392 return r;
1393}
1394
1395lbm_flash_status lbm_allocate_const_raw(lbm_uint nwords, lbm_uint *res) {
1396 lbm_flash_status r = LBM_FLASH_FULL;
1397
1398 if (lbm_const_heap_state &&
1399 (lbm_const_heap_state->next + nwords) < lbm_const_heap_state->size) {
1400 lbm_uint ix = lbm_const_heap_state->next;
1401 *res = (lbm_uint)&lbm_const_heap_state->heap[ix];
1402 lbm_const_heap_state->next += nwords;
1403 r = LBM_FLASH_WRITE_OK;
1404 }
1405 return r;
1406}
1407
1408lbm_flash_status lbm_write_const_raw(lbm_uint *data, lbm_uint n, lbm_uint *res) {
1409
1410 lbm_flash_status r = LBM_FLASH_FULL;
1411
1412 if (lbm_const_heap_state &&
1413 (lbm_const_heap_state->next + n) < lbm_const_heap_state->size) {
1414 lbm_uint ix = lbm_const_heap_state->next;
1415
1416 for (unsigned int i = 0; i < n; i ++) {
1417 if (!const_heap_write(ix + i, ((lbm_uint*)data)[i]))
1418 return LBM_FLASH_WRITE_ERROR;
1419 }
1420 lbm_const_heap_state->next += n;
1421 *res = (lbm_uint)&lbm_const_heap_state->heap[ix];
1422 r = LBM_FLASH_WRITE_OK;
1423 }
1424 return r;
1425}
1426
1427lbm_flash_status lbm_const_write(lbm_uint *tgt, lbm_uint val) {
1428
1429 if (lbm_const_heap_state) {
1430 lbm_uint flash = (lbm_uint)lbm_const_heap_state->heap;
1431 lbm_uint ix = (((lbm_uint)tgt - flash) / 4); // byte address to ix
1432 if (const_heap_write(ix, val)) {
1433 return LBM_FLASH_WRITE_OK;
1434 }
1435 return LBM_FLASH_WRITE_ERROR;
1436 }
1437 return LBM_FLASH_FULL;
1438}
1439
1440lbm_flash_status write_const_cdr(lbm_value cell, lbm_value val) {
1441 lbm_uint addr = lbm_dec_ptr(cell);
1442 if (const_heap_write(addr+1, val))
1443 return LBM_FLASH_WRITE_OK;
1444 return LBM_FLASH_WRITE_ERROR;
1445}
1446
1447lbm_flash_status write_const_car(lbm_value cell, lbm_value val) {
1448 lbm_uint addr = lbm_dec_ptr(cell);
1449 if (const_heap_write(addr, val))
1450 return LBM_FLASH_WRITE_OK;
1451 return LBM_FLASH_WRITE_ERROR;
1452}
1453
1454lbm_uint lbm_flash_memory_usage(void) {
1455 return lbm_const_heap_state->next;
1456}
+
+
←

./include/heap.h

+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1
2/*
3 Copyright 2018, 2024 Joel Svensson svenssonjoel@yahoo.se
4
5 This program is free software: you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation, either version 3 of the License, or
8 (at your option) any later version.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
14
15 You should have received a copy of the GNU General Public License
16 along with this program. If not, see <http://www.gnu.org/licenses/>.
17*/
18/** \file heap.h */
19
20#ifndef HEAP_H_
21#define HEAP_H_
22
23#include <string.h>
24#include <stdarg.h>
25
26#include "lbm_types.h"
27#include "symrepr.h"
28#include "stack.h"
29#include "lbm_memory.h"
30#include "lbm_defines.h"
31#include "lbm_channel.h"
32
33#ifdef __cplusplus
34extern "C" {
35#endif
36
37/*
38Planning for a more space efficient heap representation.
39TODO: Need to find a good reference to read up on this.
40 - List based heap
41 - Easy to implement and somewhat efficient
42
430000 0000 Size Free bits
44003F FFFF 4MB 10
45007F FFFF 8MB 9
4600FF FFFF 16MB 8
4701FF FFFF 32MB 7
4803FF FFFF 64MB 6 * Kind of heap size I am looking for
4907FF FFFF 128MB 5
500FFF FFFF 256MB 4
511FFF FFFF 512MB 3
52
53
54--- May 9 2021 ---
55Actually now I am much more interested in way smaller memories ;)
56
570000 0000 Size Free bits
580000 0FFF 4KB 20 |
590000 1FFF 8KB 19 |
600000 3FFF 16KB 18 |
610000 7FFF 32KB 17 |
620000 FFFF 64KB 16 |
630001 FFFF 128KB 15 |
640003 FFFF 256KB 14 | - This range is very interesting.
650007 FFFF 512KB 13
66000F FFFF 1MB 12
67001F FFFF 2MB 11
68003F FFFF 4MB 10
69007F FFFF 8MB 9
7000FF FFFF 16MB 8
7101FF FFFF 32MB 7
7203FF FFFF 64MB 6
7307FF FFFF 128MB 5
740FFF FFFF 256MB 4
751FFF FFFF 512MB 3
76
77Those are the kind of platforms that are fun... so a bunch of
78wasted bits in heap pointers if we run on small MCUs.
79
80-----------------
81
82it is also the case that not all addresses will be used if all "cells" are
83of the same size, 8 bytes...
84
85value 0: 0000 0000
86value 1: 0000 0008
87value 3: 0000 0010
88value 4: 0000 0018
89
90Means bits 0,1,2 will always be empty in a valid address.
91
92Cons cells also need to be have room for 2 pointers. So each ted cell from
93memory should be 8bytes.
94
95Things that needs to be represented within these bits:
96
97 - GC MARK one per cell
98 - TYPE: type of CAR and type of cons
99
100Types I would want:
101 - Full 32bit integer. Does not leave room for identification of type
102 - Float values. Same problem
103
104
105Free bits in pointers 64MB heap:
10631 30 29 28 27 26 2 1 0
1070 0 0 0 0 0 XX XXXX XXXX XXXX XXXX XXXX X 0 0 0
108
109
110Information needed for each cell:
111 Meaning | bits total | bits per car | bits per cdr
112 GC mark | 2 | 1 | 1 - only one of them will be used (the other is wasted)
113 Type | 2x | x | x
114 Ptr/!ptr | 2 | 1 | 1
115
116
117Types (unboxed):
118 - Symbols
119 - 28bit integer ( will need signed shift right functionality )
120 - 28bit unsigned integer
121 - Character
122
123If four types is all that should be possible (unboxed). then 2 bits are needed to differentiate.
1242 + 1 + 1 = 4 => 28bits for data.
125
126bit 0: ptr/!ptr
127bit 1: gc
128bit 2-3: type (if not ptr)
129bit 3 - 24 ptr (if ptr)
130bit 4 - 31 value (if value)
131
132An unboxed value can occupy a car or cdr field in a cons cell.
133
134types (boxed) extra information in pointer to cell can contain information
135 - 32 bit integer
136 - 32 bit unsigned integer
137 - 32 bit float
138
139boxed representation:
140 [ptr| cdr]
141 |
142 [Value | Aux + GC_MARK]
143
144Kinds of pointers:
145 - Pointer to cons cell.
146 - Pointer to unboxed value (fixnums not in a list, I hope this is so rare that it can be removed )
147 - integer
148 - unsigned integer
149 - symbol
150 - float
151 - Pointer to boxed value.
152 - 32 bit integer
153 - 32 bit unsigned integer
154 - 32 bit float
155 - (Maybe something else ? Vectors/strings allocated in memory not occupied by heap?)
156 - vector of int
157 - vector of uint
158 - vector of float
159 - vector of double
160 - String
161
16213 pointer"types" -> needs 4 bits
163for 64MB heap there are 6 free bits. So with this scheme going to 128MB or 256MB heap
164is also possible
165
166 a pointer to some off heap vector/string could be represented by
167
168 [ptr | cdr]
169 |
170 [full pointer | Aux + GC_MARK]
171 |
172 [VECTOR]
173
174Aux bits could be used for storing vector size. Up to 30bits should be available there
175>> This is problematic. Now the information that something is a vector is split up
176>> between 2 cons cells. This means GC needs both of these intact to be able to make
177>> proper decision.
178>> Will try to resolve this by adding some special symbols. But these must be symbols
179>> that cannot occur normally in programs. Then an array could be:
180
181 [Full pointer | ARRAY_SYM + GC_MARK]
182 |
183 [VECTOR]
184
185>> Boxed values same treatment as above.
186>> TODO: Could this be simpler?
187
188[ VALUE | TYPE_SYM + GC_MARK]
189
190
1910000 00XX XXXX XXXX XXXX XXXX XXXX X000 : 0x03FF FFF8
1921111 AA00 0000 0000 0000 0000 0000 0000 : 0xFC00 0000 (AA bits left unused for now, future heap growth?)
193 */
194
195typedef enum {
196 LBM_FLASH_WRITE_OK,
197 LBM_FLASH_FULL,
198 LBM_FLASH_WRITE_ERROR
199} lbm_flash_status;
200
201/** Struct representing a heap cons-cell.
202 *
203 */
204typedef struct {
205 lbm_value car;
206 lbm_value cdr;
207} lbm_cons_t;
208
209/**
210 * Heap state
211 */
212typedef struct {
213 lbm_cons_t *heap;
214 lbm_value freelist; // list of free cons cells.
215 lbm_stack_t gc_stack;
216
217 lbm_uint heap_size; // In number of cells.
218 lbm_uint heap_bytes; // In bytes.
219
220 lbm_uint num_alloc; // Number of cells allocated.
221 lbm_uint num_alloc_arrays; // Number of arrays allocated.
222
223 lbm_uint gc_num; // Number of times gc has been performed.
224 lbm_uint gc_marked; // Number of cells marked by mark phase.
225 lbm_uint gc_recovered; // Number of cells recovered by sweep phase.
226 lbm_uint gc_recovered_arrays;// Number of arrays recovered by sweep.
227 lbm_uint gc_least_free; // The smallest length of the freelist.
228 lbm_uint gc_last_free; // Number of elements on the freelist
229 // after most recent GC.
230} lbm_heap_state_t;
231
232extern lbm_heap_state_t lbm_heap_state;
233
234typedef bool_Bool (*const_heap_write_fun)(lbm_uint ix, lbm_uint w);
235
236typedef struct {
237 lbm_uint *heap;
238 lbm_uint next; // next free index.
239 lbm_uint size; // in lbm_uint words. (cons-cells = words / 2)
240} lbm_const_heap_t;
241
242/**
243 * The header portion of an array stored in array and symbol memory.
244 * An array is always a byte array. use the array-extensions for
245 * storing and reading larger values from arrays.
246 */
247typedef struct {
248 lbm_uint size; /// Number of elements
249 lbm_uint *data; /// pointer to lbm_memory array or C array.
250} lbm_array_header_t;
251
252typedef struct {
253 lbm_uint size;
254 lbm_uint *data;
255 uint32_t index; // Limits arrays to max 2^32-1 elements.
256} lbm_array_header_extended_t;
257
258/** Lock GC mutex
259 * Locks a mutex during GC marking when using the pointer reversal algorithm.
260 * Does nothing when using stack based GC mark.
261 */
262void lbm_gc_lock(void);
263/* Unlock GC mutex
264 */
265void lbm_gc_unlock(void);
266
267/** Initialize heap storage.
268 * \param addr Pointer to an array of lbm_cons_t elements. This array must at least be aligned 4.
269 * \param num_cells Number of lbm_cons_t elements in the array.
270 * \param gc_stack_size Size of the gc_stack in number of words.
271 * \return 1 on success or 0 for failure.
272 */
273int lbm_heap_init(lbm_cons_t *addr, lbm_uint num_cells,
274 lbm_uint gc_stack_size);
275
276/** Add GC time statistics to heap_stats
277 *
278 * \param dur Duration as reported by the timestamp callback.
279 */
280void lbm_heap_new_gc_time(lbm_uint dur);
281/** Add a new free_list length to the heap_stats.
282 * Calculates a new freelist length and updates
283 * the GC statistics.
284 */
285void lbm_heap_new_freelist_length(void);
286/** Check how many lbm_cons_t cells are on the free-list
287 *
288 * \return Number of free lbm_cons_t cells.
289 */
290lbm_uint lbm_heap_num_free(void);
291/** Check how many lbm_cons_t cells are allocated.
292 *
293 * \return Number of lbm_cons_t cells that are currently allocated.
294 */
295lbm_uint lbm_heap_num_allocated(void);
296/** Size of the heap in number of lbm_cons_t cells.
297 *
298 * \return Size of the heap in number of lbm_cons_t cells.
299 */
300lbm_uint lbm_heap_size(void);
301/** Size of the heap in bytes.
302 *
303 * \return Size of heap in bytes.
304 */
305lbm_uint lbm_heap_size_bytes(void);
306/** Allocate an lbm_cons_t cell from the heap.
307 *
308 * \param type A type that can be encoded onto the cell (most often LBM_PTR_TYPE_CONS).
309 * \param car Value to write into car position of allocated cell.
310 * \param cdr Value to write into cdr position of allocated cell.
311 * \return An lbm_value referring to a cons_cell or enc_sym(SYM_MERROR) in case the heap is full.
312 */
313lbm_value lbm_heap_allocate_cell(lbm_type type, lbm_value car, lbm_value cdr);
314/** Allocate a list of n heap-cells.
315 * \param n The number of heap-cells to allocate.
316 * \return A list of heap-cells of Memory error if unable to allocate.
317 */
318lbm_value lbm_heap_allocate_list(lbm_uint n);
319/** Allocate a list of n heap-cells and initialize the values.
320 * \pram ls The result list is passed through this ptr.
321 * \param n The length of list to allocate.
322 * \param valist The values in a va_list to initialize the list with.
323 * \return True of False depending on success of allocation.
324 */
325lbm_value lbm_heap_allocate_list_init_va(unsigned int n, va_list valist);
326/** Allocate a list of n heap-cells and initialize the values.
327 * \param n The length of list to allocate.
328 * \param ... The values to initialize the list with.
329 * \return allocated list or error symbol.
330 */
331lbm_value lbm_heap_allocate_list_init(unsigned int n, ...);
332/** Decode an lbm_value representing a string into a C string
333 *
334 * \param val Value
335 * \return allocated list or error symbol
336 */
337char *lbm_dec_str(lbm_value val);
338/** Decode an lbm_value representing a char channel into an lbm_char_channel_t pointer.
339 *
340 * \param val Value
341 * \return A pointer to an lbm_char_channel_t or NULL if the value does not encode a channel.
342 */
343lbm_char_channel_t *lbm_dec_channel(lbm_value val);
344/** Decode an lbm_value representing a custom type into a lbm_uint value.
345 *
346 * \param val Value.
347 * \return The custom type payload.
348 */
349lbm_uint lbm_dec_custom(lbm_value val);
350/** Decode a numerical value as if it is char
351 *
352 * \param val Value to decode
353 * \return The value encoded in val casted to a char. Returns 0 if val does not encode a number.
354 */
355uint8_t lbm_dec_as_char(lbm_value a);
356/** Decode a numerical value as if it is unsigned
357 *
358 * \param val Value to decode
359 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
360 */
361uint32_t lbm_dec_as_u32(lbm_value val);
362/** Decode a numerical value as a signed integer.
363 *
364 * \param val Value to decode
365 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
366 */
367int32_t lbm_dec_as_i32(lbm_value val);
368/** Decode a numerical value as a float.
369 *
370 * \param val Value to decode.
371 * \return The value encoded in val casted to a float. Returns 0 if val does not encode a number.
372 */
373float lbm_dec_as_float(lbm_value val);
374/** Decode a numerical value as if it is a 64bit unsigned
375 *
376 * \param val Value to decode
377 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
378 */
379uint64_t lbm_dec_as_u64(lbm_value val);
380/** Decode a numerical value as a 64bit signed integer.
381 *
382 * \param val Value to decode
383 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
384 */
385int64_t lbm_dec_as_i64(lbm_value val);
386/** Decode a numerical value as a float.
387 *
388 * \param val Value to decode.
389 * \return The value encoded in val casted to a float. Returns 0 if val does not encode a number.
390 */
391double lbm_dec_as_double(lbm_value val);
392
393/** Decode a numerical value into the architecture defined unsigned integer type.
394 *
395 * \param val Value to decode
396 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
397 */
398lbm_uint lbm_dec_as_uint(lbm_value val);
399
400/** Decode a numerical value into the architecture defined signed integer type.
401 *
402 * \param val Value to decode
403 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
404 */
405lbm_int lbm_dec_as_int(lbm_value val);
406
407lbm_uint lbm_dec_raw(lbm_value v);
408/** Allocates an lbm_cons_t cell from the heap and populates it.
409 *
410 * \param car The value to put in the car field of the allocated lbm_cons_t.
411 * \param cdr The value to put in the cdr field of the allocated lbm_cons_t.
412 * \return A value referencing the lbm_cons_t or enc_sym(SYM_MERROR) if heap is full.
413 */
414lbm_value lbm_cons(lbm_value car, lbm_value cdr);
415
416/** Accesses the car field of an lbm_cons_t.
417 *
418 * \param cons Value
419 * \return The car field of the lbm_cons_t if cons is a reference to a heap cell.
420 * If cons is nil, the return value is nil. If the value
421 * is not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
422 */
423lbm_value lbm_car(lbm_value cons);
424/** Accesses the car field the car field of an lbm_cons_t.
425 *
426 * \param cons Value
427 * \return The car of car field or nil.
428 */
429lbm_value lbm_caar(lbm_value c);
430/** Accesses the car of the cdr of an cons cell
431 *
432 * \param c Value
433 * \return the cdr field or type error.
434 */
435lbm_value lbm_cadr(lbm_value c);
436/** Accesses the cdr field of an lbm_cons_t.
437 *
438 * \param cons Value
439 * \return The cdr field of the lbm_cons_t if cons is a reference to a heap cell.
440 * If cons is nil, the return value is nil. If the value
441 * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
442 */
443lbm_value lbm_cdr(lbm_value cons);
444/** Accesses the cdr of an cdr field of an lbm_cons_t.
445 *
446 * \param cons Value
447 * \return The cdr of the cdr field of the lbm_cons_t if cons is a reference to a heap cell.
448 * If cons is nil, the return value is nil. If the value
449 * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
450 */
451lbm_value lbm_cddr(lbm_value c);
452/** Update the value stored in the car field of a heap cell.
453 *
454 * \param c Value referring to a heap cell.
455 * \param v Value to replace the car field with.
456 * \return 1 on success and 0 if the c value does not refer to a heap cell.
457 */
458int lbm_set_car(lbm_value c, lbm_value v);
459/** Update the value stored in the cdr field of a heap cell.
460 *
461 * \param c Value referring to a heap cell.
462 * \param v Value to replace the cdr field with.
463 * \return 1 on success and 0 if the c value does not refer to a heap cell.
464 */
465int lbm_set_cdr(lbm_value c, lbm_value v);
466/** Update the value stored in the car and cdr fields of a heap cell.
467 *
468 * \param c Value referring to a heap cell.
469 * \param car_val Value to replace the car field with.
470 * \param cdr_val Value to replace the cdr field with.
471 * \return 1 on success and 0 if the c value does not refer to a heap cell.
472 */
473int lbm_set_car_and_cdr(lbm_value c, lbm_value car_val, lbm_value cdr_val);
474// List functions
475/** Calculate the length of a proper list
476 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
477 * may lead to the function not terminating.
478 *
479 * \param c A list
480 * \return The length of the list. Unless the value is a cyclic structure on the heap, this function will terminate.
481 */
482lbm_uint lbm_list_length(lbm_value c);
483
484/** Calculate the length of a proper list and evaluate a predicate for each element.
485 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
486 * may lead to the function not terminating.
487 *
488 * \param c A list
489 * \param pres Boolean result of predicate, false if predicate is false for any of the elements in the list, otherwise true.
490 * \param pred Predicate to evaluate for each element of the list.
491 */
492unsigned int lbm_list_length_pred(lbm_value c, bool_Bool *pres, bool_Bool (*pred)(lbm_value));
493/** Reverse a proper list
494 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
495 * may lead to the function not terminating.
496 *
497 * \param list A list
498 * \return The list reversed or enc_sym(SYM_MERROR) if heap is full.
499 */
500lbm_value lbm_list_reverse(lbm_value list);
501/** Reverse a proper list destroying the original.
502 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
503 * may lead to the function not terminating.
504 *
505 * \param list A list
506 * \return The list reversed
507 */
508lbm_value lbm_list_destructive_reverse(lbm_value list);
509/** Copy a list
510 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
511 * may lead to the function not terminating.
512 *
513 * \param m Number of elements to copy or -1 for all. If 1, m will be updated with the length of the list
514 * \param list A list.
515 * \return Reversed list or enc_sym(SYM_MERROR) if heap is full.
516 */
517lbm_value lbm_list_copy(int *m, lbm_value list);
518
519/** A destructive append of two lists
520 *
521 * \param list1 A list
522 * \param list2 A list
523 * \return list1 with list2 appended at the end.
524 */
525lbm_value lbm_list_append(lbm_value list1, lbm_value list2);
526
527/** Drop values from the head of a list.
528 * \param n Number of values to drop.
529 * \param ls List to drop values from.
530 * \return The list with the n first elements removed.
531 */
532lbm_value lbm_list_drop(unsigned int n, lbm_value ls);
533/** Index into a list.
534 * \param l List to index into.
535 * \param n Position to read out of the list.
536 * \return Value at position n of l or nil if out of bounds.
537 */
538lbm_value lbm_index_list(lbm_value l, int32_t n);
539
540// State and statistics
541/** Get a copy of the heap statistics structure.
542 *
543 * \param A pointer to an lbm_heap_state_t to populate
544 * with the current statistics.
545 */
546void lbm_get_heap_state(lbm_heap_state_t *);
547/** Get the maximum stack level of the GC stack
548 * \return maximum value the gc stack sp reached so far.
549 */
550lbm_uint lbm_get_gc_stack_max(void);
551/** Get the size of the GC stack.
552 * \return the size of the gc stack.
553 */
554lbm_uint lbm_get_gc_stack_size(void);
555// Garbage collection
556/** Increment the counter that is counting the number of times GC ran
557 *
558 */
559void lbm_gc_state_inc(void);
560/** Set the freelist to NIL. Means that no memory will be available
561 * until after a garbage collection.
562 */
563void lbm_nil_freelist(void);
564/** Mark all heap cells reachable from an environment.
565 * \param environment.
566 */
567void lbm_gc_mark_env(lbm_value);
568/** Mark heap cells reachable from the lbm_value v.
569 * \param root
570 */
571void lbm_gc_mark_phase(lbm_value root);
572/** Performs lbm_gc_mark_phase on all the values of an array.
573 * This function is similar to lbm_gc_mark_roots but performs
574 * extra checks to not traverse into non-standard values.
575 * TODO: Check if this function is really needed.
576 * \param data Array of roots to traverse from.
577 * \param n Number of elements in roots-array.
578 */
579void lbm_gc_mark_aux(lbm_uint *data, lbm_uint n);
580/** Performs lbm_gc_mark_phase on all the values in the roots array.
581 * \param roots pointer to array of roots.
582 * \param num_roots size of array of roots.
583 */
584void lbm_gc_mark_roots(lbm_uint *roots, lbm_uint num_roots);
585/** Sweep up all non marked heap cells and place them on the free list.
586 *
587 * \return 1
588 */
589int lbm_gc_sweep_phase(void);
590
591// Array functionality
592/** Allocate an bytearray in symbols and arrays memory (lispbm_memory.h)
593 * and create a heap cell that refers to this bytearray.
594 * \param res The resulting lbm_value is returned through this argument.
595 * \param size Array size in number of 32 bit words.
596 * \return 1 for success of 0 for failure.
597 */
598int lbm_heap_allocate_array(lbm_value *res, lbm_uint size);
599/** Allocate an array in symbols and arrays memory (lispbm_memory.h)
600 * and create a heap cell that refers to this array.
601 * \param res The resulting lbm_value is returned through this argument.
602 * \param size Array size in number of 32 bit words.
603 * \return 1 for success of 0 for failure.
604 */
605int lbm_heap_allocate_lisp_array(lbm_value *res, lbm_uint size);
606/** Convert a C array into an lbm array. If the C array is allocated in LBM MEMORY
607 * the lifetime of the array will be managed by GC.
608 * \param res lbm_value result pointer for storage of the result array.
609 * \param data C array.
610 * \param type The type tag to assign to the resulting LBM array.
611 * \param num_elt Number of elements in the array.
612 * \return 1 for success and 0 for failure.
613 */
614int lbm_lift_array(lbm_value *value, char *data, lbm_uint num_elt);
615/** Get the size of an array value.
616 * \param arr lbm_value array to get size of.
617 * \return -1 for failure or length of array.
618 */
619lbm_int lbm_heap_array_get_size(lbm_value arr);
620/** Get a pointer to the data of an array for read only purposes.
621 * \param arr lbm_value array to get pointer from.
622 * \return NULL or valid pointer.
623 */
624const uint8_t *lbm_heap_array_get_data_ro(lbm_value arr);
625/** Get a pointer to the data of an array for read/write purposes.
626 * \param arr lbm_value array to get pointer from.
627 * \return NULL or valid pointer.
628 */
629uint8_t *lbm_heap_array_get_data_rw(lbm_value arr);
630/** Explicitly free an array.
631 * This function needs to be used with care and knowledge.
632 * \param arr Array value.
633 */
634int lbm_heap_explicit_free_array(lbm_value arr);
635/** Query the size in bytes of an lbm_type.
636 * \param t Type
637 * \return Size in bytes of type or 0 if the type represents a composite.
638 */
639lbm_uint lbm_size_of(lbm_type t);
640
641int lbm_const_heap_init(const_heap_write_fun w_fun,
642 lbm_const_heap_t *heap,
643 lbm_uint *addr,
644 lbm_uint num_words);
645
646lbm_flash_status lbm_allocate_const_cell(lbm_value *res);
647lbm_flash_status lbm_write_const_raw(lbm_uint *data, lbm_uint n, lbm_uint *res);
648lbm_flash_status lbm_allocate_const_raw(lbm_uint nwords, lbm_uint *res);
649lbm_flash_status write_const_cdr(lbm_value cell, lbm_value val);
650lbm_flash_status write_const_car(lbm_value cell, lbm_value val);
651lbm_flash_status lbm_const_write(lbm_uint *tgt, lbm_uint val);
652lbm_uint lbm_flash_memory_usage(void);
653
654/** Query the type information of a value.
655 *
656 * \param x Value to check the type of.
657 * \return The type information.
658 */
659static inline lbm_type lbm_type_of(lbm_value x) {
660 return (x & LBM_PTR_BIT0x00000001u) ? (x & LBM_PTR_TYPE_MASK0xFC000000u) : (x & LBM_VAL_TYPE_MASK0x0000000Cu);
661}
662
663// type-of check that is safe in functional code
664static inline lbm_type lbm_type_of_functional(lbm_value x) {
665 return (x & LBM_PTR_BIT0x00000001u) ?
666 (x & (LBM_PTR_TO_CONSTANT_MASK~0x04000000u & LBM_PTR_TYPE_MASK0xFC000000u)) :
667 (x & LBM_VAL_TYPE_MASK0x0000000Cu);
668}
669
670static inline lbm_value lbm_enc_cons_ptr(lbm_uint x) {
671 return ((x << LBM_ADDRESS_SHIFT2) | LBM_TYPE_CONS0x10000000u | LBM_PTR_BIT0x00000001u);
672}
673
674static inline lbm_uint lbm_dec_ptr(lbm_value p) {
675 return ((LBM_PTR_VAL_MASK0x03FFFFFCu & p) >> LBM_ADDRESS_SHIFT2);
676}
677
678extern lbm_cons_t *lbm_heaps[2];
679
680static inline lbm_uint lbm_dec_cons_cell_ptr(lbm_value p) {
681 lbm_uint h = (p & LBM_PTR_TO_CONSTANT_BIT0x04000000u) >> LBM_PTR_TO_CONSTANT_SHIFT26;
682 return lbm_dec_ptr(p) >> h;
683}
684
685static inline lbm_cons_t *lbm_dec_heap(lbm_value p) {
686 lbm_uint h = (p & LBM_PTR_TO_CONSTANT_BIT0x04000000u) >> LBM_PTR_TO_CONSTANT_SHIFT26;
687 return lbm_heaps[h];
688}
689
690static inline lbm_value lbm_set_ptr_type(lbm_value p, lbm_type t) {
691 return ((LBM_PTR_VAL_MASK0x03FFFFFCu & p) | t | LBM_PTR_BIT0x00000001u);
692}
693
694static inline lbm_value lbm_enc_sym(lbm_uint s) {
695 return (s << LBM_VAL_SHIFT4) | LBM_TYPE_SYMBOL0x00000000u;
696}
697
698static inline lbm_value lbm_enc_i(lbm_int x) {
699 return ((lbm_uint)x << LBM_VAL_SHIFT4) | LBM_TYPE_I0x00000008u;
700}
701
702static inline lbm_value lbm_enc_u(lbm_uint x) {
703 return (x << LBM_VAL_SHIFT4) | LBM_TYPE_U0x0000000Cu;
704}
705
706/** Encode 32 bit integer into an lbm_value.
707 * \param x Value to encode.
708 * \return result encoded value.
709 */
710extern lbm_value lbm_enc_i32(int32_t x);
711
712/** Encode 32 bit unsigned integer into an lbm_value.
713 * \param x Value to encode.
714 * \return result encoded value.
715 */
716extern lbm_value lbm_enc_u32(uint32_t x);
717
718/** Encode a float into an lbm_value.
719 * \param x float value to encode.
720 * \return result encoded value.
721 */
722extern lbm_value lbm_enc_float(float x);
723
724/** Encode a 64 bit integer into an lbm_value.
725 * \param x 64 bit integer to encode.
726 * \return result encoded value.
727 */
728extern lbm_value lbm_enc_i64(int64_t x);
729
730/** Encode a 64 bit unsigned integer into an lbm_value.
731 * \param x 64 bit unsigned integer to encode.
732 * \return result encoded value.
733 */
734extern lbm_value lbm_enc_u64(uint64_t x);
735
736/** Encode a double into an lbm_value.
737 * \param x double to encode.
738 * \return result encoded value.
739 */
740extern lbm_value lbm_enc_double(double x);
741
742static inline lbm_value lbm_enc_char(uint8_t x) {
743 return ((lbm_uint)x << LBM_VAL_SHIFT4) | LBM_TYPE_CHAR0x00000004u;
744}
745
746static inline lbm_int lbm_dec_i(lbm_value x) {
747 return (lbm_int)x >> LBM_VAL_SHIFT4;
748}
749
750static inline lbm_uint lbm_dec_u(lbm_value x) {
751 return x >> LBM_VAL_SHIFT4;
752}
753
754static inline uint8_t lbm_dec_char(lbm_value x) {
755 return (uint8_t)(x >> LBM_VAL_SHIFT4);
756}
757
758static inline lbm_uint lbm_dec_sym(lbm_value x) {
759 return x >> LBM_VAL_SHIFT4;
760}
761
762/** Decode an lbm_value representing a float.
763 * \param x Value to decode.
764 * \return decoded float.
765 */
766extern float lbm_dec_float(lbm_value x);
767
768/** Decode an lbm_value representing a double.
769 * \param x Value to decode.
770 * \return decoded float.
771 */
772extern double lbm_dec_double(lbm_value x);
773
774
775static inline uint32_t lbm_dec_u32(lbm_value x) {
776#ifndef LBM64
777 return (uint32_t)lbm_car(x);
778#else
779 return (uint32_t)(x >> LBM_VAL_SHIFT4);
780#endif
781}
782
783/** Decode an lbm_value representing a 64 bit unsigned integer.
784 * \param x Value to decode.
785 * \return decoded uint64_t.
786 */
787extern uint64_t lbm_dec_u64(lbm_value x);
788
789static inline int32_t lbm_dec_i32(lbm_value x) {
790#ifndef LBM64
791 return (int32_t)lbm_car(x);
792#else
793 return (int32_t)(x >> LBM_VAL_SHIFT4);
794#endif
795}
796
797/** Decode an lbm_value representing a 64 bit integer.
798 * \param x Value to decode.
799 * \return decoded int64_t.
800 */
801extern int64_t lbm_dec_i64(lbm_value x);
802
803/**
804 * Check if a value is a heap pointer
805 * \param x Value to check
806 * \return true if x is a pointer to a heap cell, false otherwise.
807 */
808static inline bool_Bool lbm_is_ptr(lbm_value x) {
809 return (x & LBM_PTR_BIT0x00000001u);
810}
811
812/**
813 * Check if a value is a Read/Writeable cons cell
814 * \param x Value to check
815 * \return true if x is a Read/Writeable cons cell, false otherwise.
816 */
817static inline bool_Bool lbm_is_cons_rw(lbm_value x) {
818 return (lbm_type_of(x) == LBM_TYPE_CONS0x10000000u);
819}
820
821/**
822 * Check if a value is a Readable cons cell
823 * \param x Value to check
824 * \return true if x is a readable cons cell, false otherwise.
825 */
826static inline bool_Bool lbm_is_cons(lbm_value x) {
827 return lbm_is_ptr(x) && ((x & LBM_CONS_TYPE_MASK0xF0000000u) == LBM_TYPE_CONS0x10000000u);
828}
829
830/** Check if a value represents a number
831 * \param x Value to check.
832 * \return true is x represents a number and false otherwise.
833 */
834static inline bool_Bool lbm_is_number(lbm_value x) {
835 return
836 (x & LBM_PTR_BIT0x00000001u) ?
837 ((x & LBM_NUMBER_MASK0x08000000u) == LBM_NUMBER_MASK0x08000000u) :
838 (x & LBM_VAL_TYPE_MASK0x0000000Cu);
839}
840
841/** Check if value is an array that can be READ
842 * \param x Value to check.
843 * \return true if x represents a readable array and false otherwise.
844 */
845static inline bool_Bool lbm_is_array_r(lbm_value x) {
846 lbm_type t = lbm_type_of(x);
847 return ((t & LBM_PTR_TO_CONSTANT_MASK~0x04000000u) == LBM_TYPE_ARRAY0x80000000u);
2
←
Assuming the condition is true
→
3
←
Returning the value 1, which participates in a condition later
→
848}
849
850static inline bool_Bool lbm_is_array_rw(lbm_value x) {
851 return( (lbm_type_of(x) == LBM_TYPE_ARRAY0x80000000u) && !(x & LBM_PTR_TO_CONSTANT_BIT0x04000000u));
852}
853
854static inline bool_Bool lbm_is_lisp_array_r(lbm_value x) {
855 lbm_type t = lbm_type_of(x);
856 return ((t & LBM_PTR_TO_CONSTANT_MASK~0x04000000u) == LBM_TYPE_LISPARRAY0xB0000000u);
857}
858
859static inline bool_Bool lbm_is_lisp_array_rw(lbm_value x) {
860 return( (lbm_type_of(x) == LBM_TYPE_LISPARRAY0xB0000000u) && !(x & LBM_PTR_TO_CONSTANT_BIT0x04000000u));
861}
862
863
864static inline bool_Bool lbm_is_channel(lbm_value x) {
865 return (lbm_type_of(x) == LBM_TYPE_CHANNEL0x90000000u &&
866 lbm_type_of(lbm_cdr(x)) == LBM_TYPE_SYMBOL0x00000000u &&
867 lbm_cdr(x) == ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
868}
869static inline bool_Bool lbm_is_char(lbm_value x) {
870 return (lbm_type_of(x) == LBM_TYPE_CHAR0x00000004u);
871}
872
873static inline bool_Bool lbm_is_special(lbm_value symrep) {
874 return ((lbm_type_of(symrep) == LBM_TYPE_SYMBOL0x00000000u) &&
875 (lbm_dec_sym(symrep) < SPECIAL_SYMBOLS_END0xFFFF));
876}
877
878static inline bool_Bool lbm_is_closure(lbm_value exp) {
879 return ((lbm_is_cons(exp)) &&
880 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
881 (lbm_car(exp) == ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u)));
882}
883
884static inline bool_Bool lbm_is_continuation(lbm_value exp) {
885 return ((lbm_type_of(exp) == LBM_TYPE_CONS0x10000000u) &&
886 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
887 (lbm_car(exp) == ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u)));
888}
889
890static inline bool_Bool lbm_is_macro(lbm_value exp) {
891 return ((lbm_type_of(exp) == LBM_TYPE_CONS0x10000000u) &&
892 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
893 (lbm_car(exp) == ENC_SYM_MACRO(((0x10D) << 4) | 0x00000000u)));
894}
895
896static inline bool_Bool lbm_is_match_binder(lbm_value exp) {
897 return (lbm_is_cons(exp) &&
898 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
899 (lbm_car(exp) == ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u)));
900}
901
902static inline bool_Bool lbm_is_comma_qualified_symbol(lbm_value exp) {
903 return (lbm_is_cons(exp) &&
904 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
905 (lbm_car(exp) == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) &&
906 (lbm_type_of(lbm_cadr(exp)) == LBM_TYPE_SYMBOL0x00000000u));
907}
908
909static inline bool_Bool lbm_is_symbol(lbm_value exp) {
910 return !(exp & LBM_LOW_RESERVED_BITS0x0000000Fu);
911}
912
913static inline bool_Bool lbm_is_symbol_nil(lbm_value exp) {
914 return !exp;
915}
916
917static inline bool_Bool lbm_is_symbol_true(lbm_value exp) {
918 return (lbm_is_symbol(exp) && exp == ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u));
919}
920
921static inline bool_Bool lbm_is_symbol_eval(lbm_value exp) {
922 return (lbm_is_symbol(exp) && exp == ENC_SYM_EVAL(((0x30008) << 4) | 0x00000000u));
923}
924
925static inline bool_Bool lbm_is_symbol_merror(lbm_value exp) {
926 return lbm_is_symbol(exp) && (exp == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
927}
928
929static inline bool_Bool lbm_is_list(lbm_value x) {
930 return (lbm_is_cons(x) || lbm_is_symbol_nil(x));
931}
932
933static inline bool_Bool lbm_is_list_rw(lbm_value x) {
934 return (lbm_is_cons_rw(x) || lbm_is_symbol_nil(x));
935}
936
937static inline bool_Bool lbm_is_quoted_list(lbm_value x) {
938 return (lbm_is_cons(x) &&
939 lbm_is_symbol(lbm_car(x)) &&
940 (lbm_car(x) == ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u)) &&
941 lbm_is_cons(lbm_cdr(x)) &&
942 lbm_is_cons(lbm_cadr(x)));
943}
944
945#ifndef LBM64
946#define ERROR_SYMBOL_MASK0xFFFFFFF0 0xFFFFFFF0
947#else
948#define ERROR_SYMBOL_MASK0xFFFFFFF0 0xFFFFFFFFFFFFFFF0
949#endif
950
951/* all error signaling symbols are in the range 0x20 - 0x2F */
952static inline bool_Bool lbm_is_error(lbm_value v){
953 return (lbm_is_symbol(v) &&
954 ((lbm_dec_sym(v) & ERROR_SYMBOL_MASK0xFFFFFFF0) == 0x20));
955}
956
957// ref_cell: returns a reference to the cell addressed by bits 3 - 26
958// Assumes user has checked that is_ptr was set
959static inline lbm_cons_t* lbm_ref_cell(lbm_value addr) {
960 return &lbm_dec_heap(addr)[lbm_dec_cons_cell_ptr(addr)];
961 //return &lbm_heap_state.heap[lbm_dec_ptr(addr)];
962}
963
964
965// lbm_uint a = lbm_heaps[0];
966// lbm_uint b = lbm_heaps[1];
967// lbm_uint i = (addr & LBM_PTR_TO_CONSTANT_BIT) >> LBM_PTR_TO_CONSTANT_SHIFT) - 1;
968// lbm_uint h = (a & i) | (b & ~i);
969
970#ifdef __cplusplus
971}
972#endif
973#endif
diff --git a/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-e1a01d.html b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-e1a01d.html new file mode 100644 index 00000000..0d157684 --- /dev/null +++ b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-e1a01d.html @@ -0,0 +1,6534 @@ + + + +src/eval_cps.c + + + + + + + + + + + + + + + + + + + + + + + + + + +

Bug Summary

+ + + + +
File:eval_cps.c
Warning:line 4412, column 7
1st function call argument is an uninitialized value
+ +

Annotated Source Code

+

Press '?' + to see keyboard shortcuts

+ + +
clang -cc1 -triple i386-pc-linux-gnu -analyze -disable-free -disable-llvm-verifier -discard-value-names -main-file-name eval_cps.c -analyzer-store=region -analyzer-opt-analyze-nested-blocks -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -mrelocation-model static -mthread-model posix -mframe-pointer=none -fmath-errno -fno-rounding-math -masm-verbose -mconstructor-aliases -target-cpu i686 -dwarf-column-info -fno-split-dwarf-inlining -debugger-tuning=gdb -resource-dir /usr/lib/llvm-10/lib/clang/10.0.0 -I ./include -I ./include/extensions -I platform/linux/include -D _PRELUDE -internal-isystem /usr/local/include -internal-isystem /usr/lib/llvm-10/lib/clang/10.0.0/include -internal-externc-isystem /usr/include/i386-linux-gnu -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -std=c99 -fdebug-compilation-dir /home/joels/Current/lispbm -ferror-limit 19 -fmessage-length 0 -fgnuc-version=4.2.1 -fobjc-runtime=gcc -fdiagnostics-show-option -vectorize-loops -vectorize-slp -analyzer-output=html -faddrsig -o /home/joels/Current/lispbm/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1 -x c src/eval_cps.c +
+ + + +
+ + +
+ + + + +
+

src/eval_cps.c

+
→
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1/*
2 Copyright 2018, 2020 - 2024 Joel Svensson svenssonjoel@yahoo.se
3
4 This program is free software: you can redistribute it and/or modify
5 it under the terms of the GNU General Public License as published by
6 the Free Software Foundation, either version 3 of the License, or
7 (at your option) any later version.
8
9 This program is distributed in the hope that it will be useful,
10 but WITHOUT ANY WARRANTY; without even the implied warranty of
11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 GNU General Public License for more details.
13
14 You should have received a copy of the GNU General Public License
15 along with this program. If not, see <http://www.gnu.org/licenses/>.
16*/
17
18#include <lbm_memory.h>
19#include <lbm_types.h>
20#include "symrepr.h"
21#include "heap.h"
22#include "env.h"
23#include "eval_cps.h"
24#include "stack.h"
25#include "fundamental.h"
26#include "extensions.h"
27#include "tokpar.h"
28#include "lbm_channel.h"
29#include "print.h"
30#include "platform_mutex.h"
31#include "lbm_flat_value.h"
32#include "lbm_flags.h"
33
34#ifdef VISUALIZE_HEAP
35#include "heap_vis.h"
36#endif
37
38#include <setjmp.h>
39#include <stdarg.h>
40
41static jmp_buf error_jmp_buf;
42static jmp_buf critical_error_jmp_buf;
43
44#define S_TO_US(X)(lbm_uint)((X) * 1000000) (lbm_uint)((X) * 1000000)
45
46#define DEC_CONTINUATION(x)(((x) & ~0xF8000001u) >> 2) (((x) & ~LBM_CONTINUATION_INTERNAL0xF8000001u) >> LBM_ADDRESS_SHIFT2)
47#define IS_CONTINUATION(x)(((x) & 0xF8000001u) == 0xF8000001u) (((x) & LBM_CONTINUATION_INTERNAL0xF8000001u) == LBM_CONTINUATION_INTERNAL0xF8000001u)
48#define CONTINUATION(x)(((x) << 2) | 0xF8000001u) (((x) << LBM_ADDRESS_SHIFT2) | LBM_CONTINUATION_INTERNAL0xF8000001u)
49
50#define DONE(((0) << 2) | 0xF8000001u) CONTINUATION(0)(((0) << 2) | 0xF8000001u)
51#define SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u) CONTINUATION(1)(((1) << 2) | 0xF8000001u)
52#define BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u) CONTINUATION(2)(((2) << 2) | 0xF8000001u)
53#define IF(((3) << 2) | 0xF8000001u) CONTINUATION(3)(((3) << 2) | 0xF8000001u)
54#define PROGN_REST(((4) << 2) | 0xF8000001u) CONTINUATION(4)(((4) << 2) | 0xF8000001u)
55#define APPLICATION_ARGS(((5) << 2) | 0xF8000001u) CONTINUATION(5)(((5) << 2) | 0xF8000001u)
56#define AND(((6) << 2) | 0xF8000001u) CONTINUATION(6)(((6) << 2) | 0xF8000001u)
57#define OR(((7) << 2) | 0xF8000001u) CONTINUATION(7)(((7) << 2) | 0xF8000001u)
58#define WAIT(((8) << 2) | 0xF8000001u) CONTINUATION(8)(((8) << 2) | 0xF8000001u)
59#define MATCH(((9) << 2) | 0xF8000001u) CONTINUATION(9)(((9) << 2) | 0xF8000001u)
60#define APPLICATION_START(((10) << 2) | 0xF8000001u) CONTINUATION(10)(((10) << 2) | 0xF8000001u)
61#define EVAL_R(((11) << 2) | 0xF8000001u) CONTINUATION(11)(((11) << 2) | 0xF8000001u)
62#define RESUME(((12) << 2) | 0xF8000001u) CONTINUATION(12)(((12) << 2) | 0xF8000001u)
63#define CLOSURE_ARGS(((13) << 2) | 0xF8000001u) CONTINUATION(13)(((13) << 2) | 0xF8000001u)
64#define EXIT_ATOMIC(((14) << 2) | 0xF8000001u) CONTINUATION(14)(((14) << 2) | 0xF8000001u)
65#define READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u) CONTINUATION(15)(((15) << 2) | 0xF8000001u)
66#define READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u) CONTINUATION(16)(((16) << 2) | 0xF8000001u)
67#define READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u) CONTINUATION(17)(((17) << 2) | 0xF8000001u)
68#define READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u) CONTINUATION(18)(((18) << 2) | 0xF8000001u)
69#define READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u) CONTINUATION(19)(((19) << 2) | 0xF8000001u)
70#define READ_DONE(((20) << 2) | 0xF8000001u) CONTINUATION(20)(((20) << 2) | 0xF8000001u)
71#define READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u) CONTINUATION(21)(((21) << 2) | 0xF8000001u)
72#define READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u) CONTINUATION(22)(((22) << 2) | 0xF8000001u)
73#define READ_COMMA_RESULT(((23) << 2) | 0xF8000001u) CONTINUATION(23)(((23) << 2) | 0xF8000001u)
74#define READ_START_ARRAY(((24) << 2) | 0xF8000001u) CONTINUATION(24)(((24) << 2) | 0xF8000001u)
75#define READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u) CONTINUATION(25)(((25) << 2) | 0xF8000001u)
76#define MAP(((26) << 2) | 0xF8000001u) CONTINUATION(26)(((26) << 2) | 0xF8000001u)
77#define MATCH_GUARD(((27) << 2) | 0xF8000001u) CONTINUATION(27)(((27) << 2) | 0xF8000001u)
78#define TERMINATE(((28) << 2) | 0xF8000001u) CONTINUATION(28)(((28) << 2) | 0xF8000001u)
79#define PROGN_VAR(((29) << 2) | 0xF8000001u) CONTINUATION(29)(((29) << 2) | 0xF8000001u)
80#define SETQ(((30) << 2) | 0xF8000001u) CONTINUATION(30)(((30) << 2) | 0xF8000001u)
81#define MOVE_TO_FLASH(((31) << 2) | 0xF8000001u) CONTINUATION(31)(((31) << 2) | 0xF8000001u)
82#define MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u) CONTINUATION(32)(((32) << 2) | 0xF8000001u)
83#define MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u) CONTINUATION(33)(((33) << 2) | 0xF8000001u)
84#define CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u) CONTINUATION(34)(((34) << 2) | 0xF8000001u)
85#define QQ_EXPAND_START(((35) << 2) | 0xF8000001u) CONTINUATION(35)(((35) << 2) | 0xF8000001u)
86#define QQ_EXPAND(((36) << 2) | 0xF8000001u) CONTINUATION(36)(((36) << 2) | 0xF8000001u)
87#define QQ_APPEND(((37) << 2) | 0xF8000001u) CONTINUATION(37)(((37) << 2) | 0xF8000001u)
88#define QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u) CONTINUATION(38)(((38) << 2) | 0xF8000001u)
89#define QQ_LIST(((39) << 2) | 0xF8000001u) CONTINUATION(39)(((39) << 2) | 0xF8000001u)
90#define KILL(((40) << 2) | 0xF8000001u) CONTINUATION(40)(((40) << 2) | 0xF8000001u)
91#define LOOP(((41) << 2) | 0xF8000001u) CONTINUATION(41)(((41) << 2) | 0xF8000001u)
92#define LOOP_CONDITION(((42) << 2) | 0xF8000001u) CONTINUATION(42)(((42) << 2) | 0xF8000001u)
93#define MERGE_REST(((43) << 2) | 0xF8000001u) CONTINUATION(43)(((43) << 2) | 0xF8000001u)
94#define MERGE_LAYER(((44) << 2) | 0xF8000001u) CONTINUATION(44)(((44) << 2) | 0xF8000001u)
95#define CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u) CONTINUATION(45)(((45) << 2) | 0xF8000001u)
96#define MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u) CONTINUATION(46)(((46) << 2) | 0xF8000001u)
97#define POP_READER_FLAGS(((47) << 2) | 0xF8000001u) CONTINUATION(47)(((47) << 2) | 0xF8000001u)
98#define EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u) CONTINUATION(48)(((48) << 2) | 0xF8000001u)
99#define NUM_CONTINUATIONS49 49
100
101#define FM_NEED_GC-1 -1
102#define FM_NO_MATCH-2 -2
103#define FM_PATTERN_ERROR-3 -3
104
105typedef enum {
106 BL_OK = 0,
107 BL_NO_MEMORY,
108 BL_INCORRECT_KEY
109} binding_location_status;
110
111#define FB_OK0 0
112#define FB_TYPE_ERROR-1 -1
113
114const char* lbm_error_str_parse_eof = "End of parse stream.";
115const char* lbm_error_str_parse_dot = "Incorrect usage of '.'.";
116const char* lbm_error_str_parse_close = "Expected closing parenthesis.";
117const char* lbm_error_str_num_args = "Incorrect number of arguments.";
118const char* lbm_error_str_forbidden_in_atomic = "Operation is forbidden in an atomic block.";
119const char* lbm_error_str_no_number = "Argument(s) must be a number.";
120const char* lbm_error_str_not_a_boolean = "Argument must be t or nil (true or false).";
121const char* lbm_error_str_incorrect_arg = "Incorrect argument.";
122const char* lbm_error_str_var_outside_progn = "Usage of var outside of progn.";
123const char* lbm_error_str_flash_not_possible = "Value cannot be written to flash.";
124const char* lbm_error_str_flash_error = "Error writing to flash.";
125const char* lbm_error_str_flash_full = "Flash memory is full.";
126const char* lbm_error_str_variable_not_bound = "Variable not bound.";
127
128static lbm_value lbm_error_suspect;
129static bool_Bool lbm_error_has_suspect = false0;
130#ifdef LBM_ALWAYS_GC
131
132#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
133 gc(); \
134 (y) = (x); \
135 if (lbm_is_symbol_merror((y))) { \
136 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
137 }
138
139#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
140 lbm_gc_mark_phase(r); \
141 gc(); \
142 (y) = (x); \
143 if (lbm_is_symbol_merror((y))) { \
144 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
145 }
146
147#else
148
149#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
150 (y) = (x); \
151 if (lbm_is_symbol_merror((y))) { \
152 gc(); \
153 (y) = (x); \
154 if (lbm_is_symbol_merror((y))) { \
155 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
156 } \
157 /* continue executing statements below */ \
158 }
159#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
160 (y) = (x); \
161 if (lbm_is_symbol_merror((y))) { \
162 lbm_gc_mark_phase(r); \
163 gc(); \
164 (y) = (x); \
165 if (lbm_is_symbol_merror((y))) { \
166 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
167 } \
168 /* continue executing statements below */ \
169 }
170
171#endif
172
173typedef struct {
174 eval_context_t *first;
175 eval_context_t *last;
176} eval_context_queue_t;
177
178#ifdef CLEAN_UP_CLOSURES
179static lbm_value clean_cl_env_symbol = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
180#endif
181
182static int gc(void);
183static void error_ctx(lbm_value);
184static void error_at_ctx(lbm_value err_val, lbm_value at);
185static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx);
186static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail);
187
188// The currently executing context.
189eval_context_t *ctx_running = NULL((void*)0);
190volatile bool_Bool lbm_system_sleeping = false0;
191
192static volatile bool_Bool gc_requested = false0;
193void lbm_request_gc(void) {
194 gc_requested = true1;
195}
196
197/*
198 On ChibiOs the CH_CFG_ST_FREQUENCY setting in chconf.h sets the
199 resolution of the timer used for sleep operations. If this is set
200 to 10KHz the resolution is 100us.
201
202 The CH_CFG_ST_TIMEDELTA specifies the minimum number of ticks that
203 can be safely specified in a timeout directive (wonder if that
204 means sleep-period). The timedelta is set to 2.
205
206 If I have understood these correctly it means that the minimum
207 sleep duration possible is 2 * 100us = 200us.
208*/
209
210#define EVAL_CPS_DEFAULT_STACK_SIZE256 256
211#define EVAL_CPS_MIN_SLEEP200 200
212#define EVAL_STEPS_QUOTA10 10
213
214static volatile uint32_t eval_steps_refill = EVAL_STEPS_QUOTA10;
215static uint32_t eval_steps_quota = EVAL_STEPS_QUOTA10;
216
217void lbm_set_eval_step_quota(uint32_t quota) {
218 eval_steps_refill = quota;
219}
220
221static uint32_t eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
222static volatile uint32_t eval_cps_next_state = EVAL_CPS_STATE_NONE0;
223static volatile uint32_t eval_cps_next_state_arg = 0;
224static volatile bool_Bool eval_cps_state_changed = false0;
225
226static void usleep_nonsense(uint32_t us) {
227 (void) us;
228}
229
230static bool_Bool dynamic_load_nonsense(const char *sym, const char **code) {
231 (void) sym;
232 (void) code;
233 return false0;
234}
235
236static uint32_t timestamp_nonsense(void) {
237 return 0;
238}
239
240static int printf_nonsense(const char *fmt, ...) {
241 (void) fmt;
242 return 0;
243}
244
245static void ctx_done_nonsense(eval_context_t *ctx) {
246 (void) ctx;
247}
248
249static void critical_nonsense(void) {
250 return;
251}
252
253static void (*critical_error_callback)(void) = critical_nonsense;
254static void (*usleep_callback)(uint32_t) = usleep_nonsense;
255static uint32_t (*timestamp_us_callback)(void) = timestamp_nonsense;
256static void (*ctx_done_callback)(eval_context_t *) = ctx_done_nonsense;
257static int (*printf_callback)(const char *, ...) = printf_nonsense;
258static bool_Bool (*dynamic_load_callback)(const char *, const char **) = dynamic_load_nonsense;
259
260void lbm_set_critical_error_callback(void (*fptr)(void)) {
261 if (fptr == NULL((void*)0)) critical_error_callback = critical_nonsense;
262 else critical_error_callback = fptr;
263}
264
265void lbm_set_usleep_callback(void (*fptr)(uint32_t)) {
266 if (fptr == NULL((void*)0)) usleep_callback = usleep_nonsense;
267 else usleep_callback = fptr;
268}
269
270void lbm_set_timestamp_us_callback(uint32_t (*fptr)(void)) {
271 if (fptr == NULL((void*)0)) timestamp_us_callback = timestamp_nonsense;
272 else timestamp_us_callback = fptr;
273}
274
275void lbm_set_ctx_done_callback(void (*fptr)(eval_context_t *)) {
276 if (fptr == NULL((void*)0)) ctx_done_callback = ctx_done_nonsense;
277 else ctx_done_callback = fptr;
278}
279
280void lbm_set_printf_callback(int (*fptr)(const char*, ...)){
281 if (fptr == NULL((void*)0)) printf_callback = printf_nonsense;
282 else printf_callback = fptr;
283}
284
285void lbm_set_dynamic_load_callback(bool_Bool (*fptr)(const char *, const char **)) {
286 if (fptr == NULL((void*)0)) dynamic_load_callback = dynamic_load_nonsense;
287 else dynamic_load_callback = fptr;
288}
289
290static volatile lbm_event_t *lbm_events = NULL((void*)0);
291static unsigned int lbm_events_head = 0;
292static unsigned int lbm_events_tail = 0;
293static unsigned int lbm_events_max = 0;
294static bool_Bool lbm_events_full = false0;
295static mutex_t lbm_events_mutex;
296static bool_Bool lbm_events_mutex_initialized = false0;
297static volatile lbm_cid lbm_event_handler_pid = -1;
298
299lbm_cid lbm_get_event_handler_pid(void) {
300 return lbm_event_handler_pid;
301}
302
303void lbm_set_event_handler_pid(lbm_cid pid) {
304 lbm_event_handler_pid = pid;
305}
306
307bool_Bool lbm_event_handler_exists(void) {
308 return(lbm_event_handler_pid > 0);
309}
310
311
312static bool_Bool event_internal(lbm_event_type_t event_type, lbm_uint parameter, lbm_uint buf_ptr, lbm_uint buf_len) {
313 bool_Bool r = false0;
314 if (lbm_events) {
315 mutex_lock(&lbm_events_mutex);
316 if (!lbm_events_full) {
317 lbm_event_t event;
318 event.type = event_type;
319 event.parameter = parameter;
320 event.buf_ptr = buf_ptr;
321 event.buf_len = buf_len;
322 lbm_events[lbm_events_head] = event;
323 lbm_events_head = (lbm_events_head + 1) % lbm_events_max;
324 lbm_events_full = lbm_events_head == lbm_events_tail;
325 r = true1;
326 }
327 mutex_unlock(&lbm_events_mutex);
328 }
329 return r;
330}
331
332bool_Bool lbm_event_define(lbm_value key, lbm_flat_value_t *fv) {
333 return event_internal(LBM_EVENT_DEFINE, key, (lbm_uint)fv->buf, fv->buf_size);
334}
335
336bool_Bool lbm_event_unboxed(lbm_value unboxed) {
337 lbm_uint t = lbm_type_of(unboxed);
338 if (t == LBM_TYPE_SYMBOL0x00000000u ||
339 t == LBM_TYPE_I0x00000008u ||
340 t == LBM_TYPE_U0x0000000Cu ||
341 t == LBM_TYPE_CHAR0x00000004u) {
342 if (lbm_event_handler_pid > 0) {
343 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)unboxed, 0);
344 }
345 }
346 return false0;
347}
348
349bool_Bool lbm_event(lbm_flat_value_t *fv) {
350 if (lbm_event_handler_pid > 0) {
351 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)fv->buf, fv->buf_size);
352 }
353 return false0;
354}
355
356static bool_Bool lbm_event_pop(lbm_event_t *event) {
357 mutex_lock(&lbm_events_mutex);
358 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
359 mutex_unlock(&lbm_events_mutex);
360 return false0;
361 }
362 *event = lbm_events[lbm_events_tail];
363 lbm_events_tail = (lbm_events_tail + 1) % lbm_events_max;
364 lbm_events_full = false0;
365 mutex_unlock(&lbm_events_mutex);
366 return true1;
367}
368
369bool_Bool lbm_event_queue_is_empty(void) {
370 mutex_lock(&lbm_events_mutex);
371 bool_Bool empty = false0;
372 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
373 empty = true1;
374 }
375 mutex_unlock(&lbm_events_mutex);
376 return empty;
377}
378
379static bool_Bool eval_running = false0;
380static volatile bool_Bool blocking_extension = false0;
381static mutex_t blocking_extension_mutex;
382static bool_Bool blocking_extension_mutex_initialized = false0;
383static lbm_uint blocking_extension_timeout_us = 0;
384static bool_Bool blocking_extension_timeout = false0;
385
386static uint32_t is_atomic = 0;
387
388/* Process queues */
389static eval_context_queue_t blocked = {NULL((void*)0), NULL((void*)0)};
390static eval_context_queue_t queue = {NULL((void*)0), NULL((void*)0)};
391
392/* one mutex for all queue operations */
393mutex_t qmutex;
394bool_Bool qmutex_initialized = false0;
395
396
397// MODES
398static volatile bool_Bool lbm_verbose = false0;
399
400void lbm_toggle_verbose(void) {
401 lbm_verbose = !lbm_verbose;
402}
403
404void lbm_set_verbose(bool_Bool verbose) {
405 lbm_verbose = verbose;
406}
407
408lbm_cid lbm_get_current_cid(void) {
409 if (ctx_running)
410 return ctx_running->id;
411 else
412 return -1;
413}
414
415eval_context_t *lbm_get_current_context(void) {
416 return ctx_running;
417}
418
419/****************************************************/
420/* Utilities used locally in this file */
421
422static lbm_value cons_with_gc(lbm_value head, lbm_value tail, lbm_value remember) {
423#ifdef LBM_ALWAYS_GC
424 lbm_value roots[3] = {head, tail, remember};
425 lbm_gc_mark_roots(roots, 3);
426 gc();
427 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
428 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
429 if (lbm_is_symbol_merror(res)) {
430 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
431 }
432 return res;
433#else
434 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
435 if (lbm_is_symbol_merror(res)) {
436 lbm_value roots[3] = {head, tail, remember};
437 lbm_gc_mark_roots(roots,3);
438 gc();
439 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
440 if (lbm_is_symbol_merror(res)) {
441 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
442 }
443 }
444 return res;
445#endif
446}
447
448static lbm_uint *get_stack_ptr(eval_context_t *ctx, unsigned int n) {
449 if (n <= ctx->K.sp) {
450 lbm_uint index = ctx->K.sp - n;
451 return &ctx->K.data[index];
452 }
453 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
454 return 0; // dead code cannot be reached, but C compiler doesn't realise.
455}
456
457// pop_stack_ptr is safe when no GC is performed and
458// the values of the stack will be dropped.
459static lbm_uint *pop_stack_ptr(eval_context_t *ctx, unsigned int n) {
460 if (n <= ctx->K.sp) {
461 ctx->K.sp -= n;
462 return &ctx->K.data[ctx->K.sp];
463 }
464 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
465 return 0; // dead code cannot be reached, but C compiler doesn't realise.
466}
467
468static inline lbm_uint *stack_reserve(eval_context_t *ctx, unsigned int n) {
469 if (ctx->K.sp + n < ctx->K.size) {
470 lbm_uint *ptr = &ctx->K.data[ctx->K.sp];
471 ctx->K.sp += n;
472 return ptr;
473 }
474 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
475 return 0; // dead code cannot be reached, but C compiler doesn't realise.
476}
477
478static void handle_flash_status(lbm_flash_status s) {
479 if ( s == LBM_FLASH_FULL) {
480 lbm_set_error_reason((char*)lbm_error_str_flash_full);
481 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
482 }
483 if (s == LBM_FLASH_WRITE_ERROR) {
484 lbm_set_error_reason((char*)lbm_error_str_flash_error);
485 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
486 }
487}
488
489static void lift_array_flash(lbm_value flash_cell, bool_Bool bytearray, char *data, lbm_uint num_elt) {
490
491 lbm_array_header_t flash_array_header;
492 flash_array_header.size = num_elt;
493 flash_array_header.data = (lbm_uint*)data;
494 lbm_uint flash_array_header_ptr;
495 handle_flash_status(lbm_write_const_raw((lbm_uint*)&flash_array_header,
496 sizeof(lbm_array_header_t) / sizeof(lbm_uint),
497 &flash_array_header_ptr));
498 handle_flash_status(write_const_car(flash_cell, flash_array_header_ptr));
499 lbm_uint t = bytearray ? ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u) : ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u);
500 handle_flash_status(write_const_cdr(flash_cell, t));
501}
502
503static void get_car_and_cdr(lbm_value a, lbm_value *a_car, lbm_value *a_cdr) {
504 if (lbm_is_ptr(a)) {
8
←
Assuming the condition is false
→
9
←
Taking false branch
→
505 lbm_cons_t *cell = lbm_ref_cell(a);
506 *a_car = cell->car;
507 *a_cdr = cell->cdr;
508 } else if (lbm_is_symbol_nil(a)) {
10
←
Taking false branch
→
509 *a_car = *a_cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
510 } else {
511 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
512 }
513}
11
←
Returning without writing to '*a_car'
→
514
515/* car cdr caar cadr replacements that are evaluator safe. */
516static lbm_value get_car(lbm_value a) {
517 if (lbm_is_ptr(a)) {
518 lbm_cons_t *cell = lbm_ref_cell(a);
519 return cell->car;
520 } else if (lbm_is_symbol_nil(a)) {
521 return a;
522 }
523 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
524 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
525}
526
527static lbm_value get_cdr(lbm_value a) {
528 if (lbm_is_ptr(a)) {
529 lbm_cons_t *cell = lbm_ref_cell(a);
530 return cell->cdr;
531 } else if (lbm_is_symbol_nil(a)) {
532 return a;
533 }
534 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
535 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
536}
537
538static lbm_value get_cadr(lbm_value a) {
539 if (lbm_is_ptr(a)) {
540 lbm_cons_t *cell = lbm_ref_cell(a);
541 lbm_value tmp = cell->cdr;
542 if (lbm_is_ptr(tmp)) {
543 return lbm_ref_cell(tmp)->car;
544 } else if (lbm_is_symbol_nil(tmp)) {
545 return tmp;
546 }
547 } else if (lbm_is_symbol_nil(a)) {
548 return a;
549 }
550 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
551 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
552}
553
554static lbm_value allocate_closure(lbm_value params, lbm_value body, lbm_value env) {
555
556#ifdef LBM_ALWAYS_GC
557 gc();
558 if (lbm_heap_num_free() < 4) {
559 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
560 }
561#else
562 if (lbm_heap_num_free() < 4) {
563 gc();
564 if (lbm_heap_num_free() < 4) {
565 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
566 }
567 }
568#endif
569 // The freelist will always contain just plain heap-cells.
570 // So dec_ptr is sufficient.
571 lbm_value res = lbm_heap_state.freelist;
572 if (lbm_type_of(res) == LBM_TYPE_CONS0x10000000u) {
573 lbm_cons_t *heap = lbm_heap_state.heap;
574 lbm_uint ix = lbm_dec_ptr(res);
575 heap[ix].car = ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u);
576 ix = lbm_dec_ptr(heap[ix].cdr);
577 heap[ix].car = params;
578 ix = lbm_dec_ptr(heap[ix].cdr);
579 heap[ix].car = body;
580 ix = lbm_dec_ptr(heap[ix].cdr);
581 heap[ix].car = env;
582 lbm_heap_state.freelist = heap[ix].cdr;
583 heap[ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
584 lbm_heap_state.num_alloc+=4;
585 } else {
586 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
587 }
588 return res;
589}
590
591// Allocate a binding and attach it to a list (if so desired)
592static lbm_value allocate_binding(lbm_value key, lbm_value val, lbm_value the_cdr) {
593 if (lbm_heap_num_free() < 2) {
594 gc();
595 if (lbm_heap_num_free() < 2) {
596 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
597 }
598 }
599 lbm_cons_t* heap = lbm_heap_state.heap;
600 lbm_value binding_cell = lbm_heap_state.freelist;
601 lbm_uint binding_cell_ix = lbm_dec_ptr(binding_cell);
602 lbm_value list_cell = heap[binding_cell_ix].cdr;
603 lbm_uint list_cell_ix = lbm_dec_ptr(list_cell);
604 lbm_heap_state.freelist = heap[list_cell_ix].cdr;
605 lbm_heap_state.num_alloc += 2;
606 heap[binding_cell_ix].car = key;
607 heap[binding_cell_ix].cdr = val;
608 heap[list_cell_ix].car = binding_cell;
609 heap[list_cell_ix].cdr = the_cdr;
610 return list_cell;
611}
612
613#define CLO_PARAMS0 0
614#define CLO_BODY1 1
615#define CLO_ENV2 2
616#define LOOP_BINDS0 0
617#define LOOP_COND1 1
618#define LOOP_BODY2 2
619
620// (a b c) -> [a b c]
621static lbm_value extract_n(lbm_value curr, lbm_value *res, unsigned int n) {
622 for (unsigned int i = 0; i < n; i ++) {
623 if (lbm_is_ptr(curr)) {
624 lbm_cons_t *cell = lbm_ref_cell(curr);
625 res[i] = cell->car;
626 curr = cell->cdr;
627 } else {
628 res[i] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
629 }
630 }
631 return curr; // Rest of list is returned here.
632}
633
634static void call_fundamental(lbm_uint fundamental, lbm_value *args, lbm_uint arg_count, eval_context_t *ctx) {
635 lbm_value res;
636 res = fundamental_table[fundamental](args, arg_count, ctx);
637 if (lbm_is_error(res)) {
638 if (lbm_is_symbol_merror(res)) {
639 gc();
640 res = fundamental_table[fundamental](args, arg_count, ctx);
641 }
642 if (lbm_is_error(res)) {
643 error_at_ctx(res, lbm_enc_sym(FUNDAMENTAL_SYMBOLS_START0x20000 | fundamental));
644 }
645 }
646 lbm_stack_drop(&ctx->K, arg_count+1);
647 ctx->app_cont = true1;
648 ctx->r = res;
649}
650
651// block_current_ctx blocks a context until it is
652// woken up externally or a timeout period of time passes.
653static void block_current_ctx(uint32_t state, lbm_uint sleep_us, bool_Bool do_cont) {
654 ctx_running->timestamp = timestamp_us_callback();
655 ctx_running->sleep_us = sleep_us;
656 ctx_running->state = state;
657 ctx_running->app_cont = do_cont;
658 enqueue_ctx(&blocked, ctx_running);
659 ctx_running = NULL((void*)0);
660}
661
662lbm_flash_status lbm_write_const_array_padded(uint8_t *data, lbm_uint n, lbm_uint *res) {
663 lbm_uint full_words = n / sizeof(lbm_uint);
664 lbm_uint n_mod = n % sizeof(lbm_uint);
665
666 if (n_mod == 0) { // perfect fit.
667 return lbm_write_const_raw((lbm_uint*)data, full_words, res);
668 } else {
669 lbm_uint last_word = 0;
670 memcpy(&last_word, &data[full_words * sizeof(lbm_uint)], n_mod);
671 if (full_words >= 1) {
672 lbm_flash_status s = lbm_write_const_raw((lbm_uint*)data, full_words, res);
673 if ( s == LBM_FLASH_WRITE_OK) {
674 lbm_uint dummy;
675 s = lbm_write_const_raw(&last_word, 1, &dummy);
676 }
677 return s;
678 } else {
679 return lbm_write_const_raw(&last_word, 1, res);
680 }
681 }
682}
683
684/****************************************************/
685/* Error message creation */
686
687#define ERROR_MESSAGE_BUFFER_SIZE_BYTES256 256
688
689void print_environments(char *buf, unsigned int size) {
690
691 lbm_value curr_l = ctx_running->curr_env;
692 printf_callback("\tCurrent local environment:\n");
693 while (lbm_type_of(curr_l) == LBM_TYPE_CONS0x10000000u) {
694 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_l));
695 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_l)));
696 printf_callback("\t%s = %s\n", buf, buf+(size/2));
697 curr_l = lbm_cdr(curr_l);
698 }
699 printf_callback("\n\n");
700 printf_callback("\tCurrent global environment:\n");
701 lbm_value *glob_env = lbm_get_global_env();
702
703 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
704 lbm_value curr_g = glob_env[i];;
705 while (lbm_type_of(curr_g) == LBM_TYPE_CONS0x10000000u) {
706
707 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_g));
708 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_g)));
709 printf_callback("\t%s = %s\n", buf, buf+(size/2));
710 curr_g = lbm_cdr(curr_g);
711 }
712 }
713}
714
715void print_error_message(lbm_value error, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int col, lbm_int row0, lbm_int row1) {
716 if (!printf_callback) return;
717
718 /* try to allocate a lbm_print_value buffer on the lbm_memory */
719 char *buf = lbm_malloc_reserve(ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
720 if (!buf) {
721 printf_callback("Error: Not enough free memory to create a human readable error message\n");
722 return;
723 }
724
725 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, error);
726 printf_callback( "*** Error: %s\n", buf);
727 if (has_at) {
728 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, at);
729 printf_callback("*** In: %s\n",buf);
730 if (lbm_error_has_suspect) {
731 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, lbm_error_suspect);
732 lbm_error_has_suspect = false0;
733 printf_callback("*** At: %s\n", buf);
734 } else {
735 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
736 printf_callback("*** After: %s\n",buf);
737 }
738 } else {
739 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
740 printf_callback("*** Near: %s\n",buf);
741 }
742
743 printf_callback("\n");
744
745 if (lbm_is_symbol(error) &&
746 error == ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u)) {
747 printf_callback("*** Line: %u\n", row);
748 printf_callback("*** Column: %u\n", col);
749 } else if (row0 != -1 || row1 != -1 ) {
750 printf_callback("*** Between rows: (-1 unknown) \n");
751 printf_callback("*** Start: %d\n", (int32_t)row0);
752 printf_callback("*** End: %d\n", (int32_t)row1);
753 }
754
755 printf_callback("\n");
756
757 if (ctx_running->error_reason) {
758 printf_callback("Reason:\n %s\n\n", ctx_running->error_reason);
759 }
760 if (lbm_verbose) {
761 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
762 printf_callback(" In context: %d\n", ctx_running->id);
763 printf_callback(" Current intermediate result: %s\n\n", buf);
764
765 print_environments(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
766 printf_callback("\n\n");
767
768 printf_callback(" Stack:\n");
769 for (unsigned int i = 0; i < ctx_running->K.sp; i ++) {
770 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->K.data[i]);
771 printf_callback(" %s\n", buf);
772 }
773 }
774 lbm_free(buf);
775}
776
777/****************************************************/
778/* Tokenizing and parsing */
779
780bool_Bool create_string_channel(char *str, lbm_value *res) {
781
782 lbm_char_channel_t *chan = NULL((void*)0);
783 lbm_string_channel_state_t *st = NULL((void*)0);
784
785 st = (lbm_string_channel_state_t*)lbm_memory_allocate(sizeof(lbm_string_channel_state_t) / sizeof(lbm_uint) +1);
786 if (st == NULL((void*)0)) {
787 return false0;
788 }
789 chan = (lbm_char_channel_t*)lbm_memory_allocate(sizeof(lbm_char_channel_t) / sizeof(lbm_uint) + 1);
790 if (chan == NULL((void*)0)) {
791 lbm_memory_free((lbm_uint*)st);
792 return false0;
793 }
794
795 lbm_create_string_char_channel(st, chan, str);
796 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
797 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
798 lbm_memory_free((lbm_uint*)st);
799 lbm_memory_free((lbm_uint*)chan);
800 return false0;
801 }
802
803 *res = cell;
804 return true1;
805}
806
807bool_Bool lift_char_channel(lbm_char_channel_t *chan , lbm_value *res) {
808 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
809 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
810 return false0;
811 }
812 *res = cell;
813 return true1;
814}
815
816
817/****************************************************/
818/* Queue functions */
819
820static void queue_iterator_nm(eval_context_queue_t *q, ctx_fun f, void *arg1, void *arg2) {
821 eval_context_t *curr;
822 curr = q->first;
823
824 while (curr != NULL((void*)0)) {
825 f(curr, arg1, arg2);
826 curr = curr->next;
827 }
828}
829
830void lbm_running_iterator(ctx_fun f, void *arg1, void *arg2){
831 mutex_lock(&qmutex);
832 queue_iterator_nm(&queue, f, arg1, arg2);
833 mutex_unlock(&qmutex);
834}
835
836void lbm_blocked_iterator(ctx_fun f, void *arg1, void *arg2){
837 mutex_lock(&qmutex);
838 queue_iterator_nm(&blocked, f, arg1, arg2);
839 mutex_unlock(&qmutex);
840}
841
842static void enqueue_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
843 if (q->last == NULL((void*)0)) {
844 ctx->prev = NULL((void*)0);
845 ctx->next = NULL((void*)0);
846 q->first = ctx;
847 q->last = ctx;
848 } else {
849 ctx->prev = q->last;
850 ctx->next = NULL((void*)0);
851 q->last->next = ctx;
852 q->last = ctx;
853 }
854}
855
856static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx) {
857 mutex_lock(&qmutex);
858 enqueue_ctx_nm(q,ctx);
859 mutex_unlock(&qmutex);
860}
861
862static eval_context_t *lookup_ctx_nm(eval_context_queue_t *q, lbm_cid cid) {
863 eval_context_t *curr;
864 curr = q->first;
865 while (curr != NULL((void*)0)) {
866 if (curr->id == cid) {
867 return curr;
868 }
869 curr = curr->next;
870 }
871 return NULL((void*)0);
872}
873
874static bool_Bool drop_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
875
876 bool_Bool res = false0;
877 if (q->first == NULL((void*)0) || q->last == NULL((void*)0)) {
878 if (!(q->last == NULL((void*)0) && q->first == NULL((void*)0))) {
879 /* error state that should not happen */
880 return res;
881 }
882 /* Queue is empty */
883 return res;
884 }
885
886 eval_context_t *curr = q->first;
887 while (curr) {
888 if (curr->id == ctx->id) {
889 res = true1;
890 eval_context_t *tmp = curr->next;
891 if (curr->prev == NULL((void*)0)) {
892 if (curr->next == NULL((void*)0)) {
893 q->last = NULL((void*)0);
894 q->first = NULL((void*)0);
895 } else {
896 q->first = tmp;
897 tmp->prev = NULL((void*)0);
898 }
899 } else { /* curr->prev != NULL */
900 if (curr->next == NULL((void*)0)) {
901 q->last = curr->prev;
902 q->last->next = NULL((void*)0);
903 } else {
904 curr->prev->next = tmp;
905 tmp->prev = curr->prev;
906 }
907 }
908 break;
909 }
910 curr = curr->next;
911 }
912 return res;
913}
914
915/* End execution of the running context. */
916static void finish_ctx(void) {
917
918 if (!ctx_running) {
919 return;
920 }
921 /* Drop the continuation stack immediately to free up lbm_memory */
922 lbm_stack_free(&ctx_running->K);
923 ctx_done_callback(ctx_running);
924 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->name)) {
925 lbm_free(ctx_running->name);
926 }
927 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->error_reason)) {
928 lbm_memory_free((lbm_uint*)ctx_running->error_reason);
929 }
930 lbm_memory_free((lbm_uint*)ctx_running->mailbox);
931 lbm_memory_free((lbm_uint*)ctx_running);
932 ctx_running = NULL((void*)0);
933}
934
935static void context_exists(eval_context_t *ctx, void *cid, void *b) {
936 if (ctx->id == *(lbm_cid*)cid) {
937 *(bool_Bool*)b = true1;
938 }
939}
940
941bool_Bool lbm_wait_ctx(lbm_cid cid, lbm_uint timeout_ms) {
942
943 bool_Bool exists;
944 uint32_t i = 0;
945
946 do {
947 exists = false0;
948 lbm_blocked_iterator(context_exists, &cid, &exists);
949 lbm_running_iterator(context_exists, &cid, &exists);
950
951 if (ctx_running &&
952 ctx_running->id == cid) {
953 exists = true1;
954 }
955
956 if (exists) {
957 if (usleep_callback) {
958 usleep_callback(1000);
959 }
960 if (timeout_ms > 0) i ++;
961 }
962 } while (exists && i < timeout_ms);
963
964 if (exists) return false0;
965 return true1;
966}
967
968void lbm_set_error_suspect(lbm_value suspect) {
969 lbm_error_suspect = suspect;
970 lbm_error_has_suspect = true1;
971}
972
973void lbm_set_error_reason(char *error_str) {
974 if (ctx_running != NULL((void*)0)) {
975 ctx_running->error_reason = error_str;
976 }
977}
978
979// Not possible to CONS_WITH_GC in error_ctx_base (potential loop)
980static void error_ctx_base(lbm_value err_val, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int column) {
981
982 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
983 if (lbm_heap_num_free() < 3) {
984 gc();
985 }
986
987 if (lbm_heap_num_free() >= 3) {
988 lbm_value msg = lbm_cons(err_val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
989 msg = lbm_cons(lbm_enc_i(ctx_running->id), msg);
990 msg = lbm_cons(ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u), msg);
991 if (!lbm_is_symbol_merror(msg)) {
992 lbm_find_receiver_and_send(ctx_running->parent, msg);
993 goto error_ctx_base_done;
994 }
995 }
996 }
997 if ((ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10) &&
998 (err_val != ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u))) {
999 lbm_uint v;
1000 while (ctx_running->K.sp > 0) {
1001 lbm_pop(&ctx_running->K, &v);
1002 if (v == EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u)) {
1003 lbm_value *sptr = get_stack_ptr(ctx_running, 2);
1004 lbm_set_car(sptr[0], ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
1005 stack_reserve(ctx_running, 1)[0] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1006 ctx_running->app_cont = true1;
1007 ctx_running->r = err_val;
1008 longjmp(error_jmp_buf, 1);
1009 }
1010 }
1011 err_val = ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u);
1012 }
1013 print_error_message(err_val,
1014 has_at,
1015 at,
1016 row,
1017 column,
1018 ctx_running->row0,
1019 ctx_running->row1);
1020 error_ctx_base_done:
1021 ctx_running->r = err_val;
1022 finish_ctx();
1023 longjmp(error_jmp_buf, 1);
1024}
1025
1026static void error_at_ctx(lbm_value err_val, lbm_value at) {
1027 error_ctx_base(err_val, true1, at, 0, 0);
1028}
1029
1030static void error_ctx(lbm_value err_val) {
1031 error_ctx_base(err_val, false0, 0, 0, 0);
1032}
1033
1034static void read_error_ctx(unsigned int row, unsigned int column) {
1035 error_ctx_base(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u), false0, 0, row, column);
1036}
1037
1038void lbm_critical_error(void) {
1039 longjmp(critical_error_jmp_buf, 1);
1040}
1041
1042// successfully finish a context
1043static void ok_ctx(void) {
1044 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
1045 lbm_value msg;
1046 WITH_GC(msg, lbm_heap_allocate_list_init(3,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1047 ENC_SYM_EXIT_OK,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1048 lbm_enc_i(ctx_running->id),(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1049 ctx_running->r))(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
1050 lbm_find_receiver_and_send(ctx_running->parent, msg);
1051 }
1052 finish_ctx();
1053}
1054
1055static eval_context_t *dequeue_ctx_nm(eval_context_queue_t *q) {
1056 if (q->last == NULL((void*)0)) {
1057 return NULL((void*)0);
1058 }
1059 // q->first should only be NULL if q->last is.
1060 eval_context_t *res = q->first;
1061
1062 if (q->first == q->last) { // One thing in queue
1063 q->first = NULL((void*)0);
1064 q->last = NULL((void*)0);
1065 } else {
1066 q->first = q->first->next;
1067 q->first->prev = NULL((void*)0);
1068 }
1069 res->prev = NULL((void*)0);
1070 res->next = NULL((void*)0);
1071 return res;
1072}
1073
1074static void wake_up_ctxs_nm(void) {
1075 lbm_uint t_now;
1076
1077 if (timestamp_us_callback) {
1078 t_now = timestamp_us_callback();
1079 } else {
1080 t_now = 0;
1081 }
1082
1083 eval_context_queue_t *q = &blocked;
1084 eval_context_t *curr = q->first;
1085
1086 while (curr != NULL((void*)0)) {
1087 lbm_uint t_diff;
1088 eval_context_t *next = curr->next;
1089 if (curr->state != LBM_THREAD_STATE_BLOCKED(uint32_t)1) {
1090 if ( curr->timestamp > t_now) {
1091 /* There was an overflow on the counter */
1092#ifndef LBM64
1093 t_diff = (0xFFFFFFFF - curr->timestamp) + t_now;
1094#else
1095 t_diff = (0xFFFFFFFFFFFFFFFF - curr->timestamp) + t_now;
1096#endif
1097 } else {
1098 t_diff = t_now - curr->timestamp;
1099 }
1100
1101 if (t_diff >= curr->sleep_us) {
1102 eval_context_t *wake_ctx = curr;
1103 if (curr == q->last) {
1104 if (curr->prev) {
1105 q->last = curr->prev;
1106 q->last->next = NULL((void*)0);
1107 } else {
1108 q->first = NULL((void*)0);
1109 q->last = NULL((void*)0);
1110 }
1111 } else if (curr->prev == NULL((void*)0)) {
1112 q->first = curr->next;
1113 q->first->prev = NULL((void*)0);
1114 } else {
1115 curr->prev->next = curr->next;
1116 if (curr->next) {
1117 curr->next->prev = curr->prev;
1118 }
1119 }
1120 wake_ctx->next = NULL((void*)0);
1121 wake_ctx->prev = NULL((void*)0);
1122 if (curr->state == LBM_THREAD_STATE_TIMEOUT(uint32_t)2) {
1123 mailbox_add_mail(wake_ctx, ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u));
1124 wake_ctx->r = ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u);
1125 }
1126 wake_ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1127 enqueue_ctx_nm(&queue, wake_ctx);
1128 }
1129 }
1130 curr = next;
1131 }
1132}
1133
1134static void yield_ctx(lbm_uint sleep_us) {
1135 if (timestamp_us_callback) {
1136 ctx_running->timestamp = timestamp_us_callback();
1137 ctx_running->sleep_us = sleep_us;
1138 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1139 } else {
1140 ctx_running->timestamp = 0;
1141 ctx_running->sleep_us = 0;
1142 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1143 }
1144 ctx_running->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1145 ctx_running->app_cont = true1;
1146 enqueue_ctx(&blocked,ctx_running);
1147 ctx_running = NULL((void*)0);
1148}
1149
1150static lbm_cid lbm_create_ctx_parent(lbm_value program, lbm_value env, lbm_uint stack_size, lbm_cid parent, uint32_t context_flags, char *name) {
1151
1152 if (!lbm_is_cons(program)) return -1;
1153
1154 eval_context_t *ctx = NULL((void*)0);
1155
1156 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1157 if (ctx == NULL((void*)0)) {
1158 lbm_uint roots[2] = {program, env};
1159 lbm_gc_mark_roots(roots, 2);
1160 gc();
1161 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1162 }
1163 if (ctx == NULL((void*)0)) return -1;
1164
1165 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1166 lbm_uint roots[2] = {program, env};
1167 lbm_gc_mark_roots(roots, 2);
1168 gc();
1169 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1170 lbm_memory_free((lbm_uint*)ctx);
1171 return -1;
1172 }
1173 }
1174
1175 lbm_value *mailbox = NULL((void*)0);
1176 mailbox = (lbm_value*)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1177 if (mailbox == NULL((void*)0)) {
1178 lbm_value roots[2] = {program, env};
1179 lbm_gc_mark_roots(roots,2);
1180 gc();
1181 mailbox = (lbm_value *)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1182 }
1183 if (mailbox == NULL((void*)0)) {
1184 lbm_stack_free(&ctx->K);
1185 lbm_memory_free((lbm_uint*)ctx);
1186 return -1;
1187 }
1188
1189 // TODO: Limit names to 19 chars + 1 char for 0? (or something similar).
1190 if (name) {
1191 lbm_uint name_len = strlen(name) + 1;
1192 ctx->name = lbm_malloc(strlen(name) + 1);
1193 if (ctx->name == NULL((void*)0)) {
1194 lbm_value roots[2] = {program, env};
1195 lbm_gc_mark_roots(roots, 2);
1196 gc();
1197 ctx->name = lbm_malloc(strlen(name) + 1);
1198 }
1199 if (ctx->name == NULL((void*)0)) {
1200 lbm_stack_free(&ctx->K);
1201 lbm_memory_free((lbm_uint*)mailbox);
1202 lbm_memory_free((lbm_uint*)ctx);
1203 return -1;
1204 }
1205 memcpy(ctx->name, name, name_len+1);
1206 } else {
1207 ctx->name = NULL((void*)0);
1208 }
1209
1210 lbm_int cid = lbm_memory_address_to_ix((lbm_uint*)ctx);
1211
1212 ctx->program = lbm_cdr(program);
1213 ctx->curr_exp = lbm_car(program);
1214 ctx->curr_env = env;
1215 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1216 ctx->error_reason = NULL((void*)0);
1217 ctx->mailbox = mailbox;
1218 ctx->mailbox_size = EVAL_CPS_DEFAULT_MAILBOX_SIZE10;
1219 ctx->flags = context_flags;
1220 ctx->num_mail = 0;
1221 ctx->app_cont = false0;
1222 ctx->timestamp = 0;
1223 ctx->sleep_us = 0;
1224 ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1225 ctx->prev = NULL((void*)0);
1226 ctx->next = NULL((void*)0);
1227
1228 ctx->row0 = -1;
1229 ctx->row1 = -1;
1230
1231 ctx->id = cid;
1232 ctx->parent = parent;
1233
1234 if (!lbm_push(&ctx->K, DONE(((0) << 2) | 0xF8000001u))) {
1235 lbm_memory_free((lbm_uint*)ctx->mailbox);
1236 lbm_stack_free(&ctx->K);
1237 lbm_memory_free((lbm_uint*)ctx);
1238 return -1;
1239 }
1240
1241 enqueue_ctx(&queue,ctx);
1242
1243 return ctx->id;
1244}
1245
1246lbm_cid lbm_create_ctx(lbm_value program, lbm_value env, lbm_uint stack_size, char *name) {
1247 // Creates a parentless context.
1248 return lbm_create_ctx_parent(program,
1249 env,
1250 stack_size,
1251 -1,
1252 EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00,
1253 name);
1254}
1255
1256bool_Bool lbm_mailbox_change_size(eval_context_t *ctx, lbm_uint new_size) {
1257
1258 lbm_value *mailbox = NULL((void*)0);
1259 mailbox = (lbm_value*)lbm_memory_allocate(new_size);
1260 if (mailbox == NULL((void*)0)) {
1261 gc();
1262 mailbox = (lbm_value *)lbm_memory_allocate(new_size);
1263 }
1264 if (mailbox == NULL((void*)0)) {
1265 return false0;
1266 }
1267
1268 for (lbm_uint i = 0; i < ctx->num_mail; i ++ ) {
1269 mailbox[i] = ctx->mailbox[i];
1270 }
1271 lbm_memory_free(ctx->mailbox);
1272 ctx->mailbox = mailbox;
1273 ctx->mailbox_size = (uint32_t)new_size;
1274 return true1;
1275}
1276
1277static void mailbox_remove_mail(eval_context_t *ctx, lbm_uint ix) {
1278
1279 for (lbm_uint i = ix; i < ctx->num_mail-1; i ++) {
1280 ctx->mailbox[i] = ctx->mailbox[i+1];
1281 }
1282 ctx->num_mail --;
1283}
1284
1285static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail) {
1286
1287 if (ctx->num_mail >= ctx->mailbox_size) {
1288 mailbox_remove_mail(ctx, 0);
1289 }
1290
1291 ctx->mailbox[ctx->num_mail] = mail;
1292 ctx->num_mail ++;
1293 return true1;
1294}
1295
1296/* Advance execution to the next expression in the program */
1297static void advance_ctx(eval_context_t *ctx) {
1298 if (lbm_is_cons(ctx->program)) {
1299 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);;
1300 get_car_and_cdr(ctx->program, &ctx->curr_exp, &ctx->program);
1301 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1302 } else {
1303 if (ctx_running == ctx) { // This should always be the case because of odd historical reasons.
1304 ok_ctx();
1305 }
1306 }
1307}
1308
1309bool_Bool lbm_unblock_ctx(lbm_cid cid, lbm_flat_value_t *fv) {
1310 return event_internal(LBM_EVENT_UNBLOCK_CTX, (lbm_uint)cid, (lbm_uint)fv->buf, fv->buf_size);
1311}
1312
1313bool_Bool lbm_unblock_ctx_r(lbm_cid cid) {
1314 mutex_lock(&blocking_extension_mutex);
1315 bool_Bool r = false0;
1316 eval_context_t *found = NULL((void*)0);
1317 mutex_lock(&qmutex);
1318 found = lookup_ctx_nm(&blocked, cid);
1319 if (found) {
1320 drop_ctx_nm(&blocked,found);
1321 enqueue_ctx_nm(&queue,found);
1322 r = true1;
1323 }
1324 mutex_unlock(&qmutex);
1325 mutex_unlock(&blocking_extension_mutex);
1326 return r;
1327}
1328
1329// unblock unboxed is also safe for rmbr:ed things.
1330bool_Bool lbm_unblock_ctx_unboxed(lbm_cid cid, lbm_value unboxed) {
1331 mutex_lock(&blocking_extension_mutex);
1332 bool_Bool r = false0;
1333 eval_context_t *found = NULL((void*)0);
1334 mutex_lock(&qmutex);
1335 found = lookup_ctx_nm(&blocked, cid);
1336 if (found) {
1337 drop_ctx_nm(&blocked,found);
1338 found->r = unboxed;
1339 if (lbm_is_error(unboxed)) {
1340 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
1341 found->app_cont = true1;
1342 }
1343 enqueue_ctx_nm(&queue,found);
1344 r = true1;
1345 }
1346 mutex_unlock(&qmutex);
1347 mutex_unlock(&blocking_extension_mutex);
1348 return r;
1349}
1350
1351static bool_Bool lbm_block_ctx_base(bool_Bool timeout, float t_s) {
1352 mutex_lock(&blocking_extension_mutex);
1353 blocking_extension = true1;
1354 if (timeout) {
1355 blocking_extension_timeout_us = S_TO_US(t_s)(lbm_uint)((t_s) * 1000000);
1356 blocking_extension_timeout = true1;
1357 } else {
1358 blocking_extension_timeout = false0;
1359 }
1360 return true1;
1361}
1362
1363void lbm_block_ctx_from_extension_timeout(float s) {
1364 lbm_block_ctx_base(true1, s);
1365}
1366
1367void lbm_block_ctx_from_extension(void) {
1368 lbm_block_ctx_base(false0, 0);
1369}
1370
1371// todo: May need to pop rmbrs from stack, if present.
1372// Suspect that the letting the discard cont run is really not a problem.
1373// Either way will be quite confusing what happens to allocated things when undoing block.
1374void lbm_undo_block_ctx_from_extension(void) {
1375 blocking_extension = false0;
1376 blocking_extension_timeout_us = 0;
1377 blocking_extension_timeout = false0;
1378 mutex_unlock(&blocking_extension_mutex);
1379}
1380
1381lbm_value lbm_find_receiver_and_send(lbm_cid cid, lbm_value msg) {
1382 mutex_lock(&qmutex);
1383 eval_context_t *found = NULL((void*)0);
1384 bool_Bool found_blocked = false0;
1385
1386 found = lookup_ctx_nm(&blocked, cid);
1387 if (found) found_blocked = true1;
1388
1389 if (found == NULL((void*)0)) {
1390 found = lookup_ctx_nm(&queue, cid);
1391 }
1392
1393 if (found) {
1394 if (!mailbox_add_mail(found, msg)) {
1395 mutex_unlock(&qmutex);
1396 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1397 }
1398
1399 if (found_blocked){
1400 drop_ctx_nm(&blocked,found);
1401 enqueue_ctx_nm(&queue,found);
1402 }
1403 mutex_unlock(&qmutex);
1404 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1405 }
1406
1407 /* check the current context */
1408 if (ctx_running && ctx_running->id == cid) {
1409 if (!mailbox_add_mail(ctx_running, msg)) {
1410 mutex_unlock(&qmutex);
1411 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1412 }
1413 mutex_unlock(&qmutex);
1414 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1415 }
1416 mutex_unlock(&qmutex);
1417 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1418}
1419
1420/* Pattern matching is currently implemented as a recursive
1421 function and make use of stack relative to the size of
1422 expressions that are being matched. */
1423static bool_Bool match(lbm_value p, lbm_value e, lbm_value *env, bool_Bool *gc) {
1424
1425 lbm_value binding;
1426
1427 if (lbm_is_match_binder(p)) {
1428 lbm_value var = get_cadr(p);
1429 lbm_value bindertype = get_car(p);
1430
1431 if (!lbm_is_symbol(var)) return false0;
1432
1433 switch (bindertype) {
1434 case ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u):
1435 if ( var == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) {
1436 return true1;
1437 }
1438 break;
1439 default: /* this should be an error case */
1440 return false0;
1441 }
1442 binding = lbm_cons(var, e);
1443 if ( lbm_type_of(binding) == LBM_TYPE_SYMBOL0x00000000u ) {
1444 *gc = true1;
1445 return false0;
1446 }
1447 *env = lbm_cons(binding, *env);
1448 if ( lbm_type_of(*env) == LBM_TYPE_SYMBOL0x00000000u ) {
1449 *gc = true1;
1450 return false0;
1451 }
1452 return true1;
1453 }
1454
1455 if (lbm_is_symbol(p)) {
1456 if (p == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return true1;
1457 return (p == e);
1458 }
1459 if (lbm_is_cons(p) &&
1460 lbm_is_cons(e) ) {
1461
1462 lbm_value headp, tailp;
1463 lbm_value heade, taile;
1464 get_car_and_cdr(p, &headp, &tailp);
1465 get_car_and_cdr(e, &heade, &taile); // Static analysis warns, but execution does not
1466 // past this point unless head and tail get initialized.
1467 if (!match(headp, heade, env, gc)) {
1468 return false0;
1469 }
1470 return match (tailp, taile, env, gc);
1471 }
1472 return struct_eq(p, e);
1473}
1474
1475// Find match is not very picky about syntax.
1476// A completely malformed recv form is most likely to
1477// just return no_match.
1478static int find_match(lbm_value plist, lbm_value *earr, lbm_uint num, lbm_value *e, lbm_value *env) {
1479
1480 // A pattern list is a list of pattern, expression lists.
1481 // ( (p1 e1) (p2 e2) ... (pn en))
1482 lbm_value curr_p = plist;
1483 int n = 0;
1484 bool_Bool gc = false0;
1485 for (int i = 0; i < (int)num; i ++ ) {
1486 lbm_value curr_e = earr[i];
1487 while (!lbm_is_symbol_nil(curr_p)) {
1488 lbm_value me = get_car(curr_p);
1489 if (match(get_car(me), curr_e, env, &gc)) {
1490 if (gc) return FM_NEED_GC-1;
1491 *e = get_cadr(me);
1492
1493 if (!lbm_is_symbol_nil(get_cadr(get_cdr(me)))) {
1494 return FM_PATTERN_ERROR-3;
1495 }
1496 return n;
1497 }
1498 curr_p = get_cdr(curr_p);
1499 }
1500 curr_p = plist; /* search all patterns against next exp */
1501 n ++;
1502 }
1503
1504 return FM_NO_MATCH-2;
1505}
1506
1507/****************************************************/
1508/* Garbage collection */
1509
1510static void mark_context(eval_context_t *ctx, void *arg1, void *arg2) {
1511 (void) arg1;
1512 (void) arg2;
1513 lbm_value roots[3] = {ctx->curr_exp, ctx->program, ctx->r };
1514 lbm_gc_mark_env(ctx->curr_env);
1515 lbm_gc_mark_roots(roots, 3);
1516 lbm_gc_mark_roots(ctx->mailbox, ctx->num_mail);
1517 lbm_gc_mark_aux(ctx->K.data, ctx->K.sp);
1518}
1519
1520static int gc(void) {
1521 if (ctx_running) {
1522 ctx_running->state = ctx_running->state | LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1523 }
1524
1525 gc_requested = false0;
1526 lbm_gc_state_inc();
1527
1528 // The freelist should generally be NIL when GC runs.
1529 lbm_nil_freelist();
1530 lbm_value *env = lbm_get_global_env();
1531 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
1532 lbm_gc_mark_env(env[i]);
1533 }
1534
1535 mutex_lock(&qmutex); // Lock the queues.
1536 // Any concurrent messing with the queues
1537 // while doing GC cannot possibly be good.
1538 queue_iterator_nm(&queue, mark_context, NULL((void*)0), NULL((void*)0));
1539 queue_iterator_nm(&blocked, mark_context, NULL((void*)0), NULL((void*)0));
1540
1541 if (ctx_running) {
1542 mark_context(ctx_running, NULL((void*)0), NULL((void*)0));
1543 }
1544 mutex_unlock(&qmutex);
1545
1546#ifdef VISUALIZE_HEAP
1547 heap_vis_gen_image();
1548#endif
1549
1550 int r = lbm_gc_sweep_phase();
1551 lbm_heap_new_freelist_length();
1552
1553 if (ctx_running) {
1554 ctx_running->state = ctx_running->state & ~LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1555 }
1556 return r;
1557}
1558
1559int lbm_perform_gc(void) {
1560 return gc();
1561}
1562
1563/****************************************************/
1564/* Evaluation functions */
1565
1566
1567static void eval_symbol(eval_context_t *ctx) {
1568 lbm_uint s = lbm_dec_sym(ctx->curr_exp);
1569 if (s >= RUNTIME_SYMBOLS_START0x40000) {
1570 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1571 if (lbm_env_lookup_b(&res, ctx->curr_exp, ctx->curr_env) ||
1572 lbm_global_env_lookup(&res, ctx->curr_exp)) {
1573 ctx->r = res;
1574 ctx->app_cont = true1;
1575 return;
1576 }
1577 // Dynamic load attempt
1578 // Only symbols of kind RUNTIME can be dynamically loaded.
1579 const char *sym_str = lbm_get_name_by_symbol(s);
1580 const char *code_str = NULL((void*)0);
1581 if (!dynamic_load_callback(sym_str, &code_str)) {
1582 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), ctx->curr_exp);
1583 }
1584 lbm_value *sptr = stack_reserve(ctx, 3);
1585 sptr[0] = ctx->curr_exp;
1586 sptr[1] = ctx->curr_env;
1587 sptr[2] = RESUME(((12) << 2) | 0xF8000001u);
1588
1589 lbm_value chan;
1590 if (!create_string_channel((char *)code_str, &chan)) {
1591 gc();
1592 if (!create_string_channel((char *)code_str, &chan)) {
1593 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1594 }
1595 }
1596
1597 lbm_value loader;
1598 WITH_GC_RMBR_1(loader, lbm_heap_allocate_list_init(2,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1599 ENC_SYM_READ,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1600 chan), chan)(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} };
1601 lbm_value evaluator;
1602 WITH_GC_RMBR_1(evaluator, lbm_heap_allocate_list_init(2,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1603 ENC_SYM_EVAL,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1604 loader), loader)(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } };
1605 ctx->curr_exp = evaluator;
1606 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // dynamics should be evaluable in empty local env
1607 } else {
1608 //special symbols and extensions can be handled the same way.
1609 ctx->r = ctx->curr_exp;
1610 ctx->app_cont = true1;
1611 }
1612}
1613
1614static void eval_quote(eval_context_t *ctx) {
1615 ctx->r = get_cadr(ctx->curr_exp);
1616 ctx->app_cont = true1;
1617}
1618
1619static void eval_selfevaluating(eval_context_t *ctx) {
1620 ctx->r = ctx->curr_exp;
1621 ctx->app_cont = true1;
1622}
1623
1624static void eval_progn(eval_context_t *ctx) {
1625 lbm_value exps = get_cdr(ctx->curr_exp);
1626
1627 if (lbm_is_cons(exps)) {
1628 lbm_uint *sptr = stack_reserve(ctx, 4);
1629 sptr[0] = ctx->curr_env; // env to restore between expressions in progn
1630 sptr[1] = lbm_enc_u(0); // Has env been copied (needed for progn local bindings)
1631 sptr[3] = PROGN_REST(((4) << 2) | 0xF8000001u);
1632 get_car_and_cdr(exps, &ctx->curr_exp, &sptr[2]);
1633 if (lbm_is_symbol(sptr[2])) /* The only symbol it can be is nil */
1634 lbm_stack_drop(&ctx->K, 4);
1635 } else if (lbm_is_symbol_nil(exps)) {
1636 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1637 ctx->app_cont = true1;
1638 } else {
1639 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1640 }
1641}
1642
1643static void eval_atomic(eval_context_t *ctx) {
1644 if (is_atomic) {
1645 lbm_set_error_reason("Atomic blocks cannot be nested!");
1646 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1647 }
1648 stack_reserve(ctx, 1)[0] = EXIT_ATOMIC(((14) << 2) | 0xF8000001u);
1649 is_atomic ++;
1650 eval_progn(ctx);
1651}
1652
1653/* (call-cc (lambda (k) .... )) */
1654static void eval_callcc(eval_context_t *ctx) {
1655 lbm_value cont_array;
1656 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1657 gc();
1658 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1659 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1660 return; // dead return but static analysis doesn't know :)
1661 }
1662 }
1663 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(cont_array);
1664 memcpy(arr->data, ctx->K.data, ctx->K.sp * sizeof(lbm_uint));
1665
1666 lbm_value acont = cons_with_gc(ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u), cont_array, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1667 lbm_value arg_list = cons_with_gc(acont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1668 // Go directly into application evaluation without passing go
1669 lbm_uint *sptr = stack_reserve(ctx, 3);
1670 sptr[0] = ctx->curr_env;
1671 sptr[1] = arg_list;
1672 sptr[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
1673 ctx->curr_exp = get_cadr(ctx->curr_exp);
1674}
1675
1676// (define sym exp)
1677#define KEY1 1
1678#define VAL2 2
1679static void eval_define(eval_context_t *ctx) {
1680 lbm_value parts[3];
1681 lbm_value rest = extract_n(ctx->curr_exp, parts, 3);
1682 lbm_uint *sptr = stack_reserve(ctx, 2);
1683 if (lbm_is_symbol(parts[KEY1]) && lbm_is_symbol_nil(rest)) {
1684 lbm_uint sym_val = lbm_dec_sym(parts[KEY1]);
1685 sptr[0] = parts[KEY1];
1686 if (sym_val >= RUNTIME_SYMBOLS_START0x40000) {
1687 sptr[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
1688 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02) {
1689 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
1690 }
1691 ctx->curr_exp = parts[VAL2];
1692 return;
1693 }
1694 }
1695 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
1696}
1697
1698
1699/* Eval lambda is cheating, a lot! It does this
1700 for performance reasons. The cheats are that
1701 1. When closure is created, a reference to the local env
1702 in which the lambda was evaluated is added to the closure.
1703 Ideally it should have created a list of free variables in the function
1704 and then looked up the values of these creating a new environment.
1705 2. The global env is considered global constant. As there is no copying
1706 of environment bindings into the closure, undefine may break closures.
1707
1708 Correct closure creation is a lot more expensive than what happens here.
1709 However, one can try to write programs in such a way that closures are created
1710 seldomly. If one does that the space-usage benefits of "correct" closures
1711 may outweigh the performance gain of "incorrect" ones.
1712
1713 some obscure programs such as test_setq_local_closure.lisp does not
1714 work properly due to this cheating.
1715 */
1716// (lambda param-list body-exp) -> (closure param-list body-exp env)
1717static void eval_lambda(eval_context_t *ctx) {
1718 lbm_value vals[3];
1719 extract_n(ctx->curr_exp, vals, 3);
1720 ctx->r = allocate_closure(vals[1],vals[2], ctx->curr_env);
1721#ifdef CLEAN_UP_CLOSURES
1722 lbm_uint sym_id = 0;
1723 if (clean_cl_env_symbol) {
1724 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1725 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1726 ctx->curr_exp = app;
1727 } else if (lbm_get_symbol_by_name("clean-cl-env", &sym_id)) {
1728 clean_cl_env_symbol = lbm_enc_sym(sym_id);
1729 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1730 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1731 ctx->curr_exp = app;
1732 } else {
1733 ctx->app_cont = true1;
1734 }
1735#else
1736 ctx->app_cont = true1;
1737#endif
1738}
1739
1740// (if cond-expr then-expr else-expr)
1741static void eval_if(eval_context_t *ctx) {
1742 lbm_value cdr = get_cdr(ctx->curr_exp);
1743 lbm_value *sptr = stack_reserve(ctx, 3);
1744 sptr[0] = get_cdr(cdr);
1745 sptr[1] = ctx->curr_env;
1746 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1747 ctx->curr_exp = get_car(cdr);
1748}
1749
1750// (cond (cond-expr-1 expr-1)
1751// ...
1752// (cond-expr-N expr-N))
1753static void eval_cond(eval_context_t *ctx) {
1754 lbm_value cond1[2];
1755 lbm_value rest_conds = extract_n(ctx->curr_exp, cond1, 2);
1756
1757 // end recursion at (cond )
1758 if (lbm_is_symbol_nil(cond1[1])) {
1759 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1760 ctx->app_cont = true1;
1761 } else {
1762 // Cond is one of the few places where a bit of syntax checking takes place at runtime..
1763 // Maybe dont bother?
1764 lbm_uint len = lbm_list_length(cond1[1]);
1765 if (len != 2) {
1766 lbm_set_error_reason("Incorrect syntax in cond");
1767 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1768 }
1769 lbm_value cond_expr[2];
1770 extract_n(cond1[1], cond_expr, 2);
1771 lbm_value rest;
1772 WITH_GC(rest, lbm_heap_allocate_list_init(2,(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1773 cond_expr[1], // Then branch(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1774 cons_with_gc(ENC_SYM_COND, rest_conds , ENC_SYM_NIL)))(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
1775 lbm_value *sptr = stack_reserve(ctx, 3);
1776 sptr[0] = rest;
1777 sptr[1] = ctx->curr_env;
1778 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1779 ctx->curr_exp = cond_expr[0]; //condition;
1780 }
1781}
1782
1783static void eval_app_cont(eval_context_t *ctx) {
1784 lbm_stack_drop(&ctx->K, 1);
1785 ctx->app_cont = true1;
1786}
1787
1788// Create a named location in an environment to later receive a value.
1789static binding_location_status create_binding_location_internal(lbm_value key, lbm_value *env) {
1790
1791 if (lbm_is_symbol(key) &&
1792 (key == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u) ||
1793 key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)))
1794 return BL_OK;
1795
1796 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) { // default case
1797 lbm_value binding;
1798 lbm_value new_env_tmp;
1799 binding = lbm_cons(key, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1800 new_env_tmp = lbm_cons(binding, *env);
1801 if (lbm_is_symbol(binding) || lbm_is_symbol(new_env_tmp)) {
1802 return BL_NO_MEMORY;
1803 }
1804 *env = new_env_tmp;
1805 } else if (lbm_is_cons(key)) { // deconstruct case
1806 int r = create_binding_location_internal(get_car(key), env);
1807 if (r == BL_OK) {
1808 r = create_binding_location_internal(get_cdr(key), env);
1809 }
1810 return r;
1811 }
1812 return BL_OK;
1813}
1814
1815static void create_binding_location(lbm_value key, lbm_value *env) {
1816
1817 lbm_value env_tmp = *env;
1818 binding_location_status r = create_binding_location_internal(key, &env_tmp);
1819 if (r != BL_OK) {
1820 if (r == BL_NO_MEMORY) {
1821 env_tmp = *env;
1822 lbm_gc_mark_phase(env_tmp);
1823 gc();
1824 r = create_binding_location_internal(key, &env_tmp);
1825 }
1826 switch(r) {
1827 case BL_OK:
1828 break;
1829 case BL_NO_MEMORY:
1830 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1831 break;
1832 case BL_INCORRECT_KEY:
1833 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
1834 break;
1835 }
1836 }
1837 *env = env_tmp;
1838}
1839
1840static void let_bind_values_eval(lbm_value binds, lbm_value exp, lbm_value env, eval_context_t *ctx) {
1841
1842 if (!lbm_is_cons(binds)) {
1843 // binds better be nil or there is a programmer error.
1844 ctx->curr_exp = exp;
1845 return;
1846 }
1847
1848 // Preallocate binding locations.
1849 lbm_value curr = binds;
1850 while (lbm_is_cons(curr)) {
1851 lbm_value new_env_tmp = env;
1852 lbm_value car_curr, cdr_curr;
1853 get_car_and_cdr(curr, &car_curr, &cdr_curr);
1854 lbm_value key = get_car(car_curr);
1855 create_binding_location(key, &new_env_tmp);
1856 env = new_env_tmp;
1857 curr = cdr_curr;
1858 }
1859
1860 lbm_value car_binds;
1861 lbm_value cdr_binds;
1862 get_car_and_cdr(binds, &car_binds, &cdr_binds);
1863 lbm_value key_val[2];
1864 extract_n(car_binds, key_val, 2);
1865
1866 lbm_uint *sptr = stack_reserve(ctx, 5);
1867 sptr[0] = exp;
1868 sptr[1] = cdr_binds;
1869 sptr[2] = env;
1870 sptr[3] = key_val[0];
1871 sptr[4] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
1872 ctx->curr_exp = key_val[1];
1873 ctx->curr_env = env;
1874}
1875
1876// (var x (...)) - local binding inside of an progn
1877// var has to take, place root-level nesting within progn.
1878// (progn ... (var a 10) ...) OK!
1879// (progn ... (something (var a 10)) ... ) NOT OK!
1880/* progn stack
1881 sp-4 : env
1882 sp-3 : 0
1883 sp-2 : rest
1884 sp-1 : PROGN_REST
1885*/
1886static void eval_var(eval_context_t *ctx) {
1887
1888 if (ctx->K.sp >= 4) { // Possibly in progn
1889 lbm_value sv = ctx->K.data[ctx->K.sp - 1];
1890 if (IS_CONTINUATION(sv)(((sv) & 0xF8000001u) == 0xF8000001u) && (sv == PROGN_REST(((4) << 2) | 0xF8000001u))) {
1891 lbm_uint sp = ctx->K.sp;
1892 uint32_t is_copied = lbm_dec_as_u32(ctx->K.data[sp-3]);
1893 if (is_copied == 0) {
1894 lbm_value env;
1895 WITH_GC(env, lbm_env_copy_spine(ctx->K.data[sp-4]))(env) = (lbm_env_copy_spine(ctx->K.data[sp-4])); if (lbm_is_symbol_merror
((env))) { gc(); (env) = (lbm_env_copy_spine(ctx->K.data[sp
-4])); if (lbm_is_symbol_merror((env))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1896 ctx->K.data[sp-3] = lbm_enc_u(1);
1897 ctx->K.data[sp-4] = env;
1898 }
1899 lbm_value new_env = ctx->K.data[sp-4];
1900 lbm_value args = get_cdr(ctx->curr_exp);
1901 lbm_value key = get_car(args);
1902 create_binding_location(key, &new_env);
1903 ctx->K.data[sp-4] = new_env;
1904
1905 lbm_value v_exp = get_cadr(args);
1906 lbm_value *sptr = stack_reserve(ctx, 3);
1907 sptr[0] = new_env;
1908 sptr[1] = key;
1909 sptr[2] = PROGN_VAR(((29) << 2) | 0xF8000001u);
1910 // Activating the new environment before the evaluation of the value to be bound,
1911 // means that other variables with same name will be shadowed already in the value
1912 // body.
1913 // The way closures work, the var-variable needs to be in scope during val evaluation
1914 // for a recursive closure to be possible.
1915 ctx->curr_env = new_env;
1916 ctx->curr_exp = v_exp;
1917 return;
1918 }
1919 }
1920 lbm_set_error_reason((char*)lbm_error_str_var_outside_progn);
1921 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1922}
1923
1924// (setq x (...)) - same as (set 'x (...)) or (setvar 'x (...))
1925static void eval_setq(eval_context_t *ctx) {
1926 lbm_value parts[3];
1927 extract_n(ctx->curr_exp, parts, 3);
1928 lbm_value *sptr = stack_reserve(ctx, 3);
1929 sptr[0] = ctx->curr_env;
1930 sptr[1] = parts[1];
1931 sptr[2] = SETQ(((30) << 2) | 0xF8000001u);
1932 ctx->curr_exp = parts[2];
1933}
1934
1935static void eval_move_to_flash(eval_context_t *ctx) {
1936 lbm_value args = get_cdr(ctx->curr_exp);
1937 lbm_value *sptr = stack_reserve(ctx,2);
1938 sptr[0] = args;
1939 sptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
1940 ctx->app_cont = true1;
1941}
1942
1943// (loop list-of-local-bindings
1944// condition-exp
1945// body-exp)
1946static void eval_loop(eval_context_t *ctx) {
1947 lbm_value env = ctx->curr_env;
1948 lbm_value parts[3];
1949 extract_n(get_cdr(ctx->curr_exp), parts, 3);
1950 lbm_value *sptr = stack_reserve(ctx, 3);
1951 sptr[0] = parts[LOOP_BODY2];
1952 sptr[1] = parts[LOOP_COND1];
1953 sptr[2] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
1954 let_bind_values_eval(parts[LOOP_BINDS0], parts[LOOP_COND1], env, ctx);
1955}
1956
1957/* (trap expression)
1958 *
1959 * suggested use:
1960 * (match (trap expression)
1961 * ((exit-error (? err)) (error-handler err))
1962 * ((exit-ok (? v)) (value-handler v)))
1963 */
1964static void eval_trap(eval_context_t *ctx) {
1965
1966 lbm_value expr = get_cadr(ctx->curr_exp);
1967 lbm_value retval;
1968 WITH_GC(retval, lbm_heap_allocate_list(2))(retval) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((retval))) { gc(); (retval) = (lbm_heap_allocate_list(2)); if
(lbm_is_symbol_merror((retval))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1969 lbm_set_car(retval, ENC_SYM_EXIT_OK(((0x3000B) << 4) | 0x00000000u)); // Assume things will go well.
1970 lbm_uint *sptr = stack_reserve(ctx,3);
1971 sptr[0] = retval;
1972 sptr[1] = ctx->flags;
1973 sptr[2] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1974 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10;
1975 ctx->curr_exp = expr;
1976}
1977
1978// (let list-of-binding s
1979// body-exp)
1980static void eval_let(eval_context_t *ctx) {
1981 lbm_value env = ctx->curr_env;
1982 lbm_value parts[3];
1983 extract_n(ctx->curr_exp, parts, 3);
1984 let_bind_values_eval(parts[1], parts[2], env, ctx);
1985}
1986
1987// (and exp0 ... expN)
1988static void eval_and(eval_context_t *ctx) {
1989 lbm_value rest = get_cdr(ctx->curr_exp);
1990 if (lbm_is_symbol_nil(rest)) {
1991 ctx->app_cont = true1;
1992 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1993 } else {
1994 lbm_value *sptr = stack_reserve(ctx, 3);
1995 sptr[0] = ctx->curr_env;
1996 sptr[1] = get_cdr(rest);
1997 sptr[2] = AND(((6) << 2) | 0xF8000001u);
1998 ctx->curr_exp = get_car(rest);
1999 }
2000}
2001
2002// (or exp0 ... expN)
2003static void eval_or(eval_context_t *ctx) {
2004 lbm_value rest = get_cdr(ctx->curr_exp);
2005 if (lbm_is_symbol_nil(rest)) {
2006 ctx->app_cont = true1;
2007 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2008 } else {
2009 lbm_value *sptr = stack_reserve(ctx, 3);
2010 sptr[0] = ctx->curr_env;
2011 sptr[1] = get_cdr(rest);
2012 sptr[2] = OR(((7) << 2) | 0xF8000001u);
2013 ctx->curr_exp = get_car(rest);
2014 }
2015}
2016
2017// Pattern matching
2018// format:
2019// (match e (pattern body)
2020// (pattern body)
2021// ... )
2022//
2023// There can be an optional pattern guard:
2024// (match e (pattern guard body)
2025// ... )
2026// a guard is a boolean expression.
2027// Guards make match, pattern matching more complicated
2028// than the recv pattern matching and requires staged execution
2029// via the continuation system rather than a while loop over a list.
2030static void eval_match(eval_context_t *ctx) {
2031
2032 lbm_value rest = get_cdr(ctx->curr_exp);
2033 if (lbm_type_of(rest) == LBM_TYPE_SYMBOL0x00000000u &&
2034 rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
2035 // Someone wrote the program (match)
2036 ctx->app_cont = true1;
2037 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2038 } else {
2039 lbm_value cdr_rest;
2040 get_car_and_cdr(rest, &ctx->curr_exp, &cdr_rest);
2041 lbm_value *sptr = stack_reserve(ctx, 3);
2042 sptr[0] = cdr_rest;
2043 sptr[1] = ctx->curr_env;
2044 sptr[2] = MATCH(((9) << 2) | 0xF8000001u);
2045 }
2046}
2047
2048static void receive_base(eval_context_t *ctx, lbm_value pats, float timeout_time, bool_Bool timeout) {
2049 if (ctx->num_mail == 0) {
2050 if (timeout) {
2051 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000), false0);
2052 } else {
2053 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1,0,false0);
2054 }
2055 } else {
2056 lbm_value *msgs = ctx->mailbox;
2057 lbm_uint num = ctx->num_mail;
2058
2059 if (lbm_is_symbol_nil(pats)) {
2060 /* A receive statement without any patterns */
2061 ctx->app_cont = true1;
2062 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2063 } else {
2064 /* The common case */
2065 lbm_value e;
2066 lbm_value new_env = ctx->curr_env;
2067 int n = find_match(pats, msgs, num, &e, &new_env);
2068 if (n == FM_NEED_GC-1) {
2069 gc();
2070 new_env = ctx->curr_env;
2071 n = find_match(pats, msgs, num, &e, &new_env);
2072 if (n == FM_NEED_GC-1) {
2073 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2074 }
2075 }
2076 if (n == FM_PATTERN_ERROR-3) {
2077 lbm_set_error_reason("Incorrect pattern format for recv");
2078 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),pats);
2079 } else if (n >= 0 ) { /* Match */
2080 mailbox_remove_mail(ctx, (lbm_uint)n);
2081 ctx->curr_env = new_env;
2082 ctx->curr_exp = e;
2083 } else { /* No match go back to sleep */
2084 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
2085 if (timeout) {
2086 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2,S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000),false0);
2087 } else {
2088 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,false0);
2089 }
2090 }
2091 }
2092 }
2093 return;
2094}
2095
2096static void eval_receive_timeout(eval_context_t *ctx) {
2097 if (is_atomic) {
2098 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2099 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2100 }
2101 lbm_value timeout_val = get_cadr(ctx->curr_exp);
2102 if (!lbm_is_number(timeout_val)) {
2103 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2104 }
2105 float timeout_time = lbm_dec_as_float(timeout_val);
2106 lbm_value pats = get_cdr(get_cdr(ctx->curr_exp));
2107 receive_base(ctx, pats, timeout_time, true1);
2108}
2109
2110// Receive
2111// (recv (pattern expr)
2112// (pattern expr))
2113static void eval_receive(eval_context_t *ctx) {
2114
2115 if (is_atomic) {
2116 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2117 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
2118 }
2119 lbm_value pats = get_cdr(ctx->curr_exp);
2120 receive_base(ctx, pats, 0, false0);
2121}
2122
2123/*********************************************************/
2124/* Continuation functions */
2125
2126/* cont_set_global_env
2127 sp-1 : Key-symbol
2128 */
2129static void cont_set_global_env(eval_context_t *ctx){
2130
2131 lbm_value key;
2132 lbm_value val = ctx->r;
2133
2134 lbm_pop(&ctx->K, &key);
2135 lbm_uint dec_key = lbm_dec_sym(key);
2136 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
2137 lbm_value *global_env = lbm_get_global_env();
2138 lbm_uint orig_env = global_env[ix_key];
2139 lbm_value new_env;
2140 // A key is a symbol and should not need to be remembered.
2141 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2142
2143 global_env[ix_key] = new_env;
2144 ctx->r = val;
2145
2146 ctx->app_cont = true1;
2147
2148 return;
2149}
2150
2151static void cont_resume(eval_context_t *ctx) {
2152 lbm_pop_2(&ctx->K, &ctx->curr_env, &ctx->curr_exp);
2153}
2154
2155static void cont_progn_rest(eval_context_t *ctx) {
2156 lbm_value *sptr = get_stack_ptr(ctx, 3);
2157
2158 lbm_value rest = sptr[2];
2159 lbm_value env = sptr[0];
2160
2161 lbm_value rest_car, rest_cdr;
2162 get_car_and_cdr(rest, &rest_car, &rest_cdr);
2163 ctx->curr_exp = rest_car;
2164 ctx->curr_env = env;
2165 if (lbm_is_symbol_nil(rest_cdr)) {
2166 // allow for tail recursion
2167 lbm_stack_drop(&ctx->K, 3);
2168 } else {
2169 sptr[2] = rest_cdr;
2170 stack_reserve(ctx, 1)[0] = PROGN_REST(((4) << 2) | 0xF8000001u);
2171 }
2172}
2173
2174static void cont_wait(eval_context_t *ctx) {
2175
2176 lbm_value cid_val;
2177 lbm_pop(&ctx->K, &cid_val);
2178 lbm_cid cid = (lbm_cid)lbm_dec_i(cid_val);
2179
2180 bool_Bool exists = false0;
2181
2182 lbm_blocked_iterator(context_exists, &cid, &exists);
2183 lbm_running_iterator(context_exists, &cid, &exists);
2184
2185 if (ctx_running->id == cid) {
2186 exists = true1;
2187 }
2188
2189 if (exists) {
2190 lbm_value *sptr = stack_reserve(ctx, 2);
2191 sptr[0] = lbm_enc_i(cid);
2192 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2193 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2194 ctx->app_cont = true1;
2195 yield_ctx(50000);
2196 } else {
2197 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2198 ctx->app_cont = true1;
2199 }
2200}
2201
2202static lbm_value perform_setvar(lbm_value key, lbm_value val, lbm_value env) {
2203
2204 lbm_uint s = lbm_dec_sym(key);
2205 if (s >= RUNTIME_SYMBOLS_START0x40000) {
2206 lbm_value new_env = lbm_env_modify_binding(env, key, val);
2207 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2208 lbm_uint ix_key = lbm_dec_sym(key) & GLOBAL_ENV_MASK0x1F;
2209 lbm_value *glob_env = lbm_get_global_env();
2210 new_env = lbm_env_modify_binding(glob_env[ix_key], key, val);
2211 glob_env[ix_key] = new_env;
2212 }
2213 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2214 lbm_set_error_reason((char*)lbm_error_str_variable_not_bound);
2215 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), key);
2216 }
2217 return val;
2218 }
2219 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2220 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // unreachable
2221}
2222
2223static void apply_setvar(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2224 if (nargs == 2 && lbm_is_symbol(args[0])) {
2225 lbm_value res;
2226 WITH_GC(res, perform_setvar(args[0], args[1], ctx->curr_env))(res) = (perform_setvar(args[0], args[1], ctx->curr_env));
if (lbm_is_symbol_merror((res))) { gc(); (res) = (perform_setvar
(args[0], args[1], ctx->curr_env)); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2227 ctx->r = args[1];
2228 lbm_stack_drop(&ctx->K, nargs+1);
2229 ctx->app_cont = true1;
2230 } else {
2231 if (nargs == 2) lbm_set_error_reason((char*)lbm_error_str_incorrect_arg);
2232 else lbm_set_error_reason((char*)lbm_error_str_num_args);
2233 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2234 }
2235}
2236
2237static void apply_read_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, bool_Bool program, bool_Bool incremental) {
2238 if (nargs == 1) {
2239 lbm_value chan = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2240 if (lbm_type_of_functional(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2241 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2242 gc();
2243 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2244 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2245 }
2246 }
2247 } else if (lbm_type_of(args[0]) == LBM_TYPE_CHANNEL0x90000000u) {
2248 chan = args[0];
2249 } else {
2250 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2251 }
2252 lbm_value *sptr = get_stack_ptr(ctx, 2);
2253
2254 // If we are inside a reader, its settings are stored.
2255 sptr[0] = lbm_enc_u(ctx->flags); // flags stored.
2256 sptr[1] = chan;
2257 lbm_value *rptr = stack_reserve(ctx,1);
2258 rptr[0] = READ_DONE(((20) << 2) | 0xF8000001u);
2259
2260 // Each reader starts in a fresh situation
2261 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
2262
2263 if (program) {
2264 if (incremental) {
2265 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2266 lbm_value *rptr1 = stack_reserve(ctx,3);
2267 rptr1[0] = chan;
2268 rptr1[1] = ctx->curr_env;
2269 rptr1[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
2270 } else {
2271 ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2272 lbm_value *rptr1 = stack_reserve(ctx,4);
2273 rptr1[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2274 rptr1[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2275 rptr1[2] = chan;
2276 rptr1[3] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
2277 }
2278 }
2279 rptr = stack_reserve(ctx,3); // reuse of variable rptr
2280 rptr[0] = chan;
2281 rptr[1] = lbm_enc_u(1);
2282 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
2283 ctx->app_cont = true1;
2284 } else {
2285 lbm_set_error_reason((char*)lbm_error_str_num_args);
2286 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2287 }
2288}
2289
2290static void apply_read_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2291 apply_read_base(args,nargs,ctx,true1,false0);
2292}
2293
2294static void apply_read_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2295 apply_read_base(args,nargs,ctx,true1,true1);
2296}
2297
2298static void apply_read(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2299 apply_read_base(args,nargs,ctx,false0,false0);
2300}
2301
2302static void apply_spawn_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, uint32_t context_flags) {
2303
2304 lbm_uint stack_size = EVAL_CPS_DEFAULT_STACK_SIZE256;
2305 lbm_uint closure_pos = 0;
2306 char *name = NULL((void*)0);
2307
2308 if (nargs >= 1 &&
2309 lbm_is_closure(args[0])) {
2310 closure_pos = 0;
2311 } else if (nargs >= 2 &&
2312 lbm_is_number(args[0]) &&
2313 lbm_is_closure(args[1])) {
2314 stack_size = lbm_dec_as_u32(args[0]);
2315 closure_pos = 1;
2316 } else if (nargs >= 2 &&
2317 lbm_is_array_r(args[0]) &&
2318 lbm_is_closure(args[1])) {
2319 name = lbm_dec_str(args[0]);
2320 closure_pos = 1;
2321 }else if (nargs >= 3 &&
2322 lbm_is_array_r(args[0]) &&
2323 lbm_is_number(args[1]) &&
2324 lbm_is_closure(args[2])) {
2325 stack_size = lbm_dec_as_u32(args[1]);
2326 closure_pos = 2;
2327 name = lbm_dec_str(args[0]);
2328 } else {
2329 if (context_flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01)
2330 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN_TRAP(((0x30005) << 4) | 0x00000000u));
2331 else
2332 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN(((0x30004) << 4) | 0x00000000u));
2333 }
2334
2335 lbm_value cl[3];
2336 extract_n(get_cdr(args[closure_pos]), cl, 3);
2337 lbm_value curr_param = cl[CLO_PARAMS0];
2338 lbm_value clo_env = cl[CLO_ENV2];
2339 lbm_uint i = closure_pos + 1;
2340 while (lbm_is_cons(curr_param) && i <= nargs) {
2341 lbm_value entry = cons_with_gc(get_car(curr_param), args[i], clo_env);
2342 lbm_value aug_env = cons_with_gc(entry, clo_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2343 clo_env = aug_env;
2344 curr_param = get_cdr(curr_param);
2345 i ++;
2346 }
2347
2348 lbm_stack_drop(&ctx->K, nargs+1);
2349
2350 lbm_value program = cons_with_gc(cl[CLO_BODY1], ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), clo_env);
2351
2352 lbm_cid cid = lbm_create_ctx_parent(program,
2353 clo_env,
2354 stack_size,
2355 lbm_get_current_cid(),
2356 context_flags,
2357 name);
2358 ctx->r = lbm_enc_i(cid);
2359 ctx->app_cont = true1;
2360}
2361
2362static void apply_spawn(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2363 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00);
2364}
2365
2366static void apply_spawn_trap(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2367 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01);
2368}
2369
2370static void apply_yield(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2371 if (is_atomic) {
2372 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2373 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2374 }
2375 if (nargs == 1 && lbm_is_number(args[0])) {
2376 lbm_uint ts = lbm_dec_as_u32(args[0]);
2377 lbm_stack_drop(&ctx->K, nargs+1);
2378 yield_ctx(ts);
2379 } else {
2380 lbm_set_error_reason((char*)lbm_error_str_no_number);
2381 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2382 }
2383}
2384
2385static void apply_sleep(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2386 if (is_atomic) {
2387 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2388 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2389 }
2390 if (nargs == 1 && lbm_is_number(args[0])) {
2391 lbm_uint ts = (lbm_uint)(1000000.0f * lbm_dec_as_float(args[0]));
2392 lbm_stack_drop(&ctx->K, nargs+1);
2393 yield_ctx(ts);
2394 } else {
2395 lbm_set_error_reason((char*)lbm_error_str_no_number);
2396 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2397 }
2398}
2399
2400static void apply_wait(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2401 if (nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2402 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2403 lbm_value *sptr = get_stack_ptr(ctx, 2);
2404 sptr[0] = lbm_enc_i(cid);
2405 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2406 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2407 ctx->app_cont = true1;
2408 yield_ctx(50000);
2409 } else {
2410 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_WAIT(((0x30007) << 4) | 0x00000000u));
2411 }
2412}
2413
2414/* (eval expr)
2415 (eval env expr) */
2416static void apply_eval(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2417 if ( nargs == 1) {
2418 ctx->curr_exp = args[0];
2419 } else if (nargs == 2) {
2420 ctx->curr_exp = args[1];
2421 ctx->curr_env = args[0];
2422 } else {
2423 lbm_set_error_reason((char*)lbm_error_str_num_args);
2424 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL(((0x30008) << 4) | 0x00000000u));
2425 }
2426 lbm_stack_drop(&ctx->K, nargs+1);
2427}
2428
2429static void apply_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2430 int prg_pos = 0;
2431 if (nargs == 2) {
2432 prg_pos = 1;
2433 ctx->curr_env = args[0];
2434 }
2435 if (nargs == 1 || nargs == 2) {
2436 lbm_value prg = args[prg_pos];
2437 lbm_value app_cont;
2438 lbm_value app_cont_prg;
2439 lbm_value new_prg;
2440 lbm_value prg_copy;
2441
2442 int len = -1;
2443 WITH_GC(prg_copy, lbm_list_copy(&len, prg))(prg_copy) = (lbm_list_copy(&len, prg)); if (lbm_is_symbol_merror
((prg_copy))) { gc(); (prg_copy) = (lbm_list_copy(&len, prg
)); if (lbm_is_symbol_merror((prg_copy))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2444 lbm_stack_drop(&ctx->K, nargs+1);
2445
2446 if (ctx->K.sp > nargs+2) { // if there is a continuation
2447 app_cont = cons_with_gc(ENC_SYM_APP_CONT(((0x111) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2448 app_cont_prg = cons_with_gc(app_cont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2449 new_prg = lbm_list_append(app_cont_prg, ctx->program);
2450 new_prg = lbm_list_append(prg_copy, new_prg);
2451 } else {
2452 new_prg = lbm_list_append(prg_copy, ctx->program);
2453 }
2454 if (!lbm_is_list(new_prg)) {
2455 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2456 }
2457 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);
2458 ctx->program = get_cdr(new_prg);
2459 ctx->curr_exp = get_car(new_prg);
2460 } else {
2461 lbm_set_error_reason((char*)lbm_error_str_num_args);
2462 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2463 }
2464}
2465
2466static void apply_send(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2467 if (nargs == 2) {
2468 if (lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2469 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2470 lbm_value msg = args[1];
2471 lbm_value status = lbm_find_receiver_and_send(cid, msg);
2472 /* return the status */
2473 lbm_stack_drop(&ctx->K, nargs+1);
2474 ctx->r = status;
2475 ctx->app_cont = true1;
2476 } else {
2477 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2478 }
2479 } else {
2480 lbm_set_error_reason((char*)lbm_error_str_num_args);
2481 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2482 }
2483}
2484
2485static void apply_ok(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2486 lbm_value ok_val = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2487 if (nargs >= 1) {
2488 ok_val = args[0];
2489 }
2490 ctx->r = ok_val;
2491 ok_ctx();
2492}
2493
2494static void apply_error(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2495 (void) ctx;
2496 lbm_value err_val = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
2497 if (nargs >= 1) {
2498 err_val = args[0];
2499 }
2500 error_at_ctx(err_val, ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
2501}
2502
2503// (map f arg-list)
2504static void apply_map(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2505 if (nargs == 2 && lbm_is_cons(args[1])) {
2506 lbm_value *sptr = get_stack_ptr(ctx, 3);
2507
2508 lbm_value f = args[0];
2509 lbm_value h = get_car(args[1]);
2510 lbm_value t = get_cdr(args[1]);
2511
2512 lbm_value appli_1;
2513 lbm_value appli;
2514 WITH_GC(appli_1, lbm_heap_allocate_list(2))(appli_1) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli_1))) { gc(); (appli_1) = (lbm_heap_allocate_list(2));
if (lbm_is_symbol_merror((appli_1))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2515 WITH_GC_RMBR_1(appli, lbm_heap_allocate_list(2), appli_1)(appli) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli))) { lbm_gc_mark_phase(appli_1); gc(); (appli) = (lbm_heap_allocate_list
(2)); if (lbm_is_symbol_merror((appli))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2516
2517 lbm_value appli_0 = get_cdr(appli_1);
2518
2519 lbm_set_car_and_cdr(appli_0, h, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2520 lbm_set_car(appli_1, ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u));
2521
2522 lbm_set_car_and_cdr(get_cdr(appli), appli_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2523 lbm_set_car(appli, f);
2524
2525 lbm_value elt = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), appli);
2526 sptr[0] = t; // reuse stack space
2527 sptr[1] = ctx->curr_env;
2528 sptr[2] = elt;
2529 lbm_value *rptr = stack_reserve(ctx,4);
2530 rptr[0] = elt;
2531 rptr[1] = appli;
2532 rptr[2] = appli_0;
2533 rptr[3] = MAP(((26) << 2) | 0xF8000001u);
2534 ctx->curr_exp = appli;
2535 } else if (nargs == 2 && lbm_is_symbol_nil(args[1])) {
2536 lbm_stack_drop(&ctx->K, 3);
2537 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2538 ctx->app_cont = true1;
2539 return;
2540 } else {
2541 lbm_set_error_reason((char*)lbm_error_str_num_args);
2542 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_MAP(((0x3000D) << 4) | 0x00000000u));
2543 }
2544}
2545
2546static void apply_reverse(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2547 if (nargs == 1 && lbm_is_list(args[0])) {
2548 lbm_value curr = args[0];
2549
2550 lbm_value new_list = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2551 while (lbm_is_cons(curr)) {
2552 lbm_value tmp = cons_with_gc(get_car(curr), new_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2553 new_list = tmp;
2554 curr = get_cdr(curr);
2555 }
2556 lbm_stack_drop(&ctx->K, 2);
2557 ctx->r = new_list;
2558 ctx->app_cont = true1;
2559 } else {
2560 lbm_set_error_reason("Reverse requires a list argument");
2561 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_REVERSE(((0x3000E) << 4) | 0x00000000u));
2562 }
2563}
2564
2565static void apply_flatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2566 if (nargs == 1) {
2567
2568 lbm_value v = flatten_value(args[0]);
2569 if ( v == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)) {
2570 gc();
2571 v = flatten_value(args[0]);
2572 }
2573
2574 if (lbm_is_symbol(v)) {
2575 error_at_ctx(v, ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2576 } else {
2577 lbm_stack_drop(&ctx->K, 2);
2578 ctx->r = v;
2579 ctx->app_cont = true1;
2580 }
2581 return;
2582 }
2583 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2584}
2585
2586static void apply_unflatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2587 if(nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2588 lbm_array_header_t *array;
2589 array = (lbm_array_header_t *)get_car(args[0]);
2590
2591 lbm_flat_value_t fv;
2592 fv.buf = (uint8_t*)array->data;
2593 fv.buf_size = array->size;
2594 fv.buf_pos = 0;
2595
2596 lbm_value res;
2597
2598 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2599 if (lbm_unflatten_value(&fv, &res)) {
2600 ctx->r = res;
2601 }
2602 lbm_stack_drop(&ctx->K, 2);
2603 ctx->app_cont = true1;
2604 return;
2605 }
2606 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_UNFLATTEN(((0x30010) << 4) | 0x00000000u));
2607}
2608
2609static void apply_kill(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2610 if (nargs == 2 && lbm_is_number(args[0])) {
2611 lbm_cid cid = lbm_dec_as_i32(args[0]);
2612
2613 if (ctx->id == cid) {
2614 ctx->r = args[1];
2615 finish_ctx();
2616 return;
2617 }
2618 mutex_lock(&qmutex);
2619 eval_context_t *found = NULL((void*)0);
2620 found = lookup_ctx_nm(&blocked, cid);
2621 if (found)
2622 drop_ctx_nm(&blocked, found);
2623 else
2624 found = lookup_ctx_nm(&queue, cid);
2625 if (found)
2626 drop_ctx_nm(&queue, found);
2627
2628 if (found) {
2629 found->K.data[found->K.sp - 1] = KILL(((40) << 2) | 0xF8000001u);
2630 found->r = args[1];
2631 found->app_cont = true1;
2632 enqueue_ctx_nm(&queue,found);
2633 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2634 } else {
2635 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2636 }
2637 lbm_stack_drop(&ctx->K, 3);
2638 ctx->app_cont = true1;
2639 mutex_unlock(&qmutex);
2640 return;
2641 }
2642 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_KILL(((0x30011) << 4) | 0x00000000u));
2643}
2644
2645// (merge comparator list1 list2)
2646static void apply_merge(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2647 if (nargs == 3 && lbm_is_list(args[1]) && lbm_is_list(args[2])) {
2648
2649 if (!lbm_is_closure(args[0])) {
2650 lbm_value closure;
2651 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2652 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2653 lbm_value cl1 = lbm_cdr(closure);
2654 lbm_value par;
2655 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2656 lbm_set_car(cl1, par);
2657 lbm_value cl2 = lbm_cdr(cl1);
2658 lbm_value body;
2659 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2660 lbm_set_car(cl2, body);
2661 lbm_value cl3 = lbm_cdr(cl2);
2662 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2663
2664 // Replace operator on stack with closure and rest of the code is
2665 // compatible.
2666 args[0] = closure;
2667 }
2668
2669 // Copy input lists for functional behaviour at top-level
2670 // merge itself is in-place in the copied lists.
2671 lbm_value a;
2672 lbm_value b;
2673 int len_a = -1;
2674 int len_b = -1;
2675 WITH_GC(a, lbm_list_copy(&len_a, args[1]))(a) = (lbm_list_copy(&len_a, args[1])); if (lbm_is_symbol_merror
((a))) { gc(); (a) = (lbm_list_copy(&len_a, args[1])); if
(lbm_is_symbol_merror((a))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } };
2676 WITH_GC_RMBR_1(b, lbm_list_copy(&len_b, args[2]), a)(b) = (lbm_list_copy(&len_b, args[2])); if (lbm_is_symbol_merror
((b))) { lbm_gc_mark_phase(a); gc(); (b) = (lbm_list_copy(&
len_b, args[2])); if (lbm_is_symbol_merror((b))) { error_ctx(
(((0x23) << 4) | 0x00000000u)); } };
2677
2678 if (len_a == 0) {
2679 ctx->r = b;
2680 lbm_stack_drop(&ctx->K, 4);
2681 ctx->app_cont = true1;
2682 return;
2683 }
2684 if (len_b == 0) {
2685 ctx->r = a;
2686 lbm_stack_drop(&ctx->K, 4);
2687 ctx->app_cont = true1;
2688 return;
2689 }
2690
2691 args[1] = a; // keep safe by replacing the original on stack.
2692 args[2] = b;
2693
2694 lbm_value a_1 = a;
2695 lbm_value a_rest = lbm_cdr(a);
2696 lbm_value b_1 = b;
2697 lbm_value b_rest = lbm_cdr(b);
2698
2699 lbm_value cl[3]; // Comparator closure
2700 extract_n(lbm_cdr(args[0]), cl, 3);
2701 lbm_value cmp_env = cl[CLO_ENV2];
2702 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2703 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2704 lbm_uint len = lbm_list_length(cl[CLO_PARAMS0]);
2705 if (len == 2) {
2706 par1 = get_car(cl[CLO_PARAMS0]);
2707 par2 = get_cadr(cl[CLO_PARAMS0]);
2708 lbm_value new_env0;
2709 lbm_value new_env;
2710 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a_1)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a_1))); if (
lbm_is_symbol_merror((new_env0))) { gc(); (new_env0) = (lbm_env_set
(cmp_env, par1, lbm_car(a_1))); if (lbm_is_symbol_merror((new_env0
))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2711 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b_1)),new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1))); if (
lbm_is_symbol_merror((new_env))) { lbm_gc_mark_phase(new_env0
); gc(); (new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1
))); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2712 cmp_env = new_env;
2713 } else {
2714 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2715 }
2716 lbm_set_cdr(a_1, b_1);
2717 lbm_set_cdr(b_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2718 lbm_value cmp = cl[CLO_BODY1];
2719
2720 lbm_stack_drop(&ctx->K, 4); // TODO: Optimize drop 4 alloc 10 into alloc 6
2721 lbm_uint *sptr = stack_reserve(ctx, 10);
2722 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged list
2723 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged list
2724 sptr[2] = a_1;
2725 sptr[3] = a_rest;
2726 sptr[4] = b_rest;
2727 sptr[5] = cmp;
2728 sptr[6] = cmp_env;
2729 sptr[7] = par1;
2730 sptr[8] = par2;
2731 sptr[9] = MERGE_REST(((43) << 2) | 0xF8000001u);
2732 ctx->curr_exp = cl[CLO_BODY1];
2733 ctx->curr_env = cmp_env;
2734 return;
2735 }
2736 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MERGE(((0x30013) << 4) | 0x00000000u));
2737}
2738
2739// (sort comparator list)
2740static void apply_sort(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2741 if (nargs == 2 && lbm_is_list(args[1])) {
2742
2743 if (!lbm_is_closure(args[0])) {
2744 lbm_value closure;
2745 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2746 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2747 lbm_value cl1 = lbm_cdr(closure);
2748 lbm_value par;
2749 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2750 lbm_set_car(cl1, par);
2751 lbm_value cl2 = lbm_cdr(cl1);
2752 lbm_value body;
2753 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2754 lbm_set_car(cl2, body);
2755 lbm_value cl3 = lbm_cdr(cl2);
2756 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2757
2758 // Replace operator on stack with closure and rest of the code is
2759 // compatible.
2760 args[0] = closure;
2761 }
2762
2763 int len = -1;
2764 lbm_value list_copy;
2765 WITH_GC(list_copy, lbm_list_copy(&len, args[1]))(list_copy) = (lbm_list_copy(&len, args[1])); if (lbm_is_symbol_merror
((list_copy))) { gc(); (list_copy) = (lbm_list_copy(&len,
args[1])); if (lbm_is_symbol_merror((list_copy))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2766 if (len <= 1) {
2767 lbm_stack_drop(&ctx->K, 3);
2768 ctx->r = list_copy;
2769 ctx->app_cont = true1;
2770 return;
2771 }
2772
2773 args[1] = list_copy; // Keep safe, original replaced on stack.
2774
2775 // Take the headmost 2, 1-element sublists.
2776 lbm_value a = list_copy;
2777 lbm_value b = lbm_cdr(a);
2778 lbm_value rest = lbm_cdr(b);
2779 // Do not terminate b. keep rest of list safe from GC in the following
2780 // closure extraction.
2781 //lbm_set_cdr(a, b); // This is void
2782
2783 lbm_value cl[3]; // Comparator closure
2784 extract_n(lbm_cdr(args[0]), cl, 3);
2785 lbm_value cmp_env = cl[CLO_ENV2];
2786 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2787 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2788 lbm_uint cl_len = lbm_list_length(cl[CLO_PARAMS0]);
2789 if (cl_len == 2) {
2790 par1 = get_car(cl[CLO_PARAMS0]);
2791 par2 = get_cadr(cl[CLO_PARAMS0]);
2792 lbm_value new_env0;
2793 lbm_value new_env;
2794 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a))); if (lbm_is_symbol_merror
((new_env0))) { gc(); (new_env0) = (lbm_env_set(cmp_env, par1
, lbm_car(a))); if (lbm_is_symbol_merror((new_env0))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2795 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b)), new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { lbm_gc_mark_phase(new_env0); gc(); (new_env) =
(lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { error_ctx((((0x23) << 4) | 0x00000000u))
; } };
2796 cmp_env = new_env;
2797 } else {
2798 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2799 }
2800 lbm_value cmp = cl[CLO_BODY1];
2801
2802 // Terminate the comparator argument list.
2803 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2804
2805 lbm_stack_drop(&ctx->K, 3); //TODO: optimize drop 3, alloc 20 into alloc 17
2806 lbm_uint *sptr = stack_reserve(ctx, 20);
2807 sptr[0] = cmp;
2808 sptr[1] = cmp_env;
2809 sptr[2] = par1;
2810 sptr[3] = par2;
2811 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged accumulation of sublists
2812 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged accumulation of sublists
2813 sptr[6] = rest;
2814 sptr[7] = lbm_enc_i(1);
2815 sptr[8] = lbm_enc_i(len); //TODO: 28 bit i vs 32 bit i
2816 sptr[9] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
2817 sptr[10] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged sublist
2818 sptr[11] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged sublist
2819 sptr[12] = a;
2820 sptr[13] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no a_rest, 1 element lists in layer 1.
2821 sptr[14] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no b_rest, 1 element lists in layer 1.
2822 sptr[15] = cmp;
2823 sptr[16] = cmp_env;
2824 sptr[17] = par1;
2825 sptr[18] = par2;
2826 sptr[19] = MERGE_REST(((43) << 2) | 0xF8000001u);
2827 ctx->curr_exp = cmp;
2828 ctx->curr_env = cmp_env;
2829 return;
2830 }
2831 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
2832}
2833
2834static void apply_rest_args(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2835 lbm_value res;
2836 if (lbm_env_lookup_b(&res, ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ctx->curr_env)) {
2837 if (nargs == 1 && lbm_is_number(args[0])) {
2838 int32_t ix = lbm_dec_as_i32(args[0]);
2839 res = lbm_index_list(res, ix);
2840 }
2841 ctx->r = res;
2842 } else {
2843 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2844 }
2845 lbm_stack_drop(&ctx->K, nargs+1);
2846 ctx->app_cont = true1;
2847}
2848
2849/* (rotate list-expr dist/dir-expr) */
2850static void apply_rotate(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2851 if (nargs == 2 && lbm_is_list(args[0]) && lbm_is_number(args[1])) {
2852 int len = -1;
2853 lbm_value ls = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2854 WITH_GC(ls, lbm_list_copy(&len, args[0]))(ls) = (lbm_list_copy(&len, args[0])); if (lbm_is_symbol_merror
((ls))) { gc(); (ls) = (lbm_list_copy(&len, args[0])); if
(lbm_is_symbol_merror((ls))) { error_ctx((((0x23) << 4
) | 0x00000000u)); } };
2855 int dist = lbm_dec_as_i32(args[1]);
2856 if (len > 0 && dist != 0) {
2857 int d = dist;
2858 if (dist > 0) {
2859 ls = lbm_list_destructive_reverse(ls);
2860 } else {
2861 d = -dist;
2862 }
2863
2864 lbm_value start = ls;
2865 lbm_value end = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2866 lbm_value curr = start;
2867 while (lbm_is_cons(curr)) {
2868 end = curr;
2869 curr = get_cdr(curr);
2870 }
2871
2872 for (int i = 0; i < d; i ++) {
2873 lbm_value a = start;
2874 start = lbm_cdr(start);
2875 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2876 lbm_set_cdr(end, a);
2877 end = a;
2878 }
2879 ls = start;
2880 if (dist > 0) {
2881 ls = lbm_list_destructive_reverse(ls);
2882 }
2883 }
2884 lbm_stack_drop(&ctx->K, nargs+1);
2885 ctx->app_cont = true1;
2886 ctx->r = ls;
2887 return;
2888 }
2889 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2890}
2891
2892/***************************************************/
2893/* Application lookup table */
2894
2895typedef void (*apply_fun)(lbm_value *, lbm_uint, eval_context_t *);
2896static const apply_fun fun_table[] =
2897 {
2898 apply_setvar,
2899 apply_read,
2900 apply_read_program,
2901 apply_read_eval_program,
2902 apply_spawn,
2903 apply_spawn_trap,
2904 apply_yield,
2905 apply_wait,
2906 apply_eval,
2907 apply_eval_program,
2908 apply_send,
2909 apply_ok,
2910 apply_error,
2911 apply_map,
2912 apply_reverse,
2913 apply_flatten,
2914 apply_unflatten,
2915 apply_kill,
2916 apply_sleep,
2917 apply_merge,
2918 apply_sort,
2919 apply_rest_args,
2920 apply_rotate,
2921 };
2922
2923/***************************************************/
2924/* Application of function that takes arguments */
2925/* passed over the stack. */
2926
2927static void application(eval_context_t *ctx, lbm_value *fun_args, lbm_uint arg_count) {
2928 /* If arriving here, we know that the fun is a symbol.
2929 * and can be a built in operation or an extension.
2930 */
2931 lbm_value fun = fun_args[0];
2932
2933 lbm_uint fun_val = lbm_dec_sym(fun);
2934 lbm_uint fun_kind = SYMBOL_KIND(fun_val)((fun_val) >> 16);
2935
2936 switch (fun_kind) {
2937 case SYMBOL_KIND_EXTENSION1: {
2938 extension_fptr f = extension_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)].fptr;
2939
2940 lbm_value ext_res;
2941 WITH_GC(ext_res, f(&fun_args[1], arg_count))(ext_res) = (f(&fun_args[1], arg_count)); if (lbm_is_symbol_merror
((ext_res))) { gc(); (ext_res) = (f(&fun_args[1], arg_count
)); if (lbm_is_symbol_merror((ext_res))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2942 if (lbm_is_error(ext_res)) { //Error other than merror
2943 error_at_ctx(ext_res, fun);
2944 }
2945 lbm_stack_drop(&ctx->K, arg_count + 1);
2946
2947 ctx->app_cont = true1;
2948 ctx->r = ext_res;
2949
2950 if (blocking_extension) {
2951 blocking_extension = false0;
2952 if (blocking_extension_timeout) {
2953 blocking_extension_timeout = false0;
2954 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, blocking_extension_timeout_us,true1);
2955 } else {
2956 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,true1);
2957 }
2958 mutex_unlock(&blocking_extension_mutex);
2959 }
2960 } break;
2961 case SYMBOL_KIND_FUNDAMENTAL2:
2962 call_fundamental(SYMBOL_IX(fun_val)((fun_val) & 0xFFFF), &fun_args[1], arg_count, ctx);
2963 break;
2964 case SYMBOL_KIND_APPFUN3:
2965 fun_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)](&fun_args[1], arg_count, ctx);
2966 break;
2967 default:
2968 // Symbols that are "special" but not in the way caught above
2969 // ends up here.
2970 lbm_set_error_reason("Symbol does not represent a function");
2971 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),fun_args[0]);
2972 break;
2973 }
2974}
2975
2976static void cont_closure_application_args(eval_context_t *ctx) {
2977 lbm_uint* sptr = get_stack_ptr(ctx, 5);
2978
2979 lbm_value arg_env = (lbm_value)sptr[0];
2980 lbm_value exp = (lbm_value)sptr[1];
2981 lbm_value clo_env = (lbm_value)sptr[2];
2982 lbm_value params = (lbm_value)sptr[3];
2983 lbm_value args = (lbm_value)sptr[4];
2984
2985 lbm_value car_params, cdr_params;
2986 get_car_and_cdr(params, &car_params, &cdr_params);
2987
2988 bool_Bool a_nil = lbm_is_symbol_nil(args);
2989 bool_Bool p_nil = lbm_is_symbol_nil(cdr_params);
2990
2991 lbm_value binder = allocate_binding(car_params, ctx->r, clo_env);
2992
2993 if (!a_nil && !p_nil) {
2994 lbm_value car_args, cdr_args;
2995 get_car_and_cdr(args, &car_args, &cdr_args);
2996 sptr[2] = binder;
2997 sptr[3] = cdr_params;
2998 sptr[4] = cdr_args;
2999 stack_reserve(ctx,1)[0] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
3000 ctx->curr_exp = car_args;
3001 ctx->curr_env = arg_env;
3002 } else if (a_nil && p_nil) {
3003 // Arguments and parameters match up in number
3004 lbm_stack_drop(&ctx->K, 5);
3005 ctx->curr_env = binder;
3006 ctx->curr_exp = exp;
3007 } else if (p_nil) {
3008 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), binder);
3009 sptr[2] = rest_binder;
3010 sptr[3] = get_cdr(args);
3011 sptr[4] = get_car(rest_binder); // last element of rest_args so far
3012 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3013 ctx->curr_exp = get_car(args);
3014 ctx->curr_env = arg_env;
3015 } else {
3016 lbm_set_error_reason((char*)lbm_error_str_num_args);
3017 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
3018 }
3019}
3020
3021
3022static void cont_closure_args_rest(eval_context_t *ctx) {
3023 lbm_uint* sptr = get_stack_ptr(ctx, 5);
3024 lbm_value arg_env = (lbm_value)sptr[0];
3025 lbm_value exp = (lbm_value)sptr[1];
3026 lbm_value clo_env = (lbm_value)sptr[2];
3027 lbm_value args = (lbm_value)sptr[3];
3028 lbm_value last = (lbm_value)sptr[4];
3029 lbm_cons_t* heap = lbm_heap_state.heap;
3030
3031 lbm_value binding = lbm_heap_state.freelist;
3032 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3033 gc();
3034 binding = lbm_heap_state.freelist;
3035 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3036 }
3037 lbm_uint binding_ix = lbm_dec_ptr(binding);
3038 lbm_heap_state.freelist = heap[binding_ix].cdr;
3039 lbm_heap_state.num_alloc += 1;
3040 heap[binding_ix].car = ctx->r;
3041 heap[binding_ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3042
3043
3044 lbm_set_cdr(last, binding);
3045 sptr[4] = binding;
3046
3047 if (args == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3048 lbm_stack_drop(&ctx->K, 5);
3049 ctx->curr_env = clo_env;
3050 ctx->curr_exp = exp;
3051 } else {
3052 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3053 sptr[3] = get_cdr(args);
3054 ctx->curr_exp = get_car(args);
3055 ctx->curr_env = arg_env;
3056 }
3057}
3058
3059static void cont_application_args(eval_context_t *ctx) {
3060 lbm_uint *sptr = get_stack_ptr(ctx, 3);
3061
3062 lbm_value env = sptr[0];
3063 lbm_value rest = sptr[1];
3064 lbm_value count = sptr[2];
3065
3066 ctx->curr_env = env;
3067 sptr[0] = ctx->r; // Function 1st then Arguments
3068 if (lbm_is_cons(rest)) {
3069 lbm_cons_t *cell = lbm_ref_cell(rest);
3070 sptr[1] = env;
3071 sptr[2] = cell->cdr;
3072 lbm_value *rptr = stack_reserve(ctx,2);
3073 rptr[0] = count + (1 << LBM_VAL_SHIFT4);
3074 rptr[1] = APPLICATION_ARGS(((5) << 2) | 0xF8000001u);
3075 ctx->curr_exp = cell->car;
3076 } else {
3077 // No more arguments
3078 lbm_stack_drop(&ctx->K, 2);
3079 lbm_uint nargs = lbm_dec_u(count);
3080 lbm_value *args = get_stack_ptr(ctx, (uint32_t)(nargs + 1));
3081 application(ctx,args, nargs);
3082 }
3083}
3084
3085static void cont_and(eval_context_t *ctx) {
3086 lbm_value env;
3087 lbm_value rest;
3088 lbm_value arg = ctx->r;
3089 lbm_pop_2(&ctx->K, &rest, &env);
3090 if (lbm_is_symbol_nil(arg)) {
3091 ctx->app_cont = true1;
3092 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3093 } else if (lbm_is_symbol_nil(rest)) {
3094 ctx->app_cont = true1;
3095 } else {
3096 lbm_value *sptr = stack_reserve(ctx, 3);
3097 sptr[0] = env;
3098 sptr[1] = get_cdr(rest);
3099 sptr[2] = AND(((6) << 2) | 0xF8000001u);
3100 ctx->curr_env = env;
3101 ctx->curr_exp = get_car(rest);
3102 }
3103}
3104
3105static void cont_or(eval_context_t *ctx) {
3106 lbm_value env;
3107 lbm_value rest;
3108 lbm_value arg = ctx->r;
3109 lbm_pop_2(&ctx->K, &rest, &env);
3110 if (!lbm_is_symbol_nil(arg)) {
3111 ctx->app_cont = true1;
3112 } else if (lbm_is_symbol_nil(rest)) {
3113 ctx->app_cont = true1;
3114 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3115 } else {
3116 lbm_value *sptr = stack_reserve(ctx, 3);
3117 sptr[0] = env;
3118 sptr[1] = get_cdr(rest);
3119 sptr[2] = OR(((7) << 2) | 0xF8000001u);
3120 ctx->curr_exp = get_car(rest);
3121 ctx->curr_env = env;
3122 }
3123}
3124
3125static int fill_binding_location(lbm_value key, lbm_value value, lbm_value env) {
3126 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) {
3127 if (key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return FB_OK0;
3128 lbm_env_modify_binding(env,key,value);
3129 return FB_OK0;
3130 } else if (lbm_is_cons(key) &&
3131 lbm_is_cons(value)) {
3132 int r = fill_binding_location(get_car(key), get_car(value), env);
3133 if (r == FB_OK0) {
3134 r = fill_binding_location(get_cdr(key), get_cdr(value), env);
3135 }
3136 return r;
3137 }
3138 return FB_TYPE_ERROR-1;
3139}
3140
3141static void cont_bind_to_key_rest(eval_context_t *ctx) {
3142
3143 lbm_value *sptr = get_stack_ptr(ctx, 4);
3144
3145 lbm_value rest = sptr[1];
3146 lbm_value env = sptr[2];
3147 lbm_value key = sptr[3];
3148
3149 if (fill_binding_location(key, ctx->r, env) < 0) {
3150 lbm_set_error_reason("Incorrect type of name/key in let-binding");
3151 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
3152 }
3153
3154 if (lbm_is_cons(rest)) {
3155 lbm_value car_rest = get_car(rest);
3156 lbm_value key_val[2];
3157 extract_n(car_rest, key_val, 2);
3158
3159 sptr[1] = get_cdr(rest);
3160 sptr[3] = key_val[0];
3161 stack_reserve(ctx,1)[0] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
3162 ctx->curr_exp = key_val[1];
3163 ctx->curr_env = env;
3164 } else {
3165 // Otherwise evaluate the expression in the populated env
3166 ctx->curr_exp = sptr[0];
3167 ctx->curr_env = env;
3168 lbm_stack_drop(&ctx->K, 4);
3169 }
3170}
3171
3172static void cont_if(eval_context_t *ctx) {
3173
3174 lbm_value arg = ctx->r;
3175
3176 lbm_value *sptr = pop_stack_ptr(ctx, 2);
3177
3178 ctx->curr_env = sptr[1];
3179 if (lbm_is_symbol_nil(arg)) {
3180 ctx->curr_exp = get_cadr(sptr[0]); // else branch
3181 } else {
3182 ctx->curr_exp = get_car(sptr[0]); // then branch
3183 }
3184}
3185
3186static void cont_match(eval_context_t *ctx) {
3187 lbm_value e = ctx->r;
3188 bool_Bool do_gc = false0;
3189
3190 lbm_uint *sptr = get_stack_ptr(ctx, 2);
3191 lbm_value patterns = (lbm_value)sptr[0];
3192 lbm_value orig_env = (lbm_value)sptr[1]; // restore enclosing environment.
3193 lbm_value new_env = orig_env;
3194
3195 if (lbm_is_symbol_nil(patterns)) {
3196 // no more patterns
3197 lbm_stack_drop(&ctx->K, 2);
3198 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
3199 ctx->app_cont = true1;
3200 } else if (lbm_is_cons(patterns)) {
3201 lbm_value match_case = get_car(patterns);
3202 lbm_value pattern = get_car(match_case);
3203 lbm_value n1 = get_cadr(match_case);
3204 lbm_value n2 = get_cadr(get_cdr(match_case));
3205 lbm_value body;
3206 bool_Bool check_guard = false0;
3207 if (lbm_is_symbol_nil(n2)) { // TODO: Not a very robust check.
3208 body = n1;
3209 } else {
3210 body = n2;
3211 check_guard = true1;
3212 }
3213
3214 bool_Bool is_match = match(pattern, e, &new_env, &do_gc);
3215 if (do_gc) {
3216 gc();
3217 do_gc = false0;
3218 new_env = orig_env;
3219 is_match = match(pattern, e, &new_env, &do_gc);
3220 if (do_gc) {
3221 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3222 }
3223 }
3224 if (is_match) {
3225 if (check_guard) {
3226 lbm_value *rptr = stack_reserve(ctx,5);
3227 sptr[0] = get_cdr(patterns);
3228 sptr[1] = ctx->curr_env;
3229 rptr[0] = MATCH(((9) << 2) | 0xF8000001u);
3230 rptr[1] = new_env;
3231 rptr[2] = body;
3232 rptr[3] = e;
3233 rptr[4] = MATCH_GUARD(((27) << 2) | 0xF8000001u);
3234 ctx->curr_env = new_env;
3235 ctx->curr_exp = n1; // The guard
3236 } else {
3237 lbm_stack_drop(&ctx->K, 2);
3238 ctx->curr_env = new_env;
3239 ctx->curr_exp = body;
3240 }
3241 } else {
3242 // set up for checking of next pattern
3243 sptr[0] = get_cdr(patterns);
3244 sptr[1] = orig_env;
3245 stack_reserve(ctx,1)[0] = MATCH(((9) << 2) | 0xF8000001u);
3246 // leave r unaltered
3247 ctx->app_cont = true1;
3248 }
3249 } else {
3250 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MATCH(((0x108) << 4) | 0x00000000u));
3251 }
3252}
3253
3254static void cont_exit_atomic(eval_context_t *ctx) {
3255 is_atomic --;
3256 ctx->app_cont = true1;
3257}
3258
3259static void cont_map(eval_context_t *ctx) {
3260 lbm_value *sptr = get_stack_ptr(ctx, 6);
3261
3262 lbm_value ls = sptr[0];
3263 lbm_value env = sptr[1];
3264 lbm_value t = sptr[3];
3265 lbm_set_car(t, ctx->r); // update car field tailmost position.
3266 if (lbm_is_cons(ls)) {
3267 lbm_value next, rest;
3268 get_car_and_cdr(ls, &next, &rest);
3269 sptr[0] = rest;
3270 stack_reserve(ctx,1)[0] = MAP(((26) << 2) | 0xF8000001u);
3271 lbm_set_car(sptr[5], next); // new arguments
3272
3273 lbm_value elt = cons_with_gc(ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3274 lbm_set_cdr(t, elt);
3275 sptr[3] = elt; // (r1 ... rN . (nil . nil))
3276 ctx->curr_exp = sptr[4];
3277 ctx->curr_env = env;
3278 } else {
3279 ctx->r = sptr[2]; //head of result list
3280 ctx->curr_env = env;
3281 lbm_stack_drop(&ctx->K, 6);
3282 ctx->app_cont = true1;
3283 }
3284}
3285
3286static void cont_match_guard(eval_context_t *ctx) {
3287 if (lbm_is_symbol_nil(ctx->r)) {
3288 lbm_value e;
3289 lbm_pop(&ctx->K, &e);
3290 lbm_stack_drop(&ctx->K, 2);
3291 ctx->r = e;
3292 ctx->app_cont = true1;
3293 } else {
3294 lbm_value body;
3295 lbm_value env;
3296 lbm_stack_drop(&ctx->K, 1);
3297 lbm_pop_2(&ctx->K, &body, &env);
3298 lbm_stack_drop(&ctx->K, 3);
3299 ctx->curr_env = env;
3300 ctx->curr_exp = body;
3301 }
3302}
3303
3304static void cont_terminate(eval_context_t *ctx) {
3305 error_ctx(ctx->r);
3306}
3307
3308static void cont_loop(eval_context_t *ctx) {
3309 lbm_value *sptr = get_stack_ptr(ctx, 2);
3310 stack_reserve(ctx,1)[0] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
3311 ctx->curr_exp = sptr[1];
3312}
3313
3314static void cont_loop_condition(eval_context_t *ctx) {
3315 if (lbm_is_symbol_nil(ctx->r)) {
3316 lbm_stack_drop(&ctx->K, 2);
3317 ctx->app_cont = true1; // A loop returns nil? Makes sense to me... but in general?
3318 return;
3319 }
3320 lbm_value *sptr = get_stack_ptr(ctx, 2);
3321 stack_reserve(ctx,1)[0] = LOOP(((41) << 2) | 0xF8000001u);
3322 ctx->curr_exp = sptr[0];
3323}
3324
3325static void cont_merge_rest(eval_context_t *ctx) {
3326 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3327
3328 // If comparator returns true (result is in ctx->r):
3329 // "a" should be moved to the last element position in merged list.
3330 // A new element from "a_rest" should be moved into comparator argument 1 pos.
3331 // else
3332 // "b" should be moved to last element position in merged list.
3333 // A new element from "b_rest" should be moved into comparator argument 2 pos.
3334 //
3335 // If a_rest or b_rest is NIL:
3336 // we are done, the remaining elements of
3337 // non_nil list should be appended to merged list.
3338 // else
3339 // Set up for a new comparator evaluation and recurse.
3340 lbm_value a = sptr[2];
3341 lbm_value b = lbm_cdr(a);
3342 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate 1 element list
3343
3344 if (ctx->r == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) { // Comparison false
3345
3346 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3347 sptr[0] = b;
3348 sptr[1] = b;
3349 } else {
3350 lbm_set_cdr(sptr[1], b);
3351 sptr[1] = b;
3352 }
3353 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3354 lbm_set_cdr(a, sptr[3]);
3355 lbm_set_cdr(sptr[1], a);
3356 ctx->r = sptr[0];
3357 lbm_stack_drop(&ctx->K, 9);
3358 ctx->app_cont = true1;
3359 return;
3360 } else {
3361 b = sptr[4];
3362 sptr[4] = lbm_cdr(sptr[4]);
3363 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3364 }
3365 } else {
3366 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3367 sptr[0] = a;
3368 sptr[1] = a;
3369 } else {
3370 lbm_set_cdr(sptr[1], a);
3371 sptr[1] = a;
3372 }
3373
3374 if (sptr[3] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3375 lbm_set_cdr(b, sptr[4]);
3376 lbm_set_cdr(sptr[1], b);
3377 ctx->r = sptr[0];
3378 lbm_stack_drop(&ctx->K, 9);
3379 ctx->app_cont = true1;
3380 return;
3381 } else {
3382 a = sptr[3];
3383 sptr[3] = lbm_cdr(sptr[3]);
3384 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3385 }
3386 }
3387 lbm_set_cdr(a, b);
3388 sptr[2] = a;
3389
3390 lbm_value par1 = sptr[7];
3391 lbm_value par2 = sptr[8];
3392 lbm_value cmp_body = sptr[5];
3393 lbm_value cmp_env = sptr[6];
3394 // Environment should be preallocated already at this point
3395 // and the operations below should never need GC.
3396 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3397 lbm_value new_env = lbm_env_set(new_env0, par2, lbm_car(b));
3398 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3399 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3400 }
3401 cmp_env = new_env;
3402
3403 stack_reserve(ctx,1)[0] = MERGE_REST(((43) << 2) | 0xF8000001u);
3404 ctx->curr_exp = cmp_body;
3405 ctx->curr_env = cmp_env;
3406}
3407
3408// merge_layer stack contents
3409// s[sp-9] = cmp
3410// s[sp-8] = cmp_env
3411// s[sp-7] = par1
3412// s[sp-6] = par2
3413// s[sp-5] = acc - first cell
3414// s[sp-4] = acc - last cell
3415// s[sp-3] = rest;
3416// s[sp-2] = layer
3417// s[sp-1] = length or original list
3418//
3419// ctx->r merged sublist
3420static void cont_merge_layer(eval_context_t *ctx) {
3421 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3422 lbm_int layer = lbm_dec_i(sptr[7]);
3423 lbm_int len = lbm_dec_i(sptr[8]);
3424
3425 lbm_value r_curr = ctx->r;
3426 while (lbm_is_cons(r_curr)) {
3427 lbm_value next = lbm_cdr(r_curr);
3428 if (next == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3429 break;
3430 }
3431 r_curr = next;
3432 }
3433
3434 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3435 sptr[4] = ctx->r;
3436 sptr[5] = r_curr;
3437 } else {
3438 lbm_set_cdr(sptr[5], ctx->r); // accumulate merged sublists.
3439 sptr[5] = r_curr;
3440 }
3441
3442 lbm_value layer_rest = sptr[6];
3443 // switch layer or done ?
3444 if (layer_rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3445 if (layer * 2 >= len) {
3446 ctx->r = sptr[4];
3447 ctx->app_cont = true1;
3448 lbm_stack_drop(&ctx->K, 9);
3449 return;
3450 } else {
3451 // Setup for merges of the next layer
3452 layer = layer * 2;
3453 sptr[7] = lbm_enc_i(layer);
3454 layer_rest = sptr[4]; // continue on the accumulation of all sublists.
3455 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3456 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3457 }
3458 }
3459 // merge another sublist based on current layer.
3460 lbm_value a_list = layer_rest;
3461 // build sublist a
3462 lbm_value curr = layer_rest;
3463 for (int i = 0; i < layer-1; i ++) {
3464 if (lbm_is_cons(curr)) {
3465 curr = lbm_cdr(curr);
3466 } else {
3467 break;
3468 }
3469 }
3470 layer_rest = lbm_cdr(curr);
3471 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3472
3473 lbm_value b_list = layer_rest;
3474 // build sublist b
3475 curr = layer_rest;
3476 for (int i = 0; i < layer-1; i ++) {
3477 if (lbm_is_cons(curr)) {
3478 curr = lbm_cdr(curr);
3479 } else {
3480 break;
3481 }
3482 }
3483 layer_rest = lbm_cdr(curr);
3484 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3485
3486 sptr[6] = layer_rest;
3487
3488 if (b_list == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3489 stack_reserve(ctx,1)[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3490 ctx->r = a_list;
3491 ctx->app_cont = true1;
3492 return;
3493 }
3494 // Set up for a merge of sublists.
3495
3496 lbm_value a_rest = lbm_cdr(a_list);
3497 lbm_value b_rest = lbm_cdr(b_list);
3498 lbm_value a = a_list;
3499 lbm_value b = b_list;
3500 lbm_set_cdr(a, b);
3501 // Terminating the b list would be incorrect here
3502 // if there was any chance that the environment update below
3503 // performs GC.
3504 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3505
3506 lbm_value cmp_body = sptr[0];
3507 lbm_value cmp_env = sptr[1];
3508 lbm_value par1 = sptr[2];
3509 lbm_value par2 = sptr[3];
3510 // Environment should be preallocated already at this point
3511 // and the operations below should never need GC.
3512 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3513 lbm_value new_env = lbm_env_set(cmp_env, par2, lbm_car(b));
3514 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3515 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3516 }
3517 cmp_env = new_env;
3518
3519 lbm_uint *merge_cont = stack_reserve(ctx, 11);
3520 merge_cont[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3521 merge_cont[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3522 merge_cont[2] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3523 merge_cont[3] = a;
3524 merge_cont[4] = a_rest;
3525 merge_cont[5] = b_rest;
3526 merge_cont[6] = cmp_body;
3527 merge_cont[7] = cmp_env;
3528 merge_cont[8] = par1;
3529 merge_cont[9] = par2;
3530 merge_cont[10] = MERGE_REST(((43) << 2) | 0xF8000001u);
3531 ctx->curr_exp = cmp_body;
3532 ctx->curr_env = cmp_env;
3533 return;
3534}
3535
3536/****************************************************/
3537/* READER */
3538
3539static void read_finish(lbm_char_channel_t *str, eval_context_t *ctx) {
3540
3541 /* Tokenizer reached "end of file"
3542 The parser could be in a state where it needs
3543 more tokens to correctly finish an expression.
3544
3545 Three cases
3546 1. The program / expression is malformed and the context should die.
3547 2. We are finished reading a program and should close off the
3548 internal representation with a closing parenthesis. Then
3549 apply continuation.
3550 3. We are finished reading an expression and should
3551 apply the continuation.
3552
3553 In case 3, we should find the READ_DONE at sp - 1.
3554 In case 2, we should find the READ_DONE at sp - 5.
3555
3556 */
3557
3558 if (lbm_is_symbol(ctx->r)) {
3559 lbm_uint sym_val = lbm_dec_sym(ctx->r);
3560 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
3561 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
3562 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3563 }
3564 }
3565
3566 if (ctx->K.data[ctx->K.sp-1] == READ_DONE(((20) << 2) | 0xF8000001u) &&
3567 lbm_dec_u(ctx->K.data[ctx->K.sp-3]) == 0) {
3568 /* successfully finished reading an expression (CASE 3) */
3569 ctx->app_cont = true1;
3570 } else if (ctx->K.sp > 4 && ctx->K.data[ctx->K.sp - 4] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3571 lbm_value env;
3572 lbm_value s;
3573 lbm_value sym;
3574 lbm_pop_3(&ctx->K, &sym, &env, &s);
3575 ctx->curr_env = env;
3576 ctx->app_cont = true1; // Program evaluated and result is in ctx->r.
3577 } else if (ctx->K.sp > 5 && ctx->K.data[ctx->K.sp - 5] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3578 /* successfully finished reading a program (CASE 2) */
3579 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3580 ctx->app_cont = true1;
3581 } else {
3582 /* Parsing failed */
3583 if (lbm_channel_row(str) == 1 &&
3584 lbm_channel_column(str) == 1 ){
3585 // eof at empty stream.
3586 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3587 ctx->app_cont = true1;
3588 } else {
3589 lbm_set_error_reason((char*)lbm_error_str_parse_eof);
3590 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3591 }
3592 lbm_channel_reader_close(str);
3593 }
3594}
3595
3596/* cont_read_next_token
3597 sp-2 : Stream
3598 sp-1 : Grab row
3599*/
3600static void cont_read_next_token(eval_context_t *ctx) {
3601 lbm_value *sptr = get_stack_ptr(ctx, 2);
3602 lbm_value stream = sptr[0];
3603 lbm_value grab_row0 = sptr[1];
3604
3605 lbm_char_channel_t *chan = lbm_dec_channel(stream);
3606 if (chan == NULL((void*)0) || chan->state == NULL((void*)0)) {
3607 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3608 }
3609
3610 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3611 lbm_stack_drop(&ctx->K, 2);
3612 read_finish(chan, ctx);
3613 return;
3614 }
3615 /* Eat whitespace and comments */
3616 if (!tok_clean_whitespace(chan)) {
3617 sptr[0] = stream;
3618 sptr[1] = lbm_enc_u(0);
3619 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3620 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3621 return;
3622 }
3623 /* After eating whitespace we may be at end of file/stream */
3624 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3625 lbm_stack_drop(&ctx->K, 2);
3626 read_finish(chan, ctx);
3627 return;
3628 }
3629
3630 if (lbm_dec_u(grab_row0)) {
3631 ctx->row0 = (int32_t)lbm_channel_row(chan);
3632 }
3633
3634 /* Attempt to extract tokens from the character stream */
3635 int n = 0;
3636 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3637 unsigned int string_len = 0;
3638
3639 /*
3640 * SYNTAX
3641 */
3642 uint32_t match;
3643 n = tok_syntax(chan, &match);
3644 if (n > 0) {
3645 if (!lbm_channel_drop(chan, (unsigned int)n)) {
3646 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3647 }
3648 ctx->app_cont = true1;
3649 lbm_uint do_next = 0;
3650 switch(match) {
3651 case TOKOPENPAR1u: {
3652 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3653 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3654 lbm_value *rptr = stack_reserve(ctx,5);
3655 rptr[0] = stream;
3656 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3657 rptr[2] = stream;
3658 rptr[3] = lbm_enc_u(0);
3659 rptr[4] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3660 ctx->r = ENC_SYM_OPENPAR(((0x70) << 4) | 0x00000000u);
3661 } return;
3662 case TOKCLOSEPAR2u: {
3663 lbm_stack_drop(&ctx->K, 2);
3664 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3665 } return;
3666 case TOKOPENBRACK3u: {
3667 sptr[0] = stream;
3668 sptr[1] = READ_START_ARRAY(((24) << 2) | 0xF8000001u);
3669 lbm_value *rptr = stack_reserve(ctx, 3);
3670 rptr[0] = stream;
3671 rptr[1] = lbm_enc_u(0);
3672 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3673 ctx->r = ENC_SYM_OPENBRACK(((0x80) << 4) | 0x00000000u);
3674 } return;
3675 case TOKCLOSEBRACK4u:
3676 lbm_stack_drop(&ctx->K, 2);
3677 ctx->r = ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u);
3678 return;
3679 case TOKDOT5u:
3680 lbm_stack_drop(&ctx->K, 2);
3681 ctx->r = ENC_SYM_DOT(((0x76) << 4) | 0x00000000u);
3682 return;
3683 case TOKDONTCARE6u:
3684 lbm_stack_drop(&ctx->K, 2);
3685 ctx->r = ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u);
3686 return;
3687 case TOKQUOTE7u:
3688 do_next = READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u);
3689 break;
3690 case TOKBACKQUOTE8u: {
3691 sptr[0] = QQ_EXPAND_START(((35) << 2) | 0xF8000001u);
3692 sptr[1] = stream;
3693 lbm_value *rptr = stack_reserve(ctx, 2);
3694 rptr[0] = lbm_enc_u(0);
3695 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3696 ctx->app_cont = true1;
3697 } return;
3698 case TOKCOMMAAT9u:
3699 do_next = READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u);
3700 break;
3701 case TOKCOMMA10u:
3702 do_next = READ_COMMA_RESULT(((23) << 2) | 0xF8000001u);
3703 break;
3704 case TOKMATCHANY11u:
3705 lbm_stack_drop(&ctx->K, 2);
3706 ctx->r = ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u);
3707 return;
3708 case TOKOPENCURL12u: {
3709 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3710 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3711 lbm_value *rptr = stack_reserve(ctx,2);
3712 rptr[0] = stream;
3713 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3714 ctx->r = ENC_SYM_PROGN(((0x102) << 4) | 0x00000000u);
3715 } return;
3716 case TOKCLOSECURL13u:
3717 lbm_stack_drop(&ctx->K, 2);
3718 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3719 return;
3720 case TOKCONSTSTART14u: /* fall through */
3721 case TOKCONSTEND15u:
3722 case TOKCONSTSYMSTR16u: {
3723 if (match == TOKCONSTSTART14u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3724 if (match == TOKCONSTEND15u) ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3725 if (match == TOKCONSTSYMSTR16u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04;
3726 sptr[0] = stream;
3727 sptr[1] = lbm_enc_u(0);
3728 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3729 ctx->app_cont = true1;
3730 } return;
3731 default:
3732 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3733 }
3734 sptr[0] = do_next;
3735 sptr[1] = stream;
3736 lbm_value *rptr = stack_reserve(ctx, 2);
3737 rptr[0] = lbm_enc_u(0);
3738 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3739 ctx->app_cont = true1;
3740 return;
3741 } else if (n < 0) goto retry_token;
3742
3743 /*
3744 * STRING
3745 */
3746 n = tok_string(chan, &string_len);
3747 if (n >= 2) {
3748 lbm_channel_drop(chan, (unsigned int)n);
3749 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3750 gc();
3751 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3752 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3753 return; // dead return but static analysis does not know that.
3754 }
3755 }
3756 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(res);
3757 char *data = (char*)arr->data;
3758 memset(data,0, string_len + 1);
3759 memcpy(data, tokpar_sym_str, string_len);
3760 lbm_stack_drop(&ctx->K, 2);
3761 ctx->r = res;
3762 ctx->app_cont = true1;
3763 return;
3764 } else if (n < 0) goto retry_token;
3765
3766 /*
3767 * FLOAT
3768 */
3769 token_float f_val;
3770 n = tok_double(chan, &f_val);
3771 if (n > 0) {
3772 lbm_channel_drop(chan, (unsigned int) n);
3773 switch(f_val.type) {
3774 case TOKTYPEF32107u:
3775 WITH_GC(res, lbm_enc_float((float)f_val.value))(res) = (lbm_enc_float((float)f_val.value)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (lbm_enc_float((float)f_val.value));
if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
3776 break;
3777 case TOKTYPEF64108u:
3778 res = lbm_enc_double(f_val.value);
3779 break;
3780 default:
3781 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3782 }
3783 lbm_stack_drop(&ctx->K, 2);
3784 ctx->r = res;
3785 ctx->app_cont = true1;
3786 return;
3787 } else if (n < 0) goto retry_token;
3788
3789 /*
3790 * INTEGER
3791 */
3792 token_int int_result;
3793 n = tok_integer(chan, &int_result);
3794 if (n > 0) {
3795 lbm_channel_drop(chan, (unsigned int)n);
3796 switch(int_result.type) {
3797 case TOKTYPEBYTE100u:
3798 res = lbm_enc_char((uint8_t)(int_result.negative ? -int_result.value : int_result.value));
3799 break;
3800 case TOKTYPEI101u:
3801 res = lbm_enc_i((lbm_int)(int_result.negative ? -int_result.value : int_result.value));
3802 break;
3803 case TOKTYPEU102u:
3804 res = lbm_enc_u((lbm_uint)(int_result.negative ? -int_result.value : int_result.value));
3805 break;
3806 case TOKTYPEI32103u:
3807 WITH_GC(res, lbm_enc_i32((int32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i32((int32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i32((int32_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3808 break;
3809 case TOKTYPEU32104u:
3810 WITH_GC(res,lbm_enc_u32((uint32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u32((uint32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u32((uint32_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3811 break;
3812 case TOKTYPEI64105u:
3813 WITH_GC(res,lbm_enc_i64((int64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i64((int64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i64((int64_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3814 break;
3815 case TOKTYPEU64106u:
3816 WITH_GC(res,lbm_enc_u64((uint64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u64((uint64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u64((uint64_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3817 break;
3818 default:
3819 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3820 }
3821 lbm_stack_drop(&ctx->K, 2);
3822 ctx->r = res;
3823 ctx->app_cont = true1;
3824 return;
3825 } else if (n < 0) goto retry_token;
3826
3827 /*
3828 * SYMBOL
3829 */
3830 n = tok_symbol(chan);
3831 if (n > 0) {
3832 lbm_channel_drop(chan, (unsigned int) n);
3833 lbm_uint symbol_id;
3834 if (lbm_get_symbol_by_name(tokpar_sym_str, &symbol_id)) {
3835 res = lbm_enc_sym(symbol_id);
3836 } else {
3837 int r = 0;
3838 if (n > 4 &&
3839 tokpar_sym_str[0] == 'e' &&
3840 tokpar_sym_str[1] == 'x' &&
3841 tokpar_sym_str[2] == 't' &&
3842 tokpar_sym_str[3] == '-') {
3843 lbm_uint ext_id;
3844 lbm_uint ext_name_len = (lbm_uint)n + 1;
3845 char *ext_name = lbm_malloc(ext_name_len);
3846 if (!ext_name) {
3847 gc();
3848 ext_name = lbm_malloc(ext_name_len);
3849 }
3850 if (ext_name) {
3851 memcpy(ext_name, tokpar_sym_str, ext_name_len);
3852 r = lbm_add_extension(ext_name, lbm_extensions_default);
3853 if (!lbm_lookup_extension_id(ext_name, &ext_id)) {
3854 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3855 }
3856 symbol_id = ext_id;
3857 } else {
3858 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3859 }
3860 } else {
3861 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04 &&
3862 ctx->flags & EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08) {
3863 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id, true1); //flash
3864 if (!r) {
3865 lbm_set_error_reason((char*)lbm_error_str_flash_error);
3866 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3867 }
3868 } else {
3869 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3870 if (!r) {
3871 gc();
3872 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3873 }
3874 }
3875 }
3876 if (r) {
3877 res = lbm_enc_sym(symbol_id);
3878 } else {
3879 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3880 }
3881 }
3882 lbm_stack_drop(&ctx->K, 2);
3883 ctx->r = res;
3884 ctx->app_cont = true1;
3885 return;
3886 } else if (n == TOKENIZER_NEED_MORE-1) {
3887 goto retry_token;
3888 } else if (n <= TOKENIZER_STRING_ERROR-2) {
3889 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3890 }
3891
3892 /*
3893 * CHAR
3894 */
3895 char c_val;
3896 n = tok_char(chan, &c_val);
3897 if(n > 0) {
3898 lbm_channel_drop(chan,(unsigned int) n);
3899 lbm_stack_drop(&ctx->K, 2);
3900 ctx->r = lbm_enc_char((uint8_t)c_val);
3901 ctx->app_cont = true1;
3902 return;
3903 }else if (n < 0) goto retry_token;
3904
3905 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3906
3907 retry_token:
3908 if (n == TOKENIZER_NEED_MORE-1) {
3909 sptr[0] = stream;
3910 sptr[1] = lbm_enc_u(0);
3911 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3912 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3913 return;
3914 }
3915 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3916}
3917
3918static void cont_read_start_array(eval_context_t *ctx) {
3919 lbm_value *sptr = get_stack_ptr(ctx, 1);
3920 lbm_value stream = sptr[0];
3921
3922 lbm_char_channel_t *str = lbm_dec_channel(stream);
3923 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
3924 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3925 }
3926
3927 lbm_uint num_free = lbm_memory_longest_free();
3928 lbm_uint initial_size = (lbm_uint)((float)num_free * 0.9);
3929 if (initial_size == 0) {
3930 gc();
3931 num_free = lbm_memory_longest_free();
3932 initial_size = (lbm_uint)((float)num_free * 0.9);
3933 if (initial_size == 0) {
3934 lbm_channel_reader_close(str);
3935 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3936 }
3937 }
3938
3939 if (lbm_is_number(ctx->r)) {
3940 lbm_value array;
3941 initial_size = sizeof(lbm_uint) * initial_size;
3942
3943 if (!lbm_heap_allocate_array(&array, initial_size)) {
3944 lbm_set_error_reason("Out of memory while reading.");
3945 lbm_channel_reader_close(str);
3946 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3947 // NOTE: If array is not created evaluation ends here.
3948 // Static analysis seems unaware.
3949 }
3950
3951 sptr[0] = array;
3952 lbm_value *rptr = stack_reserve(ctx, 4);
3953 rptr[0] = lbm_enc_u(initial_size);
3954 rptr[1] = lbm_enc_u(0);
3955 rptr[2] = stream;
3956 rptr[3] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3957 ctx->app_cont = true1;
3958 } else {
3959 lbm_channel_reader_close(str);
3960 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3961 }
3962}
3963
3964static void cont_read_append_array(eval_context_t *ctx) {
3965 lbm_uint *sptr = get_stack_ptr(ctx, 4);
3966
3967 lbm_value array = sptr[0];
3968 lbm_value size = lbm_dec_as_u32(sptr[1]);
3969 lbm_value ix = lbm_dec_as_u32(sptr[2]);
3970 lbm_value stream = sptr[3];
3971
3972 if (ix >= (size - 1)) {
3973 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3974 }
3975
3976 // get_car can return nil. Whose value is 0!
3977 // So static Analysis is right about this being a potential NULL pointer.
3978 // However, if the array was created correcly to begin with, it should be fine.
3979 lbm_value arr_car = get_car(array);
3980 lbm_array_header_t *arr = (lbm_array_header_t*)arr_car;
3981
3982 if (lbm_is_number(ctx->r)) {
3983 ((uint8_t*)arr->data)[ix] = (uint8_t)lbm_dec_as_u32(ctx->r);
3984
3985 sptr[2] = lbm_enc_u(ix + 1);
3986 lbm_value *rptr = stack_reserve(ctx, 4);
3987 rptr[0] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3988 rptr[1] = stream;
3989 rptr[2] = lbm_enc_u(0);
3990 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3991 ctx->app_cont = true1;
3992 } else if (lbm_is_symbol(ctx->r) && ctx->r == ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u)) {
3993 lbm_uint array_size = ix / sizeof(lbm_uint);
3994
3995 if (ix % sizeof(lbm_uint) != 0) {
3996 array_size = array_size + 1;
3997 }
3998 lbm_memory_shrink((lbm_uint*)arr->data, array_size);
3999 arr->size = ix;
4000 lbm_stack_drop(&ctx->K, 4);
4001 ctx->r = array;
4002 ctx->app_cont = true1;
4003 } else {
4004 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
4005 }
4006}
4007
4008static void cont_read_append_continue(eval_context_t *ctx) {
4009 lbm_value *sptr = get_stack_ptr(ctx, 3);
4010
4011 lbm_value first_cell = sptr[0];
4012 lbm_value last_cell = sptr[1];
4013 lbm_value stream = sptr[2];
4014
4015 lbm_char_channel_t *str = lbm_dec_channel(stream);
4016 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4017 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4018 }
4019
4020 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4021
4022 switch(ctx->r) {
4023 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4024 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4025 lbm_set_cdr(last_cell, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate the list
4026 ctx->r = first_cell;
4027 } else {
4028 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4029 }
4030 lbm_stack_drop(&ctx->K, 3);
4031 /* Skip reading another token and apply the continuation */
4032 ctx->app_cont = true1;
4033 return;
4034 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4035 lbm_value *rptr = stack_reserve(ctx, 4);
4036 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4037 rptr[1] = stream;
4038 rptr[2] = lbm_enc_u(0);
4039 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4040 ctx->app_cont = true1;
4041 } return;
4042 }
4043 }
4044 lbm_value new_cell = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4045 if (lbm_is_symbol_merror(new_cell)) {
4046 lbm_channel_reader_close(str);
4047 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4048 return;
4049 }
4050 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4051 lbm_set_cdr(last_cell, new_cell);
4052 last_cell = new_cell;
4053 } else {
4054 first_cell = last_cell = new_cell;
4055 }
4056 sptr[0] = first_cell;
4057 sptr[1] = last_cell;
4058 sptr[2] = stream; // unchanged.
4059 lbm_value *rptr = stack_reserve(ctx, 4);
4060 rptr[0] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
4061 rptr[1] = stream;
4062 rptr[2] = lbm_enc_u(0);
4063 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4064 ctx->app_cont = true1;
4065}
4066
4067static void cont_read_eval_continue(eval_context_t *ctx) {
4068 lbm_value env;
4069 lbm_value stream;
4070 lbm_pop_2(&ctx->K, &env, &stream);
4071
4072 lbm_char_channel_t *str = lbm_dec_channel(stream);
4073 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4074 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4075 }
4076
4077 ctx->row1 = (lbm_int)str->row(str);
4078
4079 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4080
4081 switch(ctx->r) {
4082 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4083 ctx->app_cont = true1;
4084 return;
4085 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4086 // This case is a bit mysterious.
4087 // A dot, may in reality be an error in this location.
4088 lbm_value *rptr = stack_reserve(ctx, 4);
4089 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4090 rptr[1] = stream;
4091 rptr[2] = lbm_enc_u(0);
4092 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4093 ctx->app_cont = true1;
4094 } return;
4095 }
4096 }
4097
4098 lbm_value *rptr = stack_reserve(ctx, 6);
4099 rptr[0] = stream;
4100 rptr[1] = env;
4101 rptr[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
4102 rptr[3] = stream;
4103 rptr[4] = lbm_enc_u(1);
4104 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4105 rptr[6] = lbm_enc_u(ctx->flags);
4106 rptr[7] = POP_READER_FLAGS(((47) << 2) | 0xF8000001u);
4107 ctx->curr_env = env;
4108 ctx->curr_exp = ctx->r;
4109}
4110
4111static void cont_read_expect_closepar(eval_context_t *ctx) {
4112 lbm_value res;
4113 lbm_value stream;
4114
4115 lbm_pop_2(&ctx->K, &res, &stream);
4116
4117 lbm_char_channel_t *str = lbm_dec_channel(stream);
4118 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4119 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4120 }
4121
4122 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4123 ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u)) {
4124 ctx->r = res;
4125 ctx->app_cont = true1;
4126 } else {
4127 lbm_channel_reader_close(str);
4128 lbm_set_error_reason((char*)lbm_error_str_parse_close);
4129 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4130 }
4131}
4132
4133static void cont_read_dot_terminate(eval_context_t *ctx) {
4134 lbm_value *sptr = get_stack_ptr(ctx, 3);
4135
4136 lbm_value first_cell = sptr[0];
4137 lbm_value last_cell = sptr[1];
4138 lbm_value stream = sptr[2];
4139
4140 lbm_char_channel_t *str = lbm_dec_channel(stream);
4141 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4142 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4143 }
4144
4145 lbm_stack_drop(&ctx->K ,3);
4146
4147 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4148 (ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u) ||
4149 ctx->r == ENC_SYM_DOT(((0x76) << 4) | 0x00000000u))) {
4150 lbm_channel_reader_close(str);
4151 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4152 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4153 } else {
4154 if (lbm_is_cons(last_cell)) {
4155 lbm_set_cdr(last_cell, ctx->r);
4156 ctx->r = first_cell;
4157 lbm_value *rptr = stack_reserve(ctx, 6);
4158 rptr[0] = stream;
4159 rptr[1] = ctx->r;
4160 rptr[2] = READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u);
4161 rptr[3] = stream;
4162 rptr[4] = lbm_enc_u(0);
4163 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4164 ctx->app_cont = true1;
4165 } else {
4166 lbm_channel_reader_close(str);
4167 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4168 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4169 }
4170 }
4171}
4172
4173static void cont_read_done(eval_context_t *ctx) {
4174 lbm_value stream;
4175 lbm_value f_val;
4176 lbm_pop_2(&ctx->K, &stream ,&f_val);
4177
4178 uint32_t flags = lbm_dec_as_u32(f_val);
4179 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4180 ctx->flags |= (flags & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4181
4182 lbm_char_channel_t *str = lbm_dec_channel(stream);
4183 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4184 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4185 }
4186
4187 lbm_channel_reader_close(str);
4188 if (lbm_is_symbol(ctx->r)) {
4189 lbm_uint sym_val = lbm_dec_sym(ctx->r);
4190 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
4191 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
4192 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4193 }
4194 }
4195
4196 ctx->row0 = -1;
4197 ctx->row1 = -1;
4198 ctx->app_cont = true1;
4199}
4200
4201static void cont_read_quote_result(eval_context_t *ctx) {
4202 lbm_value cell;
4203 WITH_GC(cell, lbm_heap_allocate_list_init(2,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4204 ENC_SYM_QUOTE,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4205 ctx->r))(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
};
4206 ctx->r = cell;
4207 ctx->app_cont = true1;
4208}
4209
4210static void cont_read_commaat_result(eval_context_t *ctx) {
4211 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4212 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4213 ctx->r = cell1;
4214 ctx->app_cont = true1;
4215}
4216
4217static void cont_read_comma_result(eval_context_t *ctx) {
4218 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u),ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4219 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4220 ctx->r = cell1;
4221 ctx->app_cont = true1;
4222}
4223
4224static void cont_application_start(eval_context_t *ctx) {
4225
4226 /* sptr[0] = env
4227 * sptr[1] = args
4228 * ctx->r = function
4229 */
4230
4231 if (lbm_is_symbol(ctx->r)) {
4232 stack_reserve(ctx,1)[0] = lbm_enc_u(0);
4233 cont_application_args(ctx);
4234 } else if (lbm_is_cons(ctx->r)) {
4235 lbm_uint *sptr = get_stack_ptr(ctx, 2);
4236 lbm_value args = (lbm_value)sptr[1];
4237 switch (get_car(ctx->r)) {
4238 case ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u): {
4239 lbm_value cl[3];
4240 extract_n(get_cdr(ctx->r), cl, 3);
4241 lbm_value arg_env = (lbm_value)sptr[0];
4242 lbm_value arg0, arg_rest;
4243 get_car_and_cdr(args, &arg0, &arg_rest);
4244 sptr[1] = cl[CLO_BODY1];
4245 bool_Bool a_nil = lbm_is_symbol_nil(args);
4246 bool_Bool p_nil = lbm_is_symbol_nil(cl[CLO_PARAMS0]);
4247 lbm_value *reserved = stack_reserve(ctx, 4);
4248
4249 if (!a_nil && !p_nil) {
4250 reserved[0] = cl[CLO_ENV2];
4251 reserved[1] = cl[CLO_PARAMS0];
4252 reserved[2] = arg_rest;
4253 reserved[3] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
4254 ctx->curr_exp = arg0;
4255 ctx->curr_env = arg_env;
4256 } else if (a_nil && p_nil) {
4257 // No params, No args
4258 lbm_stack_drop(&ctx->K, 6);
4259 ctx->curr_exp = cl[CLO_BODY1];
4260 ctx->curr_env = cl[CLO_ENV2];
4261 } else if (p_nil) {
4262 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), cl[CLO_ENV2]);
4263 reserved[0] = rest_binder;
4264 reserved[1] = get_cdr(args);
4265 reserved[2] = get_car(rest_binder);
4266 reserved[3] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
4267 ctx->curr_exp = get_car(args);
4268 ctx->curr_env = arg_env;
4269 } else {
4270 lbm_set_error_reason((char*)lbm_error_str_num_args);
4271 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->r);
4272 }
4273 } break;
4274 case ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u):{
4275 /* Continuation created using call-cc.
4276 * ((SYM_CONT . cont-array) arg0 )
4277 */
4278 lbm_value c = get_cdr(ctx->r); /* should be the continuation array*/
4279
4280 if (!lbm_is_lisp_array_r(c)) {
4281 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4282 }
4283
4284 lbm_uint arg_count = lbm_list_length(args);
4285 lbm_value arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4286 switch (arg_count) {
4287 case 0:
4288 arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4289 break;
4290 case 1:
4291 arg = get_car(args);
4292 break;
4293 default:
4294 lbm_set_error_reason((char*)lbm_error_str_num_args);
4295 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4296 }
4297 lbm_stack_clear(&ctx->K);
4298
4299 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(c);
4300
4301 ctx->K.sp = arr->size / sizeof(lbm_uint);
4302 memcpy(ctx->K.data, arr->data, arr->size);
4303
4304 ctx->curr_exp = arg;
4305 break;
4306 }
4307 case ENC_SYM_MACRO(((0x10D) << 4) | 0x00000000u):{
4308 /*
4309 * Perform macro expansion.
4310 * Macro expansion is really just evaluation in an
4311 * environment augmented with the unevaluated expressions passed
4312 * as arguments.
4313 */
4314 lbm_value env = (lbm_value)sptr[0];
4315
4316 lbm_value curr_param = get_cadr(ctx->r);
4317 lbm_value curr_arg = args;
4318 lbm_value expand_env = env;
4319 while (lbm_is_cons(curr_param) &&
4320 lbm_is_cons(curr_arg)) {
4321 lbm_value car_curr_param, cdr_curr_param;
4322 lbm_value car_curr_arg, cdr_curr_arg;
4323 get_car_and_cdr(curr_param, &car_curr_param, &cdr_curr_param);
4324 get_car_and_cdr(curr_arg, &car_curr_arg, &cdr_curr_arg);
4325
4326 lbm_value entry = cons_with_gc(car_curr_param, car_curr_arg, expand_env);
4327 lbm_value aug_env = cons_with_gc(entry, expand_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4328 expand_env = aug_env;
4329
4330 curr_param = cdr_curr_param;
4331 curr_arg = cdr_curr_arg;
4332 }
4333 /* Two rounds of evaluation is performed.
4334 * First to instantiate the arguments into the macro body.
4335 * Second to evaluate the resulting program.
4336 */
4337 sptr[1] = EVAL_R(((11) << 2) | 0xF8000001u);
4338 lbm_value exp = get_cadr(get_cdr(ctx->r));
4339 ctx->curr_exp = exp;
4340 ctx->curr_env = expand_env;
4341 } break;
4342 default:
4343 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4344 }
4345 } else {
4346 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4347 }
4348}
4349
4350static void cont_eval_r(eval_context_t* ctx) {
4351 lbm_value env;
4352 lbm_pop(&ctx->K, &env);
4353 ctx->curr_exp = ctx->r;
4354 ctx->curr_env = env;
4355}
4356
4357static void cont_progn_var(eval_context_t* ctx) {
4358
4359 lbm_value key;
4360 lbm_value env;
4361
4362 lbm_pop_2(&ctx->K, &key, &env);
4363
4364 if (fill_binding_location(key, ctx->r, env) < 0) {
4365 lbm_set_error_reason("Incorrect type of name/key in let-binding");
4366 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
4367 }
4368
4369 ctx->app_cont = true1;
4370}
4371
4372static void cont_setq(eval_context_t *ctx) {
4373 lbm_value sym;
4374 lbm_value env;
4375 lbm_pop_2(&ctx->K, &sym, &env);
4376 lbm_value res;
4377 WITH_GC(res, perform_setvar(sym, ctx->r, env))(res) = (perform_setvar(sym, ctx->r, env)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (perform_setvar(sym, ctx->r, env)
); if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
4378 ctx->r = res;
4379 ctx->app_cont = true1;
4380}
4381
4382lbm_flash_status request_flash_storage_cell(lbm_value val, lbm_value *res) {
4383
4384 lbm_value flash_cell;
4385 lbm_flash_status s = lbm_allocate_const_cell(&flash_cell);
4386 if (s != LBM_FLASH_WRITE_OK)
4387 return s;
4388 lbm_value new_val = val;
4389 new_val &= ~LBM_PTR_VAL_MASK0x03FFFFFCu; // clear the value part of the ptr
4390 new_val |= (flash_cell & LBM_PTR_VAL_MASK0x03FFFFFCu);
4391 new_val |= LBM_PTR_TO_CONSTANT_BIT0x04000000u;
4392 *res = new_val;
4393 return s;
4394}
4395
4396static void cont_move_to_flash(eval_context_t *ctx) {
4397
4398 lbm_value args;
4399 lbm_pop(&ctx->K, &args);
4400
4401 if (lbm_is_symbol_nil(args)) {
1
Calling 'lbm_is_symbol_nil'
→
4
←
Returning from 'lbm_is_symbol_nil'
→
5
←
Taking false branch
→
4402 // Done looping over arguments. return true.
4403 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
4404 ctx->app_cont = true1;
4405 return;
4406 }
4407
4408 lbm_value first_arg, rest;
6
←
'first_arg' declared without an initial value
→
4409 get_car_and_cdr(args, &first_arg, &rest);
7
←
Calling 'get_car_and_cdr'
→
12
←
Returning from 'get_car_and_cdr'
→
4410
4411 lbm_value val;
4412 if (lbm_is_symbol(first_arg) && lbm_global_env_lookup(&val, first_arg)) {
13
←
1st function call argument is an uninitialized value
4413 // Prepare to copy the rest of the arguments when done with first.
4414 lbm_value *rptr = stack_reserve(ctx, 2);
4415 rptr[0] = rest;
4416 rptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
4417 if (lbm_is_ptr(val) &&
4418 (!(val & LBM_PTR_TO_CONSTANT_BIT0x04000000u))) {
4419 lbm_value * rptr1 = stack_reserve(ctx, 3);
4420 rptr1[0] = first_arg;
4421 rptr1[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
4422 rptr1[2] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4423 ctx->r = val;
4424 }
4425 ctx->app_cont = true1;
4426 return;
4427 }
4428 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4429}
4430
4431static void cont_move_val_to_flash_dispatch(eval_context_t *ctx) {
4432
4433 lbm_value val = ctx->r;
4434
4435 if (lbm_is_cons(val)) {
4436 lbm_value *rptr = stack_reserve(ctx, 5);
4437 rptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // fst cell of list
4438 rptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last cell of list
4439 rptr[2] = get_cdr(val);
4440 rptr[3] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4441 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4442 ctx->r = get_car(val);
4443 ctx->app_cont = true1;
4444 return;
4445 }
4446
4447 if (lbm_is_ptr(val) && (val & LBM_PTR_TO_CONSTANT_BIT0x04000000u)) {
4448 ctx->r = val;
4449 ctx->app_cont = true1;
4450 return;
4451 }
4452
4453 if (lbm_is_ptr(val)) {
4454 lbm_cons_t *ref = lbm_ref_cell(val);
4455 if (lbm_type_of(ref->cdr) == LBM_TYPE_SYMBOL0x00000000u) {
4456 switch (ref->cdr) {
4457 case ENC_SYM_RAW_I_TYPE(((0x31) << 4) | 0x00000000u): /* fall through */
4458 case ENC_SYM_RAW_U_TYPE(((0x32) << 4) | 0x00000000u):
4459 case ENC_SYM_RAW_F_TYPE(((0x33) << 4) | 0x00000000u): {
4460 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4461 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4462 handle_flash_status(write_const_car(flash_cell, ref->car));
4463 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4464 ctx->r = flash_cell;
4465 } break;
4466 case ENC_SYM_IND_I_TYPE(((0x34) << 4) | 0x00000000u): /* fall through */
4467 case ENC_SYM_IND_U_TYPE(((0x35) << 4) | 0x00000000u):
4468 case ENC_SYM_IND_F_TYPE(((0x36) << 4) | 0x00000000u): {
4469#ifndef LBM64
4470 /* 64 bit values are in lbm mem on 32bit platforms. */
4471 lbm_uint *lbm_mem_ptr = (lbm_uint*)ref->car;
4472 lbm_uint flash_ptr;
4473
4474 handle_flash_status(lbm_write_const_raw(lbm_mem_ptr, 2, &flash_ptr));
4475 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4476 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4477 handle_flash_status(write_const_car(flash_cell, flash_ptr));
4478 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4479 ctx->r = flash_cell;
4480#else
4481 // There are no indirect types in LBM64
4482 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4483#endif
4484 } break;
4485 case ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u): {
4486 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4487 lbm_uint size = arr->size / sizeof(lbm_uint);
4488 lbm_uint flash_addr;
4489 lbm_value *arrdata = (lbm_value *)arr->data;
4490 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4491 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4492 handle_flash_status(lbm_allocate_const_raw(size, &flash_addr));
4493 lift_array_flash(flash_cell,
4494 false0,
4495 (char *)flash_addr,
4496 arr->size);
4497 // Move array contents to flash recursively
4498 lbm_value *rptr = stack_reserve(ctx, 5);
4499 rptr[0] = flash_cell;
4500 rptr[1] = lbm_enc_u(0);
4501 rptr[2] = val;
4502 rptr[3] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4503 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4504 ctx->r = arrdata[0];
4505 ctx->app_cont = true1;
4506 return;
4507 }
4508 case ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u): {
4509 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4510 // arbitrary address: flash_arr.
4511 lbm_uint flash_arr;
4512 handle_flash_status(lbm_write_const_array_padded((uint8_t*)arr->data, arr->size, &flash_arr));
4513 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4514 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4515 lift_array_flash(flash_cell,
4516 true1,
4517 (char *)flash_arr,
4518 arr->size);
4519 ctx->r = flash_cell;
4520 } break;
4521 case ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u): /* fall through */
4522 case ENC_SYM_CUSTOM_TYPE(((0x38) << 4) | 0x00000000u):
4523 lbm_set_error_reason((char *)lbm_error_str_flash_not_possible);
4524 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4525 }
4526 } else {
4527 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4528 }
4529 ctx->app_cont = true1;
4530 return;
4531 }
4532 ctx->r = val;
4533 ctx->app_cont = true1;
4534}
4535
4536static void cont_move_list_to_flash(eval_context_t *ctx) {
4537
4538 // ctx->r holds the value that should go in car
4539
4540 lbm_value *sptr = get_stack_ptr(ctx, 3);
4541
4542 lbm_value fst = sptr[0];
4543 lbm_value lst = sptr[1];
4544 lbm_value val = sptr[2];
4545
4546
4547 lbm_value new_lst = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4548 // Allocate element ptr storage after storing the element to flash.
4549 handle_flash_status(request_flash_storage_cell(lbm_enc_cons_ptr(LBM_PTR_NULL(0x03FFFFFCu >> 2)), &new_lst));
4550
4551 if (lbm_is_symbol_nil(fst)) {
4552 lst = new_lst;
4553 fst = new_lst;
4554 handle_flash_status(write_const_car(lst, ctx->r));
4555 } else {
4556 handle_flash_status(write_const_cdr(lst, new_lst)); // low before high
4557 handle_flash_status(write_const_car(new_lst, ctx->r));
4558 lst = new_lst;
4559 }
4560
4561 if (lbm_is_cons(val)) {
4562 sptr[0] = fst;
4563 sptr[1] = lst;//rest_cell;
4564 sptr[2] = get_cdr(val);
4565 lbm_value *rptr = stack_reserve(ctx, 2);
4566 rptr[0] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4567 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4568 ctx->r = get_car(val);
4569 } else {
4570 sptr[0] = fst;
4571 sptr[1] = lst;
4572 sptr[2] = CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u);
4573 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4574 ctx->r = val;
4575 }
4576 ctx->app_cont = true1;
4577}
4578
4579static void cont_close_list_in_flash(eval_context_t *ctx) {
4580 lbm_value fst;
4581 lbm_value lst;
4582 lbm_pop_2(&ctx->K, &lst, &fst);
4583 lbm_value val = ctx->r;
4584 handle_flash_status(write_const_cdr(lst, val));
4585 ctx->r = fst;
4586 ctx->app_cont = true1;
4587}
4588
4589static void cont_move_array_elts_to_flash(eval_context_t *ctx) {
4590 lbm_value *sptr = get_stack_ptr(ctx, 3);
4591 // sptr[2] = source array in RAM
4592 // sptr[1] = current index
4593 // sptr[0] = target array in flash
4594 lbm_array_header_t *src_arr = (lbm_array_header_t*)get_car(sptr[2]);
4595 lbm_uint size = src_arr->size / sizeof(lbm_uint);
4596 lbm_value *srcdata = (lbm_value *)src_arr->data;
4597
4598 lbm_array_header_t *tgt_arr = (lbm_array_header_t*)get_car(sptr[0]);
4599 lbm_uint *tgtdata = (lbm_value *)tgt_arr->data;
4600 lbm_uint ix = lbm_dec_as_u32(sptr[1]);
4601 handle_flash_status(lbm_const_write(&tgtdata[ix], ctx->r));
4602 if (ix >= size-1) {
4603 ctx->r = sptr[0];
4604 lbm_stack_drop(&ctx->K, 3);
4605 ctx->app_cont = true1;
4606 return;
4607 }
4608 sptr[1] = lbm_enc_u(ix + 1);
4609 lbm_value *rptr = stack_reserve(ctx, 2);
4610 rptr[0] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4611 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4612 ctx->r = srcdata[ix+1];
4613 ctx->app_cont = true1;
4614 return;
4615}
4616
4617static void cont_qq_expand_start(eval_context_t *ctx) {
4618 lbm_value *rptr = stack_reserve(ctx, 2);
4619 rptr[0] = ctx->r;
4620 rptr[1] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4621 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4622 ctx->app_cont = true1;
4623}
4624
4625lbm_value quote_it(lbm_value qquoted) {
4626 if (lbm_is_symbol(qquoted) &&
4627 lbm_is_special(qquoted)) return qquoted;
4628
4629 lbm_value val = cons_with_gc(qquoted, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4630 return cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4631}
4632
4633bool_Bool is_append(lbm_value a) {
4634 return (lbm_is_cons(a) &&
4635 lbm_is_symbol(get_car(a)) &&
4636 (get_car(a) == ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u)));
4637}
4638
4639lbm_value append(lbm_value front, lbm_value back) {
4640 if (lbm_is_symbol_nil(front)) return back;
4641 if (lbm_is_symbol_nil(back)) return front;
4642
4643 if (lbm_is_quoted_list(front) &&
4644 lbm_is_quoted_list(back)) {
4645 lbm_value f = get_cadr(front);
4646 lbm_value b = get_cadr(back);
4647 return quote_it(lbm_list_append(f, b));
4648 }
4649
4650 if (is_append(back) &&
4651 lbm_is_quoted_list(get_cadr(back)) &&
4652 lbm_is_quoted_list(front)) {
4653 lbm_value ql = get_cadr(back);
4654 lbm_value f = get_cadr(front);
4655 lbm_value b = get_cadr(ql);
4656
4657 lbm_value v = lbm_list_append(f, b);
4658 lbm_set_car(get_cdr(ql), v);
4659 return back;
4660 }
4661
4662 if (is_append(back)) {
4663 back = get_cdr(back);
4664 lbm_value new = cons_with_gc(front, back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4665 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), new, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4666 }
4667
4668 lbm_value t0, t1;
4669
4670 t0 = cons_with_gc(back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), front);
4671 t1 = cons_with_gc(front, t0, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4672 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), t1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4673}
4674
4675/* Bawden's qq-expand implementation
4676(define (qq-expand x)
4677 (cond ((tag-comma? x)
4678 (tag-data x))
4679 ((tag-comma-atsign? x)
4680 (error "Illegal"))
4681 ((tag-backquote? x)
4682 (qq-expand
4683 (qq-expand (tag-data x))))
4684 ((pair? x)
4685 `(append
4686 ,(qq-expand-list (car x))
4687 ,(qq-expand (cdr x))))
4688 (else `',x)))
4689 */
4690static void cont_qq_expand(eval_context_t *ctx) {
4691 lbm_value qquoted;
4692 lbm_pop(&ctx->K, &qquoted);
4693
4694 switch(lbm_type_of(qquoted)) {
4695 case LBM_TYPE_CONS0x10000000u: {
4696 lbm_value car_val = get_car(qquoted);
4697 lbm_value cdr_val = get_cdr(qquoted);
4698 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4699 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4700 ctx->r = append(ctx->r, get_car(cdr_val));
4701 ctx->app_cont = true1;
4702 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4703 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4704 error_ctx(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u));
4705 } else {
4706 lbm_value *rptr = stack_reserve(ctx, 6);
4707 rptr[0] = ctx->r;
4708 rptr[1] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4709 rptr[2] = cdr_val;
4710 rptr[3] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4711 rptr[4] = car_val;
4712 rptr[5] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4713 ctx->app_cont = true1;
4714 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4715 }
4716
4717 } break;
4718 default: {
4719 lbm_value res = quote_it(qquoted);
4720 ctx->r = append(ctx->r, res);
4721 ctx->app_cont = true1;
4722 }
4723 }
4724}
4725
4726static void cont_qq_append(eval_context_t *ctx) {
4727 lbm_value head;
4728 lbm_pop(&ctx->K, &head);
4729 ctx->r = append(head, ctx->r);
4730 ctx->app_cont = true1;
4731}
4732
4733/* Bawden's qq-expand-list implementation
4734(define (qq-expand-list x)
4735 (cond ((tag-comma? x)
4736 `(list ,(tag-data x)))
4737 ((tag-comma-atsign? x)
4738 (tag-data x))
4739 ((tag-backquote? x)
4740 (qq-expand-list
4741 (qq-expand (tag-data x))))
4742 ((pair? x)
4743 `(list
4744 (append
4745 ,(qq-expand-list (car x))
4746 ,(qq-expand (cdr x)))))
4747 (else `'(,x))))
4748*/
4749
4750static void cont_qq_expand_list(eval_context_t* ctx) {
4751 lbm_value l;
4752 lbm_pop(&ctx->K, &l);
4753
4754 ctx->app_cont = true1;
4755 switch(lbm_type_of(l)) {
4756 case LBM_TYPE_CONS0x10000000u: {
4757 lbm_value car_val = get_car(l);
4758 lbm_value cdr_val = get_cdr(l);
4759 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4760 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4761 lbm_value tl = cons_with_gc(get_car(cdr_val), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4762 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4763 ctx->r = append(ctx->r, tmp);
4764 return;
4765 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4766 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4767 ctx->r = get_car(cdr_val);
4768 return;
4769 } else {
4770 lbm_value *rptr = stack_reserve(ctx, 7);
4771 rptr[0] = QQ_LIST(((39) << 2) | 0xF8000001u);
4772 rptr[1] = ctx->r;
4773 rptr[2] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4774 rptr[3] = cdr_val;
4775 rptr[4] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4776 rptr[5] = car_val;
4777 rptr[6] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4778 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4779 }
4780
4781 } break;
4782 default: {
4783 lbm_value a_list = cons_with_gc(l, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4784 lbm_value tl = cons_with_gc(a_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4785 lbm_value tmp = cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4786 ctx->r = append(ctx->r, tmp);
4787 }
4788 }
4789}
4790
4791static void cont_qq_list(eval_context_t *ctx) {
4792 lbm_value val = ctx->r;
4793 lbm_value apnd_app = cons_with_gc(val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4794 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), apnd_app, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4795 ctx->r = tmp;
4796 ctx->app_cont = true1;
4797}
4798
4799static void cont_kill(eval_context_t *ctx) {
4800 (void) ctx;
4801 finish_ctx();
4802}
4803
4804static void cont_pop_reader_flags(eval_context_t *ctx) {
4805 lbm_value flags;
4806 lbm_pop(&ctx->K, &flags);
4807 ctx->flags = ctx->flags & ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4808 ctx->flags |= (lbm_dec_as_u32(flags) & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4809 // r is unchanged.
4810 ctx->app_cont = true1;
4811}
4812
4813static void cont_exception_handler(eval_context_t *ctx) {
4814 lbm_value *sptr = pop_stack_ptr(ctx, 2);
4815 lbm_value retval = sptr[0];
4816 lbm_value flags = sptr[1];
4817 lbm_set_car(get_cdr(retval), ctx->r);
4818 ctx->flags = flags;
4819 ctx->r = retval;
4820 ctx->app_cont = true1;
4821}
4822
4823/*********************************************************/
4824/* Continuations table */
4825typedef void (*cont_fun)(eval_context_t *);
4826
4827static const cont_fun continuations[NUM_CONTINUATIONS49] =
4828 { advance_ctx, // CONT_DONE
4829 cont_set_global_env,
4830 cont_bind_to_key_rest,
4831 cont_if,
4832 cont_progn_rest,
4833 cont_application_args,
4834 cont_and,
4835 cont_or,
4836 cont_wait,
4837 cont_match,
4838 cont_application_start,
4839 cont_eval_r,
4840 cont_resume,
4841 cont_closure_application_args,
4842 cont_exit_atomic,
4843 cont_read_next_token,
4844 cont_read_append_continue,
4845 cont_read_eval_continue,
4846 cont_read_expect_closepar,
4847 cont_read_dot_terminate,
4848 cont_read_done,
4849 cont_read_quote_result,
4850 cont_read_commaat_result,
4851 cont_read_comma_result,
4852 cont_read_start_array,
4853 cont_read_append_array,
4854 cont_map,
4855 cont_match_guard,
4856 cont_terminate,
4857 cont_progn_var,
4858 cont_setq,
4859 cont_move_to_flash,
4860 cont_move_val_to_flash_dispatch,
4861 cont_move_list_to_flash,
4862 cont_close_list_in_flash,
4863 cont_qq_expand_start,
4864 cont_qq_expand,
4865 cont_qq_append,
4866 cont_qq_expand_list,
4867 cont_qq_list,
4868 cont_kill,
4869 cont_loop,
4870 cont_loop_condition,
4871 cont_merge_rest,
4872 cont_merge_layer,
4873 cont_closure_args_rest,
4874 cont_move_array_elts_to_flash,
4875 cont_pop_reader_flags,
4876 cont_exception_handler
4877 };
4878
4879/*********************************************************/
4880/* Evaluators lookup table (special forms) */
4881typedef void (*evaluator_fun)(eval_context_t *);
4882
4883static const evaluator_fun evaluators[] =
4884 {
4885 eval_quote,
4886 eval_define,
4887 eval_progn,
4888 eval_lambda,
4889 eval_if,
4890 eval_let,
4891 eval_and,
4892 eval_or,
4893 eval_match,
4894 eval_receive,
4895 eval_receive_timeout,
4896 eval_callcc,
4897 eval_atomic,
4898 eval_selfevaluating, // macro
4899 eval_selfevaluating, // cont
4900 eval_selfevaluating, // closure
4901 eval_cond,
4902 eval_app_cont,
4903 eval_var,
4904 eval_setq,
4905 eval_move_to_flash,
4906 eval_loop,
4907 eval_trap
4908 };
4909
4910
4911/*********************************************************/
4912/* Evaluator step function */
4913
4914static void evaluation_step(void){
4915 eval_context_t *ctx = ctx_running;
4916#ifdef VISUALIZE_HEAP
4917 heap_vis_gen_image();
4918#endif
4919
4920 if (ctx->app_cont) {
4921 lbm_value k;
4922 lbm_pop(&ctx->K, &k);
4923 ctx->app_cont = false0;
4924
4925 lbm_uint decoded_k = DEC_CONTINUATION(k)(((k) & ~0xF8000001u) >> 2);
4926
4927 if (decoded_k < NUM_CONTINUATIONS49) {
4928 continuations[decoded_k](ctx);
4929 } else {
4930 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4931 }
4932 return;
4933 }
4934
4935 if (lbm_is_symbol(ctx->curr_exp)) {
4936 eval_symbol(ctx);
4937 return;
4938 }
4939 if (lbm_is_cons(ctx->curr_exp)) {
4940 lbm_cons_t *cell = lbm_ref_cell(ctx->curr_exp);
4941 lbm_value h = cell->car;
4942 if (lbm_is_symbol(h) && ((h & ENC_SPECIAL_FORMS_MASK0xFFFFF000) == ENC_SPECIAL_FORMS_BIT0x00001000)) {
4943 lbm_uint eval_index = lbm_dec_sym(h) & SPECIAL_FORMS_INDEX_MASK0x000000FF;
4944 evaluators[eval_index](ctx);
4945 return;
4946 }
4947 /*
4948 * At this point head can be anything. It should evaluate
4949 * into a form that can be applied (closure, symbol, ...) though.
4950 */
4951 lbm_value *reserved = stack_reserve(ctx, 3);
4952 reserved[0] = ctx->curr_env;
4953 reserved[1] = cell->cdr;
4954 reserved[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
4955 ctx->curr_exp = h; // evaluate the function
4956 return;
4957 }
4958
4959 eval_selfevaluating(ctx);
4960 return;
4961}
4962
4963void lbm_pause_eval(void ) {
4964 eval_cps_next_state_arg = 0;
4965 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4966 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4967}
4968
4969void lbm_pause_eval_with_gc(uint32_t num_free) {
4970 eval_cps_next_state_arg = num_free;
4971 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4972 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4973}
4974
4975void lbm_continue_eval(void) {
4976 eval_cps_next_state = EVAL_CPS_STATE_RUNNING2;
4977 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4978}
4979
4980void lbm_kill_eval(void) {
4981 eval_cps_next_state = EVAL_CPS_STATE_KILL4;
4982 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4983}
4984
4985uint32_t lbm_get_eval_state(void) {
4986 return eval_cps_run_state;
4987}
4988
4989// Will wake up thread that is sleeping as well.
4990// Not sure this is good behavior.
4991static void handle_event_unblock_ctx(lbm_cid cid, lbm_value v) {
4992 eval_context_t *found = NULL((void*)0);
4993 mutex_lock(&qmutex);
4994
4995 found = lookup_ctx_nm(&blocked, cid);
4996 if (found) {
4997 drop_ctx_nm(&blocked,found);
4998 if (lbm_is_error(v)) {
4999 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
5000 found->app_cont = true1;
5001 }
5002 found->r = v;
5003 enqueue_ctx_nm(&queue,found);
5004 }
5005 mutex_unlock(&qmutex);
5006}
5007
5008static void handle_event_define(lbm_value key, lbm_value val) {
5009 lbm_uint dec_key = lbm_dec_sym(key);
5010 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
5011 lbm_value *global_env = lbm_get_global_env();
5012 lbm_uint orig_env = global_env[ix_key];
5013 lbm_value new_env;
5014 // A key is a symbol and should not need to be remembered.
5015 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
5016
5017 global_env[ix_key] = new_env;
5018}
5019
5020static lbm_value get_event_value(lbm_event_t *e) {
5021 lbm_value v;
5022 if (e->buf_len > 0) {
5023 lbm_flat_value_t fv;
5024 fv.buf = (uint8_t*)e->buf_ptr;
5025 fv.buf_size = e->buf_len;
5026 fv.buf_pos = 0;
5027 if (!lbm_unflatten_value(&fv, &v)) {
5028 lbm_set_flags(LBM_FLAG_HANDLER_EVENT_DELIVERY_FAILED(1 << 1));
5029 v = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
5030 }
5031 // Free the flat value buffer. GC is unaware of its existence.
5032 lbm_free(fv.buf);
5033 } else {
5034 v = (lbm_value)e->buf_ptr;
5035 }
5036 return v;
5037}
5038
5039static void process_events(void) {
5040
5041 if (!lbm_events) return;
5042 lbm_event_t e;
5043
5044 while (lbm_event_pop(&e)) {
5045
5046 lbm_value event_val = get_event_value(&e);
5047 switch(e.type) {
5048 case LBM_EVENT_UNBLOCK_CTX:
5049 handle_event_unblock_ctx((lbm_cid)e.parameter, event_val);
5050 break;
5051 case LBM_EVENT_DEFINE:
5052 handle_event_define((lbm_value)e.parameter, event_val);
5053 break;
5054 case LBM_EVENT_FOR_HANDLER:
5055 if (lbm_event_handler_pid >= 0) {
5056 lbm_find_receiver_and_send(lbm_event_handler_pid, event_val);
5057 }
5058 break;
5059 }
5060 }
5061}
5062
5063/* eval_cps_run can be paused
5064 I think it would be better use a mailbox for
5065 communication between other threads and the run_eval
5066 but for now a set of variables will be used. */
5067void lbm_run_eval(void){
5068
5069 if (setjmp(critical_error_jmp_buf)_setjmp (critical_error_jmp_buf) > 0) {
5070 printf_callback("GC stack overflow!\n");
5071 critical_error_callback();
5072 // terminate evaluation thread.
5073 return;
5074 }
5075
5076 setjmp(error_jmp_buf)_setjmp (error_jmp_buf);
5077
5078 while (eval_running) {
5079 if (eval_cps_state_changed || eval_cps_run_state == EVAL_CPS_STATE_PAUSED1) {
5080 eval_cps_state_changed = false0;
5081 switch (eval_cps_next_state) {
5082 case EVAL_CPS_STATE_PAUSED1:
5083 if (eval_cps_run_state != EVAL_CPS_STATE_PAUSED1) {
5084 if (lbm_heap_num_free() < eval_cps_next_state_arg) {
5085 gc();
5086 }
5087 eval_cps_next_state_arg = 0;
5088 }
5089 eval_cps_run_state = EVAL_CPS_STATE_PAUSED1;
5090 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5091 continue; /* jump back to start of eval_running loop */
5092 case EVAL_CPS_STATE_KILL4:
5093 eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
5094 eval_running = false0;
5095 continue;
5096 default: // running state
5097 eval_cps_run_state = eval_cps_next_state;
5098 break;
5099 }
5100 }
5101 while (true1) {
5102 if (eval_steps_quota && ctx_running) {
5103 eval_steps_quota--;
5104 evaluation_step();
5105 } else {
5106 if (eval_cps_state_changed) break;
5107 eval_steps_quota = eval_steps_refill;
5108 if (is_atomic) {
5109 if (!ctx_running) {
5110 lbm_set_flags(LBM_FLAG_ATOMIC_MALFUNCTION(1 << 0));
5111 is_atomic = 0;
5112 }
5113 } else {
5114 if (gc_requested) {
5115 gc();
5116 }
5117 process_events();
5118 mutex_lock(&qmutex);
5119 if (ctx_running) {
5120 enqueue_ctx_nm(&queue, ctx_running);
5121 ctx_running = NULL((void*)0);
5122 }
5123 wake_up_ctxs_nm();
5124 ctx_running = dequeue_ctx_nm(&queue);
5125 mutex_unlock(&qmutex);
5126 if (!ctx_running) {
5127 lbm_system_sleeping = true1;
5128 //Fixed sleep interval to poll events regularly.
5129 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5130 lbm_system_sleeping = false0;
5131 }
5132 }
5133 }
5134 }
5135 }
5136}
5137
5138lbm_cid lbm_eval_program(lbm_value lisp) {
5139 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), 256, NULL((void*)0));
5140}
5141
5142lbm_cid lbm_eval_program_ext(lbm_value lisp, unsigned int stack_size) {
5143 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), stack_size, NULL((void*)0));
5144}
5145
5146int lbm_eval_init() {
5147 if (!qmutex_initialized) {
5148 mutex_init(&qmutex);
5149 qmutex_initialized = true1;
5150 }
5151 if (!lbm_events_mutex_initialized) {
5152 mutex_init(&lbm_events_mutex);
5153 lbm_events_mutex_initialized = true1;
5154 }
5155 if (!blocking_extension_mutex_initialized) {
5156 mutex_init(&blocking_extension_mutex);
5157 blocking_extension_mutex_initialized = true1;
5158 }
5159
5160 mutex_lock(&qmutex);
5161 mutex_lock(&lbm_events_mutex);
5162
5163 blocked.first = NULL((void*)0);
5164 blocked.last = NULL((void*)0);
5165 queue.first = NULL((void*)0);
5166 queue.last = NULL((void*)0);
5167 ctx_running = NULL((void*)0);
5168
5169 eval_cps_run_state = EVAL_CPS_STATE_RUNNING2;
5170
5171 mutex_unlock(&lbm_events_mutex);
5172 mutex_unlock(&qmutex);
5173
5174 if (!lbm_init_env()) return 0;
5175 eval_running = true1;
5176 return 1;
5177}
5178
5179bool_Bool lbm_eval_init_events(unsigned int num_events) {
5180
5181 mutex_lock(&lbm_events_mutex);
5182 lbm_events = (lbm_event_t*)lbm_malloc(num_events * sizeof(lbm_event_t));
5183 bool_Bool r = false0;
5184 if (lbm_events) {
5185 lbm_events_max = num_events;
5186 lbm_events_head = 0;
5187 lbm_events_tail = 0;
5188 lbm_events_full = false0;
5189 lbm_event_handler_pid = -1;
5190 r = true1;
5191 }
5192 mutex_unlock(&lbm_events_mutex);
5193 return r;
5194}
+
+
←

./include/heap.h

+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1
2/*
3 Copyright 2018, 2024 Joel Svensson svenssonjoel@yahoo.se
4
5 This program is free software: you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation, either version 3 of the License, or
8 (at your option) any later version.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
14
15 You should have received a copy of the GNU General Public License
16 along with this program. If not, see <http://www.gnu.org/licenses/>.
17*/
18/** \file heap.h */
19
20#ifndef HEAP_H_
21#define HEAP_H_
22
23#include <string.h>
24#include <stdarg.h>
25
26#include "lbm_types.h"
27#include "symrepr.h"
28#include "stack.h"
29#include "lbm_memory.h"
30#include "lbm_defines.h"
31#include "lbm_channel.h"
32
33#ifdef __cplusplus
34extern "C" {
35#endif
36
37/*
38Planning for a more space efficient heap representation.
39TODO: Need to find a good reference to read up on this.
40 - List based heap
41 - Easy to implement and somewhat efficient
42
430000 0000 Size Free bits
44003F FFFF 4MB 10
45007F FFFF 8MB 9
4600FF FFFF 16MB 8
4701FF FFFF 32MB 7
4803FF FFFF 64MB 6 * Kind of heap size I am looking for
4907FF FFFF 128MB 5
500FFF FFFF 256MB 4
511FFF FFFF 512MB 3
52
53
54--- May 9 2021 ---
55Actually now I am much more interested in way smaller memories ;)
56
570000 0000 Size Free bits
580000 0FFF 4KB 20 |
590000 1FFF 8KB 19 |
600000 3FFF 16KB 18 |
610000 7FFF 32KB 17 |
620000 FFFF 64KB 16 |
630001 FFFF 128KB 15 |
640003 FFFF 256KB 14 | - This range is very interesting.
650007 FFFF 512KB 13
66000F FFFF 1MB 12
67001F FFFF 2MB 11
68003F FFFF 4MB 10
69007F FFFF 8MB 9
7000FF FFFF 16MB 8
7101FF FFFF 32MB 7
7203FF FFFF 64MB 6
7307FF FFFF 128MB 5
740FFF FFFF 256MB 4
751FFF FFFF 512MB 3
76
77Those are the kind of platforms that are fun... so a bunch of
78wasted bits in heap pointers if we run on small MCUs.
79
80-----------------
81
82it is also the case that not all addresses will be used if all "cells" are
83of the same size, 8 bytes...
84
85value 0: 0000 0000
86value 1: 0000 0008
87value 3: 0000 0010
88value 4: 0000 0018
89
90Means bits 0,1,2 will always be empty in a valid address.
91
92Cons cells also need to be have room for 2 pointers. So each ted cell from
93memory should be 8bytes.
94
95Things that needs to be represented within these bits:
96
97 - GC MARK one per cell
98 - TYPE: type of CAR and type of cons
99
100Types I would want:
101 - Full 32bit integer. Does not leave room for identification of type
102 - Float values. Same problem
103
104
105Free bits in pointers 64MB heap:
10631 30 29 28 27 26 2 1 0
1070 0 0 0 0 0 XX XXXX XXXX XXXX XXXX XXXX X 0 0 0
108
109
110Information needed for each cell:
111 Meaning | bits total | bits per car | bits per cdr
112 GC mark | 2 | 1 | 1 - only one of them will be used (the other is wasted)
113 Type | 2x | x | x
114 Ptr/!ptr | 2 | 1 | 1
115
116
117Types (unboxed):
118 - Symbols
119 - 28bit integer ( will need signed shift right functionality )
120 - 28bit unsigned integer
121 - Character
122
123If four types is all that should be possible (unboxed). then 2 bits are needed to differentiate.
1242 + 1 + 1 = 4 => 28bits for data.
125
126bit 0: ptr/!ptr
127bit 1: gc
128bit 2-3: type (if not ptr)
129bit 3 - 24 ptr (if ptr)
130bit 4 - 31 value (if value)
131
132An unboxed value can occupy a car or cdr field in a cons cell.
133
134types (boxed) extra information in pointer to cell can contain information
135 - 32 bit integer
136 - 32 bit unsigned integer
137 - 32 bit float
138
139boxed representation:
140 [ptr| cdr]
141 |
142 [Value | Aux + GC_MARK]
143
144Kinds of pointers:
145 - Pointer to cons cell.
146 - Pointer to unboxed value (fixnums not in a list, I hope this is so rare that it can be removed )
147 - integer
148 - unsigned integer
149 - symbol
150 - float
151 - Pointer to boxed value.
152 - 32 bit integer
153 - 32 bit unsigned integer
154 - 32 bit float
155 - (Maybe something else ? Vectors/strings allocated in memory not occupied by heap?)
156 - vector of int
157 - vector of uint
158 - vector of float
159 - vector of double
160 - String
161
16213 pointer"types" -> needs 4 bits
163for 64MB heap there are 6 free bits. So with this scheme going to 128MB or 256MB heap
164is also possible
165
166 a pointer to some off heap vector/string could be represented by
167
168 [ptr | cdr]
169 |
170 [full pointer | Aux + GC_MARK]
171 |
172 [VECTOR]
173
174Aux bits could be used for storing vector size. Up to 30bits should be available there
175>> This is problematic. Now the information that something is a vector is split up
176>> between 2 cons cells. This means GC needs both of these intact to be able to make
177>> proper decision.
178>> Will try to resolve this by adding some special symbols. But these must be symbols
179>> that cannot occur normally in programs. Then an array could be:
180
181 [Full pointer | ARRAY_SYM + GC_MARK]
182 |
183 [VECTOR]
184
185>> Boxed values same treatment as above.
186>> TODO: Could this be simpler?
187
188[ VALUE | TYPE_SYM + GC_MARK]
189
190
1910000 00XX XXXX XXXX XXXX XXXX XXXX X000 : 0x03FF FFF8
1921111 AA00 0000 0000 0000 0000 0000 0000 : 0xFC00 0000 (AA bits left unused for now, future heap growth?)
193 */
194
195typedef enum {
196 LBM_FLASH_WRITE_OK,
197 LBM_FLASH_FULL,
198 LBM_FLASH_WRITE_ERROR
199} lbm_flash_status;
200
201/** Struct representing a heap cons-cell.
202 *
203 */
204typedef struct {
205 lbm_value car;
206 lbm_value cdr;
207} lbm_cons_t;
208
209/**
210 * Heap state
211 */
212typedef struct {
213 lbm_cons_t *heap;
214 lbm_value freelist; // list of free cons cells.
215 lbm_stack_t gc_stack;
216
217 lbm_uint heap_size; // In number of cells.
218 lbm_uint heap_bytes; // In bytes.
219
220 lbm_uint num_alloc; // Number of cells allocated.
221 lbm_uint num_alloc_arrays; // Number of arrays allocated.
222
223 lbm_uint gc_num; // Number of times gc has been performed.
224 lbm_uint gc_marked; // Number of cells marked by mark phase.
225 lbm_uint gc_recovered; // Number of cells recovered by sweep phase.
226 lbm_uint gc_recovered_arrays;// Number of arrays recovered by sweep.
227 lbm_uint gc_least_free; // The smallest length of the freelist.
228 lbm_uint gc_last_free; // Number of elements on the freelist
229 // after most recent GC.
230} lbm_heap_state_t;
231
232extern lbm_heap_state_t lbm_heap_state;
233
234typedef bool_Bool (*const_heap_write_fun)(lbm_uint ix, lbm_uint w);
235
236typedef struct {
237 lbm_uint *heap;
238 lbm_uint next; // next free index.
239 lbm_uint size; // in lbm_uint words. (cons-cells = words / 2)
240} lbm_const_heap_t;
241
242/**
243 * The header portion of an array stored in array and symbol memory.
244 * An array is always a byte array. use the array-extensions for
245 * storing and reading larger values from arrays.
246 */
247typedef struct {
248 lbm_uint size; /// Number of elements
249 lbm_uint *data; /// pointer to lbm_memory array or C array.
250} lbm_array_header_t;
251
252typedef struct {
253 lbm_uint size;
254 lbm_uint *data;
255 uint32_t index; // Limits arrays to max 2^32-1 elements.
256} lbm_array_header_extended_t;
257
258/** Lock GC mutex
259 * Locks a mutex during GC marking when using the pointer reversal algorithm.
260 * Does nothing when using stack based GC mark.
261 */
262void lbm_gc_lock(void);
263/* Unlock GC mutex
264 */
265void lbm_gc_unlock(void);
266
267/** Initialize heap storage.
268 * \param addr Pointer to an array of lbm_cons_t elements. This array must at least be aligned 4.
269 * \param num_cells Number of lbm_cons_t elements in the array.
270 * \param gc_stack_size Size of the gc_stack in number of words.
271 * \return 1 on success or 0 for failure.
272 */
273int lbm_heap_init(lbm_cons_t *addr, lbm_uint num_cells,
274 lbm_uint gc_stack_size);
275
276/** Add GC time statistics to heap_stats
277 *
278 * \param dur Duration as reported by the timestamp callback.
279 */
280void lbm_heap_new_gc_time(lbm_uint dur);
281/** Add a new free_list length to the heap_stats.
282 * Calculates a new freelist length and updates
283 * the GC statistics.
284 */
285void lbm_heap_new_freelist_length(void);
286/** Check how many lbm_cons_t cells are on the free-list
287 *
288 * \return Number of free lbm_cons_t cells.
289 */
290lbm_uint lbm_heap_num_free(void);
291/** Check how many lbm_cons_t cells are allocated.
292 *
293 * \return Number of lbm_cons_t cells that are currently allocated.
294 */
295lbm_uint lbm_heap_num_allocated(void);
296/** Size of the heap in number of lbm_cons_t cells.
297 *
298 * \return Size of the heap in number of lbm_cons_t cells.
299 */
300lbm_uint lbm_heap_size(void);
301/** Size of the heap in bytes.
302 *
303 * \return Size of heap in bytes.
304 */
305lbm_uint lbm_heap_size_bytes(void);
306/** Allocate an lbm_cons_t cell from the heap.
307 *
308 * \param type A type that can be encoded onto the cell (most often LBM_PTR_TYPE_CONS).
309 * \param car Value to write into car position of allocated cell.
310 * \param cdr Value to write into cdr position of allocated cell.
311 * \return An lbm_value referring to a cons_cell or enc_sym(SYM_MERROR) in case the heap is full.
312 */
313lbm_value lbm_heap_allocate_cell(lbm_type type, lbm_value car, lbm_value cdr);
314/** Allocate a list of n heap-cells.
315 * \param n The number of heap-cells to allocate.
316 * \return A list of heap-cells of Memory error if unable to allocate.
317 */
318lbm_value lbm_heap_allocate_list(lbm_uint n);
319/** Allocate a list of n heap-cells and initialize the values.
320 * \pram ls The result list is passed through this ptr.
321 * \param n The length of list to allocate.
322 * \param valist The values in a va_list to initialize the list with.
323 * \return True of False depending on success of allocation.
324 */
325lbm_value lbm_heap_allocate_list_init_va(unsigned int n, va_list valist);
326/** Allocate a list of n heap-cells and initialize the values.
327 * \param n The length of list to allocate.
328 * \param ... The values to initialize the list with.
329 * \return allocated list or error symbol.
330 */
331lbm_value lbm_heap_allocate_list_init(unsigned int n, ...);
332/** Decode an lbm_value representing a string into a C string
333 *
334 * \param val Value
335 * \return allocated list or error symbol
336 */
337char *lbm_dec_str(lbm_value val);
338/** Decode an lbm_value representing a char channel into an lbm_char_channel_t pointer.
339 *
340 * \param val Value
341 * \return A pointer to an lbm_char_channel_t or NULL if the value does not encode a channel.
342 */
343lbm_char_channel_t *lbm_dec_channel(lbm_value val);
344/** Decode an lbm_value representing a custom type into a lbm_uint value.
345 *
346 * \param val Value.
347 * \return The custom type payload.
348 */
349lbm_uint lbm_dec_custom(lbm_value val);
350/** Decode a numerical value as if it is char
351 *
352 * \param val Value to decode
353 * \return The value encoded in val casted to a char. Returns 0 if val does not encode a number.
354 */
355uint8_t lbm_dec_as_char(lbm_value a);
356/** Decode a numerical value as if it is unsigned
357 *
358 * \param val Value to decode
359 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
360 */
361uint32_t lbm_dec_as_u32(lbm_value val);
362/** Decode a numerical value as a signed integer.
363 *
364 * \param val Value to decode
365 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
366 */
367int32_t lbm_dec_as_i32(lbm_value val);
368/** Decode a numerical value as a float.
369 *
370 * \param val Value to decode.
371 * \return The value encoded in val casted to a float. Returns 0 if val does not encode a number.
372 */
373float lbm_dec_as_float(lbm_value val);
374/** Decode a numerical value as if it is a 64bit unsigned
375 *
376 * \param val Value to decode
377 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
378 */
379uint64_t lbm_dec_as_u64(lbm_value val);
380/** Decode a numerical value as a 64bit signed integer.
381 *
382 * \param val Value to decode
383 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
384 */
385int64_t lbm_dec_as_i64(lbm_value val);
386/** Decode a numerical value as a float.
387 *
388 * \param val Value to decode.
389 * \return The value encoded in val casted to a float. Returns 0 if val does not encode a number.
390 */
391double lbm_dec_as_double(lbm_value val);
392
393/** Decode a numerical value into the architecture defined unsigned integer type.
394 *
395 * \param val Value to decode
396 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
397 */
398lbm_uint lbm_dec_as_uint(lbm_value val);
399
400/** Decode a numerical value into the architecture defined signed integer type.
401 *
402 * \param val Value to decode
403 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
404 */
405lbm_int lbm_dec_as_int(lbm_value val);
406
407lbm_uint lbm_dec_raw(lbm_value v);
408/** Allocates an lbm_cons_t cell from the heap and populates it.
409 *
410 * \param car The value to put in the car field of the allocated lbm_cons_t.
411 * \param cdr The value to put in the cdr field of the allocated lbm_cons_t.
412 * \return A value referencing the lbm_cons_t or enc_sym(SYM_MERROR) if heap is full.
413 */
414lbm_value lbm_cons(lbm_value car, lbm_value cdr);
415
416/** Accesses the car field of an lbm_cons_t.
417 *
418 * \param cons Value
419 * \return The car field of the lbm_cons_t if cons is a reference to a heap cell.
420 * If cons is nil, the return value is nil. If the value
421 * is not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
422 */
423lbm_value lbm_car(lbm_value cons);
424/** Accesses the car field the car field of an lbm_cons_t.
425 *
426 * \param cons Value
427 * \return The car of car field or nil.
428 */
429lbm_value lbm_caar(lbm_value c);
430/** Accesses the car of the cdr of an cons cell
431 *
432 * \param c Value
433 * \return the cdr field or type error.
434 */
435lbm_value lbm_cadr(lbm_value c);
436/** Accesses the cdr field of an lbm_cons_t.
437 *
438 * \param cons Value
439 * \return The cdr field of the lbm_cons_t if cons is a reference to a heap cell.
440 * If cons is nil, the return value is nil. If the value
441 * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
442 */
443lbm_value lbm_cdr(lbm_value cons);
444/** Accesses the cdr of an cdr field of an lbm_cons_t.
445 *
446 * \param cons Value
447 * \return The cdr of the cdr field of the lbm_cons_t if cons is a reference to a heap cell.
448 * If cons is nil, the return value is nil. If the value
449 * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
450 */
451lbm_value lbm_cddr(lbm_value c);
452/** Update the value stored in the car field of a heap cell.
453 *
454 * \param c Value referring to a heap cell.
455 * \param v Value to replace the car field with.
456 * \return 1 on success and 0 if the c value does not refer to a heap cell.
457 */
458int lbm_set_car(lbm_value c, lbm_value v);
459/** Update the value stored in the cdr field of a heap cell.
460 *
461 * \param c Value referring to a heap cell.
462 * \param v Value to replace the cdr field with.
463 * \return 1 on success and 0 if the c value does not refer to a heap cell.
464 */
465int lbm_set_cdr(lbm_value c, lbm_value v);
466/** Update the value stored in the car and cdr fields of a heap cell.
467 *
468 * \param c Value referring to a heap cell.
469 * \param car_val Value to replace the car field with.
470 * \param cdr_val Value to replace the cdr field with.
471 * \return 1 on success and 0 if the c value does not refer to a heap cell.
472 */
473int lbm_set_car_and_cdr(lbm_value c, lbm_value car_val, lbm_value cdr_val);
474// List functions
475/** Calculate the length of a proper list
476 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
477 * may lead to the function not terminating.
478 *
479 * \param c A list
480 * \return The length of the list. Unless the value is a cyclic structure on the heap, this function will terminate.
481 */
482lbm_uint lbm_list_length(lbm_value c);
483
484/** Calculate the length of a proper list and evaluate a predicate for each element.
485 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
486 * may lead to the function not terminating.
487 *
488 * \param c A list
489 * \param pres Boolean result of predicate, false if predicate is false for any of the elements in the list, otherwise true.
490 * \param pred Predicate to evaluate for each element of the list.
491 */
492unsigned int lbm_list_length_pred(lbm_value c, bool_Bool *pres, bool_Bool (*pred)(lbm_value));
493/** Reverse a proper list
494 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
495 * may lead to the function not terminating.
496 *
497 * \param list A list
498 * \return The list reversed or enc_sym(SYM_MERROR) if heap is full.
499 */
500lbm_value lbm_list_reverse(lbm_value list);
501/** Reverse a proper list destroying the original.
502 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
503 * may lead to the function not terminating.
504 *
505 * \param list A list
506 * \return The list reversed
507 */
508lbm_value lbm_list_destructive_reverse(lbm_value list);
509/** Copy a list
510 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
511 * may lead to the function not terminating.
512 *
513 * \param m Number of elements to copy or -1 for all. If 1, m will be updated with the length of the list
514 * \param list A list.
515 * \return Reversed list or enc_sym(SYM_MERROR) if heap is full.
516 */
517lbm_value lbm_list_copy(int *m, lbm_value list);
518
519/** A destructive append of two lists
520 *
521 * \param list1 A list
522 * \param list2 A list
523 * \return list1 with list2 appended at the end.
524 */
525lbm_value lbm_list_append(lbm_value list1, lbm_value list2);
526
527/** Drop values from the head of a list.
528 * \param n Number of values to drop.
529 * \param ls List to drop values from.
530 * \return The list with the n first elements removed.
531 */
532lbm_value lbm_list_drop(unsigned int n, lbm_value ls);
533/** Index into a list.
534 * \param l List to index into.
535 * \param n Position to read out of the list.
536 * \return Value at position n of l or nil if out of bounds.
537 */
538lbm_value lbm_index_list(lbm_value l, int32_t n);
539
540// State and statistics
541/** Get a copy of the heap statistics structure.
542 *
543 * \param A pointer to an lbm_heap_state_t to populate
544 * with the current statistics.
545 */
546void lbm_get_heap_state(lbm_heap_state_t *);
547/** Get the maximum stack level of the GC stack
548 * \return maximum value the gc stack sp reached so far.
549 */
550lbm_uint lbm_get_gc_stack_max(void);
551/** Get the size of the GC stack.
552 * \return the size of the gc stack.
553 */
554lbm_uint lbm_get_gc_stack_size(void);
555// Garbage collection
556/** Increment the counter that is counting the number of times GC ran
557 *
558 */
559void lbm_gc_state_inc(void);
560/** Set the freelist to NIL. Means that no memory will be available
561 * until after a garbage collection.
562 */
563void lbm_nil_freelist(void);
564/** Mark all heap cells reachable from an environment.
565 * \param environment.
566 */
567void lbm_gc_mark_env(lbm_value);
568/** Mark heap cells reachable from the lbm_value v.
569 * \param root
570 */
571void lbm_gc_mark_phase(lbm_value root);
572/** Performs lbm_gc_mark_phase on all the values of an array.
573 * This function is similar to lbm_gc_mark_roots but performs
574 * extra checks to not traverse into non-standard values.
575 * TODO: Check if this function is really needed.
576 * \param data Array of roots to traverse from.
577 * \param n Number of elements in roots-array.
578 */
579void lbm_gc_mark_aux(lbm_uint *data, lbm_uint n);
580/** Performs lbm_gc_mark_phase on all the values in the roots array.
581 * \param roots pointer to array of roots.
582 * \param num_roots size of array of roots.
583 */
584void lbm_gc_mark_roots(lbm_uint *roots, lbm_uint num_roots);
585/** Sweep up all non marked heap cells and place them on the free list.
586 *
587 * \return 1
588 */
589int lbm_gc_sweep_phase(void);
590
591// Array functionality
592/** Allocate an bytearray in symbols and arrays memory (lispbm_memory.h)
593 * and create a heap cell that refers to this bytearray.
594 * \param res The resulting lbm_value is returned through this argument.
595 * \param size Array size in number of 32 bit words.
596 * \return 1 for success of 0 for failure.
597 */
598int lbm_heap_allocate_array(lbm_value *res, lbm_uint size);
599/** Allocate an array in symbols and arrays memory (lispbm_memory.h)
600 * and create a heap cell that refers to this array.
601 * \param res The resulting lbm_value is returned through this argument.
602 * \param size Array size in number of 32 bit words.
603 * \return 1 for success of 0 for failure.
604 */
605int lbm_heap_allocate_lisp_array(lbm_value *res, lbm_uint size);
606/** Convert a C array into an lbm array. If the C array is allocated in LBM MEMORY
607 * the lifetime of the array will be managed by GC.
608 * \param res lbm_value result pointer for storage of the result array.
609 * \param data C array.
610 * \param type The type tag to assign to the resulting LBM array.
611 * \param num_elt Number of elements in the array.
612 * \return 1 for success and 0 for failure.
613 */
614int lbm_lift_array(lbm_value *value, char *data, lbm_uint num_elt);
615/** Get the size of an array value.
616 * \param arr lbm_value array to get size of.
617 * \return -1 for failure or length of array.
618 */
619lbm_int lbm_heap_array_get_size(lbm_value arr);
620/** Get a pointer to the data of an array for read only purposes.
621 * \param arr lbm_value array to get pointer from.
622 * \return NULL or valid pointer.
623 */
624const uint8_t *lbm_heap_array_get_data_ro(lbm_value arr);
625/** Get a pointer to the data of an array for read/write purposes.
626 * \param arr lbm_value array to get pointer from.
627 * \return NULL or valid pointer.
628 */
629uint8_t *lbm_heap_array_get_data_rw(lbm_value arr);
630/** Explicitly free an array.
631 * This function needs to be used with care and knowledge.
632 * \param arr Array value.
633 */
634int lbm_heap_explicit_free_array(lbm_value arr);
635/** Query the size in bytes of an lbm_type.
636 * \param t Type
637 * \return Size in bytes of type or 0 if the type represents a composite.
638 */
639lbm_uint lbm_size_of(lbm_type t);
640
641int lbm_const_heap_init(const_heap_write_fun w_fun,
642 lbm_const_heap_t *heap,
643 lbm_uint *addr,
644 lbm_uint num_words);
645
646lbm_flash_status lbm_allocate_const_cell(lbm_value *res);
647lbm_flash_status lbm_write_const_raw(lbm_uint *data, lbm_uint n, lbm_uint *res);
648lbm_flash_status lbm_allocate_const_raw(lbm_uint nwords, lbm_uint *res);
649lbm_flash_status write_const_cdr(lbm_value cell, lbm_value val);
650lbm_flash_status write_const_car(lbm_value cell, lbm_value val);
651lbm_flash_status lbm_const_write(lbm_uint *tgt, lbm_uint val);
652lbm_uint lbm_flash_memory_usage(void);
653
654/** Query the type information of a value.
655 *
656 * \param x Value to check the type of.
657 * \return The type information.
658 */
659static inline lbm_type lbm_type_of(lbm_value x) {
660 return (x & LBM_PTR_BIT0x00000001u) ? (x & LBM_PTR_TYPE_MASK0xFC000000u) : (x & LBM_VAL_TYPE_MASK0x0000000Cu);
661}
662
663// type-of check that is safe in functional code
664static inline lbm_type lbm_type_of_functional(lbm_value x) {
665 return (x & LBM_PTR_BIT0x00000001u) ?
666 (x & (LBM_PTR_TO_CONSTANT_MASK~0x04000000u & LBM_PTR_TYPE_MASK0xFC000000u)) :
667 (x & LBM_VAL_TYPE_MASK0x0000000Cu);
668}
669
670static inline lbm_value lbm_enc_cons_ptr(lbm_uint x) {
671 return ((x << LBM_ADDRESS_SHIFT2) | LBM_TYPE_CONS0x10000000u | LBM_PTR_BIT0x00000001u);
672}
673
674static inline lbm_uint lbm_dec_ptr(lbm_value p) {
675 return ((LBM_PTR_VAL_MASK0x03FFFFFCu & p) >> LBM_ADDRESS_SHIFT2);
676}
677
678extern lbm_cons_t *lbm_heaps[2];
679
680static inline lbm_uint lbm_dec_cons_cell_ptr(lbm_value p) {
681 lbm_uint h = (p & LBM_PTR_TO_CONSTANT_BIT0x04000000u) >> LBM_PTR_TO_CONSTANT_SHIFT26;
682 return lbm_dec_ptr(p) >> h;
683}
684
685static inline lbm_cons_t *lbm_dec_heap(lbm_value p) {
686 lbm_uint h = (p & LBM_PTR_TO_CONSTANT_BIT0x04000000u) >> LBM_PTR_TO_CONSTANT_SHIFT26;
687 return lbm_heaps[h];
688}
689
690static inline lbm_value lbm_set_ptr_type(lbm_value p, lbm_type t) {
691 return ((LBM_PTR_VAL_MASK0x03FFFFFCu & p) | t | LBM_PTR_BIT0x00000001u);
692}
693
694static inline lbm_value lbm_enc_sym(lbm_uint s) {
695 return (s << LBM_VAL_SHIFT4) | LBM_TYPE_SYMBOL0x00000000u;
696}
697
698static inline lbm_value lbm_enc_i(lbm_int x) {
699 return ((lbm_uint)x << LBM_VAL_SHIFT4) | LBM_TYPE_I0x00000008u;
700}
701
702static inline lbm_value lbm_enc_u(lbm_uint x) {
703 return (x << LBM_VAL_SHIFT4) | LBM_TYPE_U0x0000000Cu;
704}
705
706/** Encode 32 bit integer into an lbm_value.
707 * \param x Value to encode.
708 * \return result encoded value.
709 */
710extern lbm_value lbm_enc_i32(int32_t x);
711
712/** Encode 32 bit unsigned integer into an lbm_value.
713 * \param x Value to encode.
714 * \return result encoded value.
715 */
716extern lbm_value lbm_enc_u32(uint32_t x);
717
718/** Encode a float into an lbm_value.
719 * \param x float value to encode.
720 * \return result encoded value.
721 */
722extern lbm_value lbm_enc_float(float x);
723
724/** Encode a 64 bit integer into an lbm_value.
725 * \param x 64 bit integer to encode.
726 * \return result encoded value.
727 */
728extern lbm_value lbm_enc_i64(int64_t x);
729
730/** Encode a 64 bit unsigned integer into an lbm_value.
731 * \param x 64 bit unsigned integer to encode.
732 * \return result encoded value.
733 */
734extern lbm_value lbm_enc_u64(uint64_t x);
735
736/** Encode a double into an lbm_value.
737 * \param x double to encode.
738 * \return result encoded value.
739 */
740extern lbm_value lbm_enc_double(double x);
741
742static inline lbm_value lbm_enc_char(uint8_t x) {
743 return ((lbm_uint)x << LBM_VAL_SHIFT4) | LBM_TYPE_CHAR0x00000004u;
744}
745
746static inline lbm_int lbm_dec_i(lbm_value x) {
747 return (lbm_int)x >> LBM_VAL_SHIFT4;
748}
749
750static inline lbm_uint lbm_dec_u(lbm_value x) {
751 return x >> LBM_VAL_SHIFT4;
752}
753
754static inline uint8_t lbm_dec_char(lbm_value x) {
755 return (uint8_t)(x >> LBM_VAL_SHIFT4);
756}
757
758static inline lbm_uint lbm_dec_sym(lbm_value x) {
759 return x >> LBM_VAL_SHIFT4;
760}
761
762/** Decode an lbm_value representing a float.
763 * \param x Value to decode.
764 * \return decoded float.
765 */
766extern float lbm_dec_float(lbm_value x);
767
768/** Decode an lbm_value representing a double.
769 * \param x Value to decode.
770 * \return decoded float.
771 */
772extern double lbm_dec_double(lbm_value x);
773
774
775static inline uint32_t lbm_dec_u32(lbm_value x) {
776#ifndef LBM64
777 return (uint32_t)lbm_car(x);
778#else
779 return (uint32_t)(x >> LBM_VAL_SHIFT4);
780#endif
781}
782
783/** Decode an lbm_value representing a 64 bit unsigned integer.
784 * \param x Value to decode.
785 * \return decoded uint64_t.
786 */
787extern uint64_t lbm_dec_u64(lbm_value x);
788
789static inline int32_t lbm_dec_i32(lbm_value x) {
790#ifndef LBM64
791 return (int32_t)lbm_car(x);
792#else
793 return (int32_t)(x >> LBM_VAL_SHIFT4);
794#endif
795}
796
797/** Decode an lbm_value representing a 64 bit integer.
798 * \param x Value to decode.
799 * \return decoded int64_t.
800 */
801extern int64_t lbm_dec_i64(lbm_value x);
802
803/**
804 * Check if a value is a heap pointer
805 * \param x Value to check
806 * \return true if x is a pointer to a heap cell, false otherwise.
807 */
808static inline bool_Bool lbm_is_ptr(lbm_value x) {
809 return (x & LBM_PTR_BIT0x00000001u);
810}
811
812/**
813 * Check if a value is a Read/Writeable cons cell
814 * \param x Value to check
815 * \return true if x is a Read/Writeable cons cell, false otherwise.
816 */
817static inline bool_Bool lbm_is_cons_rw(lbm_value x) {
818 return (lbm_type_of(x) == LBM_TYPE_CONS0x10000000u);
819}
820
821/**
822 * Check if a value is a Readable cons cell
823 * \param x Value to check
824 * \return true if x is a readable cons cell, false otherwise.
825 */
826static inline bool_Bool lbm_is_cons(lbm_value x) {
827 return lbm_is_ptr(x) && ((x & LBM_CONS_TYPE_MASK0xF0000000u) == LBM_TYPE_CONS0x10000000u);
828}
829
830/** Check if a value represents a number
831 * \param x Value to check.
832 * \return true is x represents a number and false otherwise.
833 */
834static inline bool_Bool lbm_is_number(lbm_value x) {
835 return
836 (x & LBM_PTR_BIT0x00000001u) ?
837 ((x & LBM_NUMBER_MASK0x08000000u) == LBM_NUMBER_MASK0x08000000u) :
838 (x & LBM_VAL_TYPE_MASK0x0000000Cu);
839}
840
841/** Check if value is an array that can be READ
842 * \param x Value to check.
843 * \return true if x represents a readable array and false otherwise.
844 */
845static inline bool_Bool lbm_is_array_r(lbm_value x) {
846 lbm_type t = lbm_type_of(x);
847 return ((t & LBM_PTR_TO_CONSTANT_MASK~0x04000000u) == LBM_TYPE_ARRAY0x80000000u);
848}
849
850static inline bool_Bool lbm_is_array_rw(lbm_value x) {
851 return( (lbm_type_of(x) == LBM_TYPE_ARRAY0x80000000u) && !(x & LBM_PTR_TO_CONSTANT_BIT0x04000000u));
852}
853
854static inline bool_Bool lbm_is_lisp_array_r(lbm_value x) {
855 lbm_type t = lbm_type_of(x);
856 return ((t & LBM_PTR_TO_CONSTANT_MASK~0x04000000u) == LBM_TYPE_LISPARRAY0xB0000000u);
857}
858
859static inline bool_Bool lbm_is_lisp_array_rw(lbm_value x) {
860 return( (lbm_type_of(x) == LBM_TYPE_LISPARRAY0xB0000000u) && !(x & LBM_PTR_TO_CONSTANT_BIT0x04000000u));
861}
862
863
864static inline bool_Bool lbm_is_channel(lbm_value x) {
865 return (lbm_type_of(x) == LBM_TYPE_CHANNEL0x90000000u &&
866 lbm_type_of(lbm_cdr(x)) == LBM_TYPE_SYMBOL0x00000000u &&
867 lbm_cdr(x) == ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
868}
869static inline bool_Bool lbm_is_char(lbm_value x) {
870 return (lbm_type_of(x) == LBM_TYPE_CHAR0x00000004u);
871}
872
873static inline bool_Bool lbm_is_special(lbm_value symrep) {
874 return ((lbm_type_of(symrep) == LBM_TYPE_SYMBOL0x00000000u) &&
875 (lbm_dec_sym(symrep) < SPECIAL_SYMBOLS_END0xFFFF));
876}
877
878static inline bool_Bool lbm_is_closure(lbm_value exp) {
879 return ((lbm_is_cons(exp)) &&
880 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
881 (lbm_car(exp) == ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u)));
882}
883
884static inline bool_Bool lbm_is_continuation(lbm_value exp) {
885 return ((lbm_type_of(exp) == LBM_TYPE_CONS0x10000000u) &&
886 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
887 (lbm_car(exp) == ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u)));
888}
889
890static inline bool_Bool lbm_is_macro(lbm_value exp) {
891 return ((lbm_type_of(exp) == LBM_TYPE_CONS0x10000000u) &&
892 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
893 (lbm_car(exp) == ENC_SYM_MACRO(((0x10D) << 4) | 0x00000000u)));
894}
895
896static inline bool_Bool lbm_is_match_binder(lbm_value exp) {
897 return (lbm_is_cons(exp) &&
898 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
899 (lbm_car(exp) == ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u)));
900}
901
902static inline bool_Bool lbm_is_comma_qualified_symbol(lbm_value exp) {
903 return (lbm_is_cons(exp) &&
904 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
905 (lbm_car(exp) == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) &&
906 (lbm_type_of(lbm_cadr(exp)) == LBM_TYPE_SYMBOL0x00000000u));
907}
908
909static inline bool_Bool lbm_is_symbol(lbm_value exp) {
910 return !(exp & LBM_LOW_RESERVED_BITS0x0000000Fu);
911}
912
913static inline bool_Bool lbm_is_symbol_nil(lbm_value exp) {
914 return !exp;
2
←
Assuming 'exp' is not equal to 0, which participates in a condition later
→
3
←
Returning zero, which participates in a condition later
→
915}
916
917static inline bool_Bool lbm_is_symbol_true(lbm_value exp) {
918 return (lbm_is_symbol(exp) && exp == ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u));
919}
920
921static inline bool_Bool lbm_is_symbol_eval(lbm_value exp) {
922 return (lbm_is_symbol(exp) && exp == ENC_SYM_EVAL(((0x30008) << 4) | 0x00000000u));
923}
924
925static inline bool_Bool lbm_is_symbol_merror(lbm_value exp) {
926 return lbm_is_symbol(exp) && (exp == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
927}
928
929static inline bool_Bool lbm_is_list(lbm_value x) {
930 return (lbm_is_cons(x) || lbm_is_symbol_nil(x));
931}
932
933static inline bool_Bool lbm_is_list_rw(lbm_value x) {
934 return (lbm_is_cons_rw(x) || lbm_is_symbol_nil(x));
935}
936
937static inline bool_Bool lbm_is_quoted_list(lbm_value x) {
938 return (lbm_is_cons(x) &&
939 lbm_is_symbol(lbm_car(x)) &&
940 (lbm_car(x) == ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u)) &&
941 lbm_is_cons(lbm_cdr(x)) &&
942 lbm_is_cons(lbm_cadr(x)));
943}
944
945#ifndef LBM64
946#define ERROR_SYMBOL_MASK0xFFFFFFF0 0xFFFFFFF0
947#else
948#define ERROR_SYMBOL_MASK0xFFFFFFF0 0xFFFFFFFFFFFFFFF0
949#endif
950
951/* all error signaling symbols are in the range 0x20 - 0x2F */
952static inline bool_Bool lbm_is_error(lbm_value v){
953 return (lbm_is_symbol(v) &&
954 ((lbm_dec_sym(v) & ERROR_SYMBOL_MASK0xFFFFFFF0) == 0x20));
955}
956
957// ref_cell: returns a reference to the cell addressed by bits 3 - 26
958// Assumes user has checked that is_ptr was set
959static inline lbm_cons_t* lbm_ref_cell(lbm_value addr) {
960 return &lbm_dec_heap(addr)[lbm_dec_cons_cell_ptr(addr)];
961 //return &lbm_heap_state.heap[lbm_dec_ptr(addr)];
962}
963
964
965// lbm_uint a = lbm_heaps[0];
966// lbm_uint b = lbm_heaps[1];
967// lbm_uint i = (addr & LBM_PTR_TO_CONSTANT_BIT) >> LBM_PTR_TO_CONSTANT_SHIFT) - 1;
968// lbm_uint h = (a & i) | (b & ~i);
969
970#ifdef __cplusplus
971}
972#endif
973#endif
diff --git a/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-ebe0ba.html b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-ebe0ba.html new file mode 100644 index 00000000..fa86c9a6 --- /dev/null +++ b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-ebe0ba.html @@ -0,0 +1,2797 @@ + + + +src/heap.c + + + + + + + + + + + + + + + + + + + + + + + + + + +

Bug Summary

+ + + + +
File:heap.c
Warning:line 1259, column 19
Access to field 'data' results in a dereference of a null pointer (loaded from variable 'header')
+ +

Annotated Source Code

+

Press '?' + to see keyboard shortcuts

+ + +
clang -cc1 -triple i386-pc-linux-gnu -analyze -disable-free -disable-llvm-verifier -discard-value-names -main-file-name heap.c -analyzer-store=region -analyzer-opt-analyze-nested-blocks -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -mrelocation-model static -mthread-model posix -mframe-pointer=none -fmath-errno -fno-rounding-math -masm-verbose -mconstructor-aliases -target-cpu i686 -dwarf-column-info -fno-split-dwarf-inlining -debugger-tuning=gdb -resource-dir /usr/lib/llvm-10/lib/clang/10.0.0 -I ./include -I ./include/extensions -I platform/linux/include -D _PRELUDE -internal-isystem /usr/local/include -internal-isystem /usr/lib/llvm-10/lib/clang/10.0.0/include -internal-externc-isystem /usr/include/i386-linux-gnu -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -std=c99 -fdebug-compilation-dir /home/joels/Current/lispbm -ferror-limit 19 -fmessage-length 0 -fgnuc-version=4.2.1 -fobjc-runtime=gcc -fdiagnostics-show-option -vectorize-loops -vectorize-slp -analyzer-output=html -faddrsig -o /home/joels/Current/lispbm/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1 -x c src/heap.c +
+ + + +
+ + +
+ + + + +
+

src/heap.c

+
→
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1/*
2 Copyright 2018, 2020, 2022 - 2024 Joel Svensson svenssonjoel@yahoo.se
3 2022 Benjamin Vedder
4
5 This program is free software: you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation, either version 3 of the License, or
8 (at your option) any later version.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
14
15 You should have received a copy of the GNU General Public License
16 along with this program. If not, see <http://www.gnu.org/licenses/>.
17*/
18
19#include <stdio.h>
20#include <stdlib.h>
21#include <stdint.h>
22#include <stdarg.h>
23#include <inttypes.h>
24#include <lbm_memory.h>
25#include <lbm_custom_type.h>
26
27#include "heap.h"
28#include "symrepr.h"
29#include "stack.h"
30#include "lbm_channel.h"
31#include "platform_mutex.h"
32#include "eval_cps.h"
33#ifdef VISUALIZE_HEAP
34#include "heap_vis.h"
35#endif
36
37
38static inline lbm_value lbm_set_gc_mark(lbm_value x) {
39 return x | LBM_GC_MARKED0x00000002u;
40}
41
42static inline lbm_value lbm_clr_gc_mark(lbm_value x) {
43 return x & ~LBM_GC_MASK0x00000002u;
44}
45
46static inline bool_Bool lbm_get_gc_mark(lbm_value x) {
47 return x & LBM_GC_MASK0x00000002u;
48}
49
50// flag is the same bit as mark, but in car
51static inline bool_Bool lbm_get_gc_flag(lbm_value x) {
52 return x & LBM_GC_MARKED0x00000002u;
53}
54
55static inline lbm_value lbm_set_gc_flag(lbm_value x) {
56 return x | LBM_GC_MARKED0x00000002u;
57}
58
59static inline lbm_value lbm_clr_gc_flag(lbm_value x) {
60 return x & ~LBM_GC_MASK0x00000002u;
61}
62
63
64lbm_heap_state_t lbm_heap_state;
65
66lbm_const_heap_t *lbm_const_heap_state;
67
68lbm_cons_t *lbm_heaps[2] = {NULL((void*)0), NULL((void*)0)};
69
70static mutex_t lbm_const_heap_mutex;
71static bool_Bool lbm_const_heap_mutex_initialized = false0;
72
73static mutex_t lbm_mark_mutex;
74static bool_Bool lbm_mark_mutex_initialized = false0;
75
76#ifdef USE_GC_PTR_REV
77void lbm_gc_lock(void) {
78 mutex_lock(&lbm_mark_mutex);
79}
80void lbm_gc_unlock(void) {
81 mutex_unlock(&lbm_mark_mutex);
82}
83#else
84void lbm_gc_lock(void) {
85}
86void lbm_gc_unlock(void) {
87}
88#endif
89
90/****************************************************/
91/* ENCODERS DECODERS */
92
93lbm_value lbm_enc_i32(int32_t x) {
94#ifndef LBM64
95 lbm_value i = lbm_cons((lbm_uint)x, ENC_SYM_RAW_I_TYPE(((0x31) << 4) | 0x00000000u));
96 if (lbm_type_of(i) == LBM_TYPE_SYMBOL0x00000000u) return i;
97 return lbm_set_ptr_type(i, LBM_TYPE_I320x28000000u);
98#else
99 return (((lbm_uint)x) << LBM_VAL_SHIFT4) | LBM_TYPE_I320x28000000u;
100#endif
101}
102
103lbm_value lbm_enc_u32(uint32_t x) {
104#ifndef LBM64
105 lbm_value u = lbm_cons(x, ENC_SYM_RAW_U_TYPE(((0x32) << 4) | 0x00000000u));
106 if (lbm_type_of(u) == LBM_TYPE_SYMBOL0x00000000u) return u;
107 return lbm_set_ptr_type(u, LBM_TYPE_U320x38000000u);
108#else
109 return (((lbm_uint)x) << LBM_VAL_SHIFT4) | LBM_TYPE_U320x38000000u;
110#endif
111}
112
113lbm_value lbm_enc_float(float x) {
114#ifndef LBM64
115 lbm_uint t;
116 memcpy(&t, &x, sizeof(lbm_float));
117 lbm_value f = lbm_cons(t, ENC_SYM_RAW_F_TYPE(((0x33) << 4) | 0x00000000u));
118 if (lbm_type_of(f) == LBM_TYPE_SYMBOL0x00000000u) return f;
119 return lbm_set_ptr_type(f, LBM_TYPE_FLOAT0x68000000u);
120#else
121 lbm_uint t = 0;
122 memcpy(&t, &x, sizeof(float));
123 return (((lbm_uint)t) << LBM_VAL_SHIFT4) | LBM_TYPE_FLOAT0x68000000u;
124#endif
125}
126
127static lbm_value enc_64_on_32(uint8_t *source, lbm_uint type_qual, lbm_uint type) {
128 lbm_value res = ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u);
129 res = lbm_cons(ENC_SYM_NIL(((0x0) << 4) | 0x00000000u),ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
130 if (lbm_type_of(res) != LBM_TYPE_SYMBOL0x00000000u) {
131 uint8_t* storage = lbm_malloc(sizeof(uint64_t));
132 if (storage) {
133 memcpy(storage,source, sizeof(uint64_t));
134 lbm_set_car_and_cdr(res, (lbm_uint)storage, type_qual);
135 res = lbm_set_ptr_type(res, type);
136 } else {
137 res = ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u);
138 }
139 }
140 return res;
141}
142
143lbm_value lbm_enc_i64(int64_t x) {
144#ifndef LBM64
145 return enc_64_on_32((uint8_t *)&x, ENC_SYM_IND_I_TYPE(((0x34) << 4) | 0x00000000u), LBM_TYPE_I640x48000000u);
146#else
147 lbm_value u = lbm_cons((uint64_t)x, ENC_SYM_RAW_I_TYPE(((0x31) << 4) | 0x00000000u));
148 if (lbm_type_of(u) == LBM_TYPE_SYMBOL0x00000000u) return u;
149 return lbm_set_ptr_type(u, LBM_TYPE_I640x48000000u);
150#endif
151}
152
153lbm_value lbm_enc_u64(uint64_t x) {
154#ifndef LBM64
155 return enc_64_on_32((uint8_t *)&x, ENC_SYM_IND_U_TYPE(((0x35) << 4) | 0x00000000u), LBM_TYPE_U640x58000000u);
156#else
157 lbm_value u = lbm_cons(x, ENC_SYM_RAW_U_TYPE(((0x32) << 4) | 0x00000000u));
158 if (lbm_type_of(u) == LBM_TYPE_SYMBOL0x00000000u) return u;
159 return lbm_set_ptr_type(u, LBM_TYPE_U640x58000000u);
160#endif
161}
162
163lbm_value lbm_enc_double(double x) {
164#ifndef LBM64
165 return enc_64_on_32((uint8_t *)&x, ENC_SYM_IND_F_TYPE(((0x36) << 4) | 0x00000000u), LBM_TYPE_DOUBLE0x78000000u);
166#else
167 lbm_uint t;
168 memcpy(&t, &x, sizeof(double));
169 lbm_value f = lbm_cons(t, ENC_SYM_RAW_F_TYPE(((0x33) << 4) | 0x00000000u));
170 if (lbm_type_of(f) == LBM_TYPE_SYMBOL0x00000000u) return f;
171 return lbm_set_ptr_type(f, LBM_TYPE_DOUBLE0x78000000u);
172#endif
173}
174
175// Type specific (as opposed to the dec_as_X) functions
176// should only be run on values KNOWN to represent a value of the type
177// that the decoder decodes.
178
179float lbm_dec_float(lbm_value x) {
180#ifndef LBM64
181 float f_tmp;
182 lbm_uint tmp = lbm_car(x);
183 memcpy(&f_tmp, &tmp, sizeof(float));
184 return f_tmp;
185#else
186 uint32_t tmp = (uint32_t)(x >> LBM_VAL_SHIFT4);
187 float f_tmp;
188 memcpy(&f_tmp, &tmp, sizeof(float));
189 return f_tmp;
190#endif
191}
192
193double lbm_dec_double(lbm_value x) {
194#ifndef LBM64
195 double d;
196 uint32_t *data = (uint32_t*)lbm_car(x);
197 memcpy(&d, data, sizeof(double));
198 return d;
199#else
200 double f_tmp;
201 lbm_uint tmp = lbm_car(x);
202 memcpy(&f_tmp, &tmp, sizeof(double));
203 return f_tmp;
204#endif
205}
206
207uint64_t lbm_dec_u64(lbm_value x) {
208#ifndef LBM64
209 uint64_t u;
210 uint32_t *data = (uint32_t*)lbm_car(x);
211 memcpy(&u, data, 8);
212 return u;
213#else
214 return (uint64_t)lbm_car(x);
215#endif
216}
217
218int64_t lbm_dec_i64(lbm_value x) {
219#ifndef LBM64
220 int64_t i;
221 uint32_t *data = (uint32_t*)lbm_car(x);
222 memcpy(&i, data, 8);
223 return i;
224#else
225 return (int64_t)lbm_car(x);
226#endif
227}
228
229char *lbm_dec_str(lbm_value val) {
230 char *res = 0;
231 // If val is an array, car of val will be non-null.
232 if (lbm_is_array_r(val)) {
233 lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(val);
234 res = (char *)array->data;
235 }
236 return res;
237}
238
239lbm_char_channel_t *lbm_dec_channel(lbm_value val) {
240 lbm_char_channel_t *res = NULL((void*)0);
241
242 if (lbm_type_of(val) == LBM_TYPE_CHANNEL0x90000000u) {
243 res = (lbm_char_channel_t *)lbm_car(val);
244 }
245 return res;
246}
247
248lbm_uint lbm_dec_custom(lbm_value val) {
249 lbm_uint res = 0;
250 if (lbm_type_of(val) == LBM_TYPE_CUSTOM0xA0000000u) {
251 res = (lbm_uint)lbm_car(val);
252 }
253 return res;
254}
255
256uint8_t lbm_dec_as_char(lbm_value a) {
257 switch (lbm_type_of_functional(a)) {
258 case LBM_TYPE_CHAR0x00000004u:
259 return (uint8_t) lbm_dec_char(a);
260 case LBM_TYPE_I0x00000008u:
261 return (uint8_t) lbm_dec_i(a);
262 case LBM_TYPE_U0x0000000Cu:
263 return (uint8_t) lbm_dec_u(a);
264 case LBM_TYPE_I320x28000000u:
265 return (uint8_t) lbm_dec_i32(a);
266 case LBM_TYPE_U320x38000000u:
267 return (uint8_t) lbm_dec_u32(a);
268 case LBM_TYPE_FLOAT0x68000000u:
269 return (uint8_t)lbm_dec_float(a);
270 case LBM_TYPE_I640x48000000u:
271 return (uint8_t) lbm_dec_i64(a);
272 case LBM_TYPE_U640x58000000u:
273 return (uint8_t) lbm_dec_u64(a);
274 case LBM_TYPE_DOUBLE0x78000000u:
275 return (uint8_t) lbm_dec_double(a);
276 }
277 return 0;
278}
279
280uint32_t lbm_dec_as_u32(lbm_value a) {
281 switch (lbm_type_of_functional(a)) {
282 case LBM_TYPE_CHAR0x00000004u:
283 return (uint32_t) lbm_dec_char(a);
284 case LBM_TYPE_I0x00000008u:
285 return (uint32_t) lbm_dec_i(a);
286 case LBM_TYPE_U0x0000000Cu:
287 return (uint32_t) lbm_dec_u(a);
288 case LBM_TYPE_I320x28000000u: /* fall through */
289 case LBM_TYPE_U320x38000000u:
290 return (uint32_t) lbm_dec_u32(a);
291 case LBM_TYPE_FLOAT0x68000000u:
292 return (uint32_t)lbm_dec_float(a);
293 case LBM_TYPE_I640x48000000u:
294 return (uint32_t) lbm_dec_i64(a);
295 case LBM_TYPE_U640x58000000u:
296 return (uint32_t) lbm_dec_u64(a);
297 case LBM_TYPE_DOUBLE0x78000000u:
298 return (uint32_t) lbm_dec_double(a);
299 }
300 return 0;
301}
302
303int32_t lbm_dec_as_i32(lbm_value a) {
304 switch (lbm_type_of_functional(a)) {
305 case LBM_TYPE_CHAR0x00000004u:
306 return (int32_t) lbm_dec_char(a);
307 case LBM_TYPE_I0x00000008u:
308 return (int32_t) lbm_dec_i(a);
309 case LBM_TYPE_U0x0000000Cu:
310 return (int32_t) lbm_dec_u(a);
311 case LBM_TYPE_I320x28000000u:
312 return (int32_t) lbm_dec_i32(a);
313 case LBM_TYPE_U320x38000000u:
314 return (int32_t) lbm_dec_u32(a);
315 case LBM_TYPE_FLOAT0x68000000u:
316 return (int32_t) lbm_dec_float(a);
317 case LBM_TYPE_I640x48000000u:
318 return (int32_t) lbm_dec_i64(a);
319 case LBM_TYPE_U640x58000000u:
320 return (int32_t) lbm_dec_u64(a);
321 case LBM_TYPE_DOUBLE0x78000000u:
322 return (int32_t) lbm_dec_double(a);
323
324 }
325 return 0;
326}
327
328int64_t lbm_dec_as_i64(lbm_value a) {
329 switch (lbm_type_of_functional(a)) {
330 case LBM_TYPE_CHAR0x00000004u:
331 return (int64_t) lbm_dec_char(a);
332 case LBM_TYPE_I0x00000008u:
333 return lbm_dec_i(a);
334 case LBM_TYPE_U0x0000000Cu:
335 return (int64_t) lbm_dec_u(a);
336 case LBM_TYPE_I320x28000000u:
337 return (int64_t) lbm_dec_i32(a);
338 case LBM_TYPE_U320x38000000u:
339 return (int64_t) lbm_dec_u32(a);
340 case LBM_TYPE_FLOAT0x68000000u:
341 return (int64_t) lbm_dec_float(a);
342 case LBM_TYPE_I640x48000000u:
343 return (int64_t) lbm_dec_i64(a);
344 case LBM_TYPE_U640x58000000u:
345 return (int64_t) lbm_dec_u64(a);
346 case LBM_TYPE_DOUBLE0x78000000u:
347 return (int64_t) lbm_dec_double(a);
348 }
349 return 0;
350}
351
352uint64_t lbm_dec_as_u64(lbm_value a) {
353 switch (lbm_type_of_functional(a)) {
354 case LBM_TYPE_CHAR0x00000004u:
355 return (uint64_t) lbm_dec_char(a);
356 case LBM_TYPE_I0x00000008u:
357 return (uint64_t) lbm_dec_i(a);
358 case LBM_TYPE_U0x0000000Cu:
359 return lbm_dec_u(a);
360 case LBM_TYPE_I320x28000000u:
361 return (uint64_t) lbm_dec_i32(a);
362 case LBM_TYPE_U320x38000000u:
363 return (uint64_t) lbm_dec_u32(a);
364 case LBM_TYPE_FLOAT0x68000000u:
365 return (uint64_t)lbm_dec_float(a);
366 case LBM_TYPE_I640x48000000u:
367 return (uint64_t) lbm_dec_i64(a);
368 case LBM_TYPE_U640x58000000u:
369 return (uint64_t) lbm_dec_u64(a);
370 case LBM_TYPE_DOUBLE0x78000000u:
371 return (uint64_t) lbm_dec_double(a);
372 }
373 return 0;
374}
375
376lbm_uint lbm_dec_as_uint(lbm_value a) {
377 switch (lbm_type_of_functional(a)) {
378 case LBM_TYPE_CHAR0x00000004u:
379 return (lbm_uint) lbm_dec_char(a);
380 case LBM_TYPE_I0x00000008u:
381 return (lbm_uint) lbm_dec_i(a);
382 case LBM_TYPE_U0x0000000Cu:
383 return (lbm_uint) lbm_dec_u(a);
384 case LBM_TYPE_I320x28000000u:
385 return (lbm_uint) lbm_dec_i32(a);
386 case LBM_TYPE_U320x38000000u:
387 return (lbm_uint) lbm_dec_u32(a);
388 case LBM_TYPE_FLOAT0x68000000u:
389 return (lbm_uint) lbm_dec_float(a);
390 case LBM_TYPE_I640x48000000u:
391 return (lbm_uint) lbm_dec_i64(a);
392 case LBM_TYPE_U640x58000000u:
393 return (lbm_uint) lbm_dec_u64(a);
394 case LBM_TYPE_DOUBLE0x78000000u:
395 return (lbm_uint) lbm_dec_double(a);
396 }
397 return 0;
398}
399
400lbm_int lbm_dec_as_int(lbm_value a) {
401 switch (lbm_type_of_functional(a)) {
402 case LBM_TYPE_CHAR0x00000004u:
403 return (lbm_int) lbm_dec_char(a);
404 case LBM_TYPE_I0x00000008u:
405 return (lbm_int) lbm_dec_i(a);
406 case LBM_TYPE_U0x0000000Cu:
407 return (lbm_int) lbm_dec_u(a);
408 case LBM_TYPE_I320x28000000u:
409 return (lbm_int) lbm_dec_i32(a);
410 case LBM_TYPE_U320x38000000u:
411 return (lbm_int) lbm_dec_u32(a);
412 case LBM_TYPE_FLOAT0x68000000u:
413 return (lbm_int)lbm_dec_float(a);
414 case LBM_TYPE_I640x48000000u:
415 return (lbm_int) lbm_dec_i64(a);
416 case LBM_TYPE_U640x58000000u:
417 return (lbm_int) lbm_dec_u64(a);
418 case LBM_TYPE_DOUBLE0x78000000u:
419 return (lbm_int) lbm_dec_double(a);
420 }
421 return 0;
422}
423
424float lbm_dec_as_float(lbm_value a) {
425
426 switch (lbm_type_of_functional(a)) {
427 case LBM_TYPE_CHAR0x00000004u:
428 return (float) lbm_dec_char(a);
429 case LBM_TYPE_I0x00000008u:
430 return (float) lbm_dec_i(a);
431 case LBM_TYPE_U0x0000000Cu:
432 return (float) lbm_dec_u(a);
433 case LBM_TYPE_I320x28000000u:
434 return (float) lbm_dec_i32(a);
435 case LBM_TYPE_U320x38000000u:
436 return (float) lbm_dec_u32(a);
437 case LBM_TYPE_FLOAT0x68000000u:
438 return (float) lbm_dec_float(a);
439 case LBM_TYPE_I640x48000000u:
440 return (float) lbm_dec_i64(a);
441 case LBM_TYPE_U640x58000000u:
442 return (float) lbm_dec_u64(a);
443 case LBM_TYPE_DOUBLE0x78000000u:
444 return (float) lbm_dec_double(a);
445 }
446 return 0;
447}
448
449double lbm_dec_as_double(lbm_value a) {
450
451 switch (lbm_type_of_functional(a)) {
452 case LBM_TYPE_CHAR0x00000004u:
453 return (double) lbm_dec_char(a);
454 case LBM_TYPE_I0x00000008u:
455 return (double) lbm_dec_i(a);
456 case LBM_TYPE_U0x0000000Cu:
457 return (double) lbm_dec_u(a);
458 case LBM_TYPE_I320x28000000u:
459 return (double) lbm_dec_i32(a);
460 case LBM_TYPE_U320x38000000u:
461 return (double) lbm_dec_u32(a);
462 case LBM_TYPE_FLOAT0x68000000u:
463 return (double) lbm_dec_float(a);
464 case LBM_TYPE_I640x48000000u:
465 return (double) lbm_dec_i64(a);
466 case LBM_TYPE_U640x58000000u:
467 return (double) lbm_dec_u64(a);
468 case LBM_TYPE_DOUBLE0x78000000u:
469 return (double) lbm_dec_double(a);
470 }
471 return 0;
472}
473
474/****************************************************/
475/* HEAP MANAGEMENT */
476
477static int generate_freelist(size_t num_cells) {
478 size_t i = 0;
479
480 if (!lbm_heap_state.heap) return 0;
481
482 lbm_heap_state.freelist = lbm_enc_cons_ptr(0);
483
484 lbm_cons_t *t;
485
486 // Add all cells to free list
487 for (i = 1; i < num_cells; i ++) {
488 t = lbm_ref_cell(lbm_enc_cons_ptr(i-1));
489 t->car = ENC_SYM_RECOVERED(((0x28) << 4) | 0x00000000u); // all cars in free list are "RECOVERED"
490 t->cdr = lbm_enc_cons_ptr(i);
491 }
492
493 // Replace the incorrect pointer at the last cell.
494 t = lbm_ref_cell(lbm_enc_cons_ptr(num_cells-1));
495 t->cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
496
497 return 1;
498}
499
500void lbm_nil_freelist(void) {
501 lbm_heap_state.freelist = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
502 lbm_heap_state.num_alloc = lbm_heap_state.heap_size;
503}
504
505static void heap_init_state(lbm_cons_t *addr, lbm_uint num_cells,
506 lbm_uint* gc_stack_storage, lbm_uint gc_stack_size) {
507 lbm_heap_state.heap = addr;
508 lbm_heap_state.heap_bytes = (unsigned int)(num_cells * sizeof(lbm_cons_t));
509 lbm_heap_state.heap_size = num_cells;
510
511 lbm_stack_create(&lbm_heap_state.gc_stack, gc_stack_storage, gc_stack_size);
512
513 lbm_heap_state.num_alloc = 0;
514 lbm_heap_state.num_alloc_arrays = 0;
515 lbm_heap_state.gc_num = 0;
516 lbm_heap_state.gc_marked = 0;
517 lbm_heap_state.gc_recovered = 0;
518 lbm_heap_state.gc_recovered_arrays = 0;
519 lbm_heap_state.gc_least_free = num_cells;
520 lbm_heap_state.gc_last_free = num_cells;
521}
522
523void lbm_heap_new_freelist_length(void) {
524 lbm_uint l = lbm_heap_state.heap_size - lbm_heap_state.num_alloc;
525 lbm_heap_state.gc_last_free = l;
526 if (l < lbm_heap_state.gc_least_free)
527 lbm_heap_state.gc_least_free = l;
528}
529
530int lbm_heap_init(lbm_cons_t *addr, lbm_uint num_cells,
531 lbm_uint gc_stack_size) {
532
533 if (((uintptr_t)addr % 8) != 0) return 0;
534
535 memset(addr,0, sizeof(lbm_cons_t) * num_cells);
536
537 lbm_uint *gc_stack_storage = (lbm_uint*)lbm_malloc(gc_stack_size * sizeof(lbm_uint));
538 if (gc_stack_storage == NULL((void*)0)) return 0;
539
540 heap_init_state(addr, num_cells,
541 gc_stack_storage, gc_stack_size);
542
543 lbm_heaps[0] = addr;
544
545 return generate_freelist(num_cells);
546}
547
548lbm_uint lbm_heap_num_free(void) {
549 return lbm_heap_state.heap_size - lbm_heap_state.num_alloc;
550}
551
552lbm_value lbm_heap_allocate_cell(lbm_type ptr_type, lbm_value car, lbm_value cdr) {
553 lbm_value res;
554 // it is a ptr replace freelist with cdr of freelist;
555 res = lbm_heap_state.freelist;
556 if (lbm_type_of(res) == LBM_TYPE_CONS0x10000000u) {
557 lbm_uint heap_ix = lbm_dec_ptr(res);
558 lbm_heap_state.freelist = lbm_heap_state.heap[heap_ix].cdr;
559 lbm_heap_state.num_alloc++;
560 lbm_heap_state.heap[heap_ix].car = car;
561 lbm_heap_state.heap[heap_ix].cdr = cdr;
562 res = lbm_set_ptr_type(res, ptr_type);
563 return res;
564 }
565 return ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u);
566}
567
568lbm_value lbm_heap_allocate_list(lbm_uint n) {
569 if (n == 0) return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
570 if (lbm_heap_num_free() < n) return ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u);
571
572 lbm_value curr = lbm_heap_state.freelist;
573 lbm_value res = curr;
574 if (lbm_type_of(curr) == LBM_TYPE_CONS0x10000000u) {
575
576 lbm_cons_t *c_cell = NULL((void*)0);
577 lbm_uint count = 0;
578 do {
579 c_cell = lbm_ref_cell(curr);
580 c_cell->car = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
581 curr = c_cell->cdr;
582 count ++;
583 } while (count < n);
584 lbm_heap_state.freelist = curr;
585 c_cell->cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
586 lbm_heap_state.num_alloc+=count;
587 return res;
588 }
589 return ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u);
590}
591
592lbm_value lbm_heap_allocate_list_init_va(unsigned int n, va_list valist) {
593 if (n == 0) return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
594 if (lbm_heap_num_free() < n) return ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u);
595
596 lbm_value curr = lbm_heap_state.freelist;
597 lbm_value res = curr;
598 if (lbm_type_of(curr) == LBM_TYPE_CONS0x10000000u) {
599
600 lbm_cons_t *c_cell = NULL((void*)0);
601 unsigned int count = 0;
602 do {
603 c_cell = lbm_ref_cell(curr);
604 c_cell->car = va_arg(valist, lbm_value)__builtin_va_arg(valist, lbm_value);
605 curr = c_cell->cdr;
606 count ++;
607 } while (count < n);
608 lbm_heap_state.freelist = curr;
609 c_cell->cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
610 lbm_heap_state.num_alloc+=count;
611 return res;
612 }
613 return ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u);
614}
615
616lbm_value lbm_heap_allocate_list_init(unsigned int n, ...) {
617 va_list valist;
618 va_start(valist, n)__builtin_va_start(valist, n);
619 lbm_value r = lbm_heap_allocate_list_init_va(n, valist);
620 va_end(valist)__builtin_va_end(valist);
621 return r;
622}
623
624lbm_uint lbm_heap_num_allocated(void) {
625 return lbm_heap_state.num_alloc;
626}
627lbm_uint lbm_heap_size(void) {
628 return lbm_heap_state.heap_size;
629}
630
631lbm_uint lbm_heap_size_bytes(void) {
632 return lbm_heap_state.heap_bytes;
633}
634
635void lbm_get_heap_state(lbm_heap_state_t *res) {
636 *res = lbm_heap_state;
637}
638
639lbm_uint lbm_get_gc_stack_max(void) {
640 return lbm_heap_state.gc_stack.max_sp;
641}
642
643lbm_uint lbm_get_gc_stack_size(void) {
644 return lbm_heap_state.gc_stack.size;
645}
646
647#ifdef USE_GC_PTR_REV
648static inline void value_assign(lbm_value *a, lbm_value b) {
649 lbm_value a_old = *a & LBM_GC_MASK0x00000002u;
650 *a = a_old | (b & ~LBM_GC_MASK0x00000002u);
651}
652
653void lbm_gc_mark_phase(lbm_value root) {
654 bool_Bool work_to_do = true1;
655
656 if (!lbm_is_ptr(root)) return;
657
658 mutex_lock(&lbm_const_heap_mutex);
659 lbm_value curr = root;
660 lbm_value prev = lbm_enc_cons_ptr(LBM_PTR_NULL(0x03FFFFFCu >> 2));
661
662 while (work_to_do) {
663 // follow leftwards pointers
664 while (lbm_is_ptr(curr) &&
665 (lbm_dec_ptr(curr) != LBM_PTR_NULL(0x03FFFFFCu >> 2)) &&
666 ((curr & LBM_PTR_TO_CONSTANT_BIT0x04000000u) == 0) &&
667 !lbm_get_gc_mark(lbm_cdr(curr))) {
668 // Mark the cell if not a constant cell
669 lbm_cons_t *cell = lbm_ref_cell(curr);
670 cell->cdr = lbm_set_gc_mark(cell->cdr);
671 if (lbm_is_cons_rw(curr)) {
672 lbm_value next = 0;
673 value_assign(&next, cell->car);
674 value_assign(&cell->car, prev);
675 value_assign(&prev,curr);
676 value_assign(&curr, next);
677 }
678 // Will jump out next iteration as gc mark is set in curr.
679 }
680 while (lbm_is_ptr(prev) &&
681 (lbm_dec_ptr(prev) != LBM_PTR_NULL(0x03FFFFFCu >> 2)) &&
682 lbm_get_gc_flag(lbm_car(prev)) ) {
683 // clear the flag
684 lbm_cons_t *cell = lbm_ref_cell(prev);
685 cell->car = lbm_clr_gc_flag(cell->car);
686 lbm_value next = 0;
687 value_assign(&next, cell->cdr);
688 value_assign(&cell->cdr, curr);
689 value_assign(&curr, prev);
690 value_assign(&prev, next);
691 }
692 if (lbm_is_ptr(prev) &&
693 lbm_dec_ptr(prev) == LBM_PTR_NULL(0x03FFFFFCu >> 2)) {
694 work_to_do = false0;
695 } else if (lbm_is_ptr(prev)) {
696 // set the flag
697 lbm_cons_t *cell = lbm_ref_cell(prev);
698 cell->car = lbm_set_gc_flag(cell->car);
699 lbm_value next = 0;
700 value_assign(&next, cell->car);
701 value_assign(&cell->car, curr);
702 value_assign(&curr, cell->cdr);
703 value_assign(&cell->cdr, next);
704 }
705 }
706 mutex_unlock(&lbm_const_heap_mutex);
707}
708
709#else
710extern eval_context_t *ctx_running;
711void lbm_gc_mark_phase(lbm_value root) {
712 lbm_value t_ptr;
713 lbm_stack_t *s = &lbm_heap_state.gc_stack;
714 s->data[s->sp++] = root;
715
716 while (!lbm_stack_is_empty(s)) {
717 lbm_value curr;
718 lbm_pop(s, &curr);
719
720 mark_shortcut:
721
722 if (!lbm_is_ptr(curr) ||
723 (curr & LBM_PTR_TO_CONSTANT_BIT0x04000000u)) {
724 continue;
725 }
726
727 lbm_cons_t *cell = &lbm_heap_state.heap[lbm_dec_ptr(curr)];
728
729 if (lbm_get_gc_mark(cell->cdr)) {
730 continue;
731 }
732
733 t_ptr = lbm_type_of(curr);
734
735 // An array is marked in O(N) time using an additional 32bit
736 // value per array that keeps track of how far into the array GC
737 // has progressed.
738 if (t_ptr == LBM_TYPE_LISPARRAY0xB0000000u) {
739 lbm_push(s, curr); // put array back as bookkeeping.
740 lbm_array_header_extended_t *arr = (lbm_array_header_extended_t*)cell->car;
741 lbm_value *arrdata = (lbm_value *)arr->data;
742 uint32_t index = arr->index;
743
744 // Potential optimization.
745 // 1. CONS pointers are set to curr and recurse.
746 // 2. Any other ptr is marked immediately and index is increased.
747 if (lbm_is_ptr(arrdata[index]) && ((arrdata[index] & LBM_PTR_TO_CONSTANT_BIT0x04000000u) == 0) &&
748 !((arrdata[index] & LBM_CONTINUATION_INTERNAL0xF8000001u) == LBM_CONTINUATION_INTERNAL0xF8000001u)) {
749 lbm_cons_t *elt = &lbm_heap_state.heap[lbm_dec_ptr(arrdata[index])];
750 if (!lbm_get_gc_mark(elt->cdr)) {
751 curr = arrdata[index];
752 goto mark_shortcut;
753 }
754 }
755 if (index < ((arr->size/(sizeof(lbm_value))) - 1)) {
756 arr->index++;
757 continue;
758 }
759
760 arr->index = 0;
761 cell->cdr = lbm_set_gc_mark(cell->cdr);
762 lbm_heap_state.gc_marked ++;
763 lbm_pop(s, &curr); // Remove array from GC stack as we are done marking it.
764 continue;
765 }
766
767 cell->cdr = lbm_set_gc_mark(cell->cdr);
768 lbm_heap_state.gc_marked ++;
769
770 if (t_ptr == LBM_TYPE_CONS0x10000000u) {
771 if (lbm_is_ptr(cell->cdr)) {
772 if (!lbm_push(s, cell->cdr)) {
773 lbm_critical_error();
774 break;
775 }
776 }
777 curr = cell->car;
778 goto mark_shortcut; // Skip a push/pop
779 }
780 }
781}
782#endif
783
784//Environments are proper lists with a 2 element list stored in each car.
785void lbm_gc_mark_env(lbm_value env) {
786 lbm_value curr = env;
787 lbm_cons_t *c;
788
789 while (lbm_is_ptr(curr)) {
790 c = lbm_ref_cell(curr);
791 c->cdr = lbm_set_gc_mark(c->cdr); // mark the environent list structure.
792 lbm_cons_t *b = lbm_ref_cell(c->car);
793 b->cdr = lbm_set_gc_mark(b->cdr); // mark the binding list head cell.
794 lbm_gc_mark_phase(b->cdr); // mark the bound object.
795 lbm_heap_state.gc_marked +=2;
796 curr = c->cdr;
797 }
798}
799
800
801void lbm_gc_mark_aux(lbm_uint *aux_data, lbm_uint aux_size) {
802 for (lbm_uint i = 0; i < aux_size; i ++) {
803 if (lbm_is_ptr(aux_data[i])) {
804 lbm_type pt_t = lbm_type_of(aux_data[i]);
805 lbm_uint pt_v = lbm_dec_ptr(aux_data[i]);
806 if( pt_t >= LBM_POINTER_TYPE_FIRST0x10000000u &&
807 pt_t <= LBM_POINTER_TYPE_LAST0xBC000000u &&
808 pt_v < lbm_heap_state.heap_size) {
809 lbm_gc_mark_phase(aux_data[i]);
810 }
811 }
812 }
813}
814
815void lbm_gc_mark_roots(lbm_uint *roots, lbm_uint num_roots) {
816 for (lbm_uint i = 0; i < num_roots; i ++) {
817 lbm_gc_mark_phase(roots[i]);
818 }
819}
820
821// Sweep moves non-marked heap objects to the free list.
822int lbm_gc_sweep_phase(void) {
823 unsigned int i = 0;
824 lbm_cons_t *heap = (lbm_cons_t *)lbm_heap_state.heap;
825
826 for (i = 0; i < lbm_heap_state.heap_size; i ++) {
827 if ( lbm_get_gc_mark(heap[i].cdr)) {
828 heap[i].cdr = lbm_clr_gc_mark(heap[i].cdr);
829 } else {
830 // Check if this cell is a pointer to an array
831 // and free it.
832 if (lbm_type_of(heap[i].cdr) == LBM_TYPE_SYMBOL0x00000000u) {
833 switch(heap[i].cdr) {
834
835 case ENC_SYM_IND_I_TYPE(((0x34) << 4) | 0x00000000u): /* fall through */
836 case ENC_SYM_IND_U_TYPE(((0x35) << 4) | 0x00000000u):
837 case ENC_SYM_IND_F_TYPE(((0x36) << 4) | 0x00000000u):
838 lbm_memory_free((lbm_uint*)heap[i].car);
839 break;
840 case ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u): /* fall through */
841 case ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u):{
842 lbm_array_header_t *arr = (lbm_array_header_t*)heap[i].car;
843 if (lbm_memory_ptr_inside((lbm_uint*)arr->data)) {
844 lbm_memory_free((lbm_uint *)arr->data);
845 lbm_heap_state.gc_recovered_arrays++;
846 }
847 lbm_memory_free((lbm_uint *)arr);
848 } break;
849 case ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u):{
850 lbm_char_channel_t *chan = (lbm_char_channel_t*)heap[i].car;
851 if (lbm_memory_ptr_inside((lbm_uint*)chan)) {
852 lbm_memory_free((lbm_uint*)chan->state);
853 lbm_memory_free((lbm_uint*)chan);
854 }
855 } break;
856 case ENC_SYM_CUSTOM_TYPE(((0x38) << 4) | 0x00000000u): {
857 lbm_uint *t = (lbm_uint*)heap[i].car;
858 lbm_custom_type_destroy(t);
859 lbm_memory_free(t);
860 } break;
861 default:
862 break;
863 }
864 }
865 // create pointer to use as new freelist
866 lbm_uint addr = lbm_enc_cons_ptr(i);
867
868 // Clear the "freed" cell.
869 heap[i].car = ENC_SYM_RECOVERED(((0x28) << 4) | 0x00000000u);
870 heap[i].cdr = lbm_heap_state.freelist;
871 lbm_heap_state.freelist = addr;
872 lbm_heap_state.num_alloc --;
873 lbm_heap_state.gc_recovered ++;
874 }
875 }
876 return 1;
877}
878
879void lbm_gc_state_inc(void) {
880 lbm_heap_state.gc_num ++;
881 lbm_heap_state.gc_recovered = 0;
882 lbm_heap_state.gc_marked = 0;
883}
884
885// construct, alter and break apart
886lbm_value lbm_cons(lbm_value car, lbm_value cdr) {
887 return lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, car, cdr);
888}
889
890lbm_value lbm_car(lbm_value c){
891
892 if (lbm_is_ptr(c) ){
7
←
Taking false branch
→
893 lbm_cons_t *cell = lbm_ref_cell(c);
894 return cell->car;
895 }
896
897 if (lbm_type_of(c) == LBM_TYPE_SYMBOL0x00000000u &&
8
←
Assuming the condition is true
→
10
←
Taking true branch
→
898 c == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
9
←
Assuming the condition is true
→
899 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // if nil, return nil.
11
←
Returning zero
→
900 }
901
902 return ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u);
903}
904
905// TODO: Many comparisons "is this the nil symbol" can be
906// streamlined a bit. NIL is 0 and cannot be confused with any other
907// lbm_value.
908
909lbm_value lbm_caar(lbm_value c) {
910
911 lbm_value tmp;
912
913 if (lbm_is_ptr(c)) {
914 tmp = lbm_ref_cell(c)->car;
915
916 if (lbm_is_ptr(tmp)) {
917 return lbm_ref_cell(tmp)->car;
918 } else if (lbm_is_symbol(tmp) && tmp == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
919 return tmp;
920 }
921 } else if (lbm_is_symbol(c) && c == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
922 return c;
923 }
924 return ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u);
925}
926
927
928lbm_value lbm_cadr(lbm_value c) {
929
930 lbm_value tmp;
931
932 if (lbm_is_ptr(c)) {
933 tmp = lbm_ref_cell(c)->cdr;
934
935 if (lbm_is_ptr(tmp)) {
936 return lbm_ref_cell(tmp)->car;
937 } else if (lbm_is_symbol(tmp) && tmp == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
938 return tmp;
939 }
940 } else if (lbm_is_symbol(c) && c == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
941 return c;
942 }
943 return ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u);
944}
945
946lbm_value lbm_cdr(lbm_value c){
947
948 if (lbm_type_of(c) == LBM_TYPE_SYMBOL0x00000000u &&
949 c == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
950 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // if nil, return nil.
951 }
952
953 if (lbm_is_ptr(c)) {
954 lbm_cons_t *cell = lbm_ref_cell(c);
955 return cell->cdr;
956 }
957 return ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u);
958}
959
960lbm_value lbm_cddr(lbm_value c) {
961
962 if (lbm_is_ptr(c)) {
963 lbm_value tmp = lbm_ref_cell(c)->cdr;
964 if (lbm_is_ptr(tmp)) {
965 return lbm_ref_cell(tmp)->cdr;
966 }
967 }
968 if (lbm_is_symbol(c) && c == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
969 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
970 }
971 return ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u);
972}
973
974int lbm_set_car(lbm_value c, lbm_value v) {
975 int r = 0;
976
977 if (lbm_type_of(c) == LBM_TYPE_CONS0x10000000u) {
978 lbm_cons_t *cell = lbm_ref_cell(c);
979 cell->car = v;
980 r = 1;
981 }
982 return r;
983}
984
985int lbm_set_cdr(lbm_value c, lbm_value v) {
986 int r = 0;
987 if (lbm_is_cons_rw(c)){
988 lbm_cons_t *cell = lbm_ref_cell(c);
989 cell->cdr = v;
990 r = 1;
991 }
992 return r;
993}
994
995int lbm_set_car_and_cdr(lbm_value c, lbm_value car_val, lbm_value cdr_val) {
996 int r = 0;
997 if (lbm_is_cons_rw(c)) {
998 lbm_cons_t *cell = lbm_ref_cell(c);
999 cell->car = car_val;
1000 cell->cdr = cdr_val;
1001 r = 1;
1002 }
1003 return r;
1004}
1005
1006/* calculate length of a proper list */
1007lbm_uint lbm_list_length(lbm_value c) {
1008 lbm_uint len = 0;
1009
1010 while (lbm_is_cons(c)){
1011 len ++;
1012 c = lbm_cdr(c);
1013 }
1014 return len;
1015}
1016
1017/* calculate the length of a list and check that each element
1018 fullfills the predicate pred */
1019unsigned int lbm_list_length_pred(lbm_value c, bool_Bool *pres, bool_Bool (*pred)(lbm_value)) {
1020 bool_Bool res = true1;
1021 unsigned int len = 0;
1022
1023 while (lbm_is_cons(c)){
1024 len ++;
1025 res = res && pred(lbm_car(c));
1026 c = lbm_cdr(c);
1027 }
1028 *pres = res;
1029 return len;
1030}
1031
1032/* reverse a proper list */
1033lbm_value lbm_list_reverse(lbm_value list) {
1034 if (lbm_type_of(list) == LBM_TYPE_SYMBOL0x00000000u) {
1035 return list;
1036 }
1037
1038 lbm_value curr = list;
1039
1040 lbm_value new_list = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1041 while (lbm_is_cons(curr)) {
1042
1043 new_list = lbm_cons(lbm_car(curr), new_list);
1044 if (lbm_type_of(new_list) == LBM_TYPE_SYMBOL0x00000000u) {
1045 return ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u);
1046 }
1047 curr = lbm_cdr(curr);
1048 }
1049 return new_list;
1050}
1051
1052lbm_value lbm_list_destructive_reverse(lbm_value list) {
1053 if (lbm_type_of(list) == LBM_TYPE_SYMBOL0x00000000u) {
1054 return list;
1055 }
1056 lbm_value curr = list;
1057 lbm_value last_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1058
1059 while (lbm_is_cons_rw(curr)) {
1060 lbm_value next = lbm_cdr(curr);
1061 lbm_set_cdr(curr, last_cell);
1062 last_cell = curr;
1063 curr = next;
1064 }
1065 return last_cell;
1066}
1067
1068
1069lbm_value lbm_list_copy(int *m, lbm_value list) {
1070 lbm_value curr = list;
1071 lbm_uint n = lbm_list_length(list);
1072 lbm_uint copy_n = n;
1073 if (*m >= 0 && (lbm_uint)*m < n) {
1074 copy_n = (lbm_uint)*m;
1075 } else if (*m == -1) {
1076 *m = (int)n; // TODO: smaller range in target variable.
1077 }
1078 if (copy_n == 0) return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1079 lbm_uint new_list = lbm_heap_allocate_list(copy_n);
1080 if (lbm_is_symbol(new_list)) return new_list;
1081 lbm_value curr_targ = new_list;
1082
1083 while (lbm_is_cons(curr) && copy_n > 0) {
1084 lbm_value v = lbm_car(curr);
1085 lbm_set_car(curr_targ, v);
1086 curr_targ = lbm_cdr(curr_targ);
1087 curr = lbm_cdr(curr);
1088 copy_n --;
1089 }
1090
1091 return new_list;
1092}
1093
1094// Append for proper lists only
1095// Destructive update of list1.
1096lbm_value lbm_list_append(lbm_value list1, lbm_value list2) {
1097
1098 if(lbm_is_list_rw(list1) &&
1099 lbm_is_list(list2)) {
1100
1101 lbm_value curr = list1;
1102 while(lbm_type_of(lbm_cdr(curr)) == LBM_TYPE_CONS0x10000000u) {
1103 curr = lbm_cdr(curr);
1104 }
1105 if (lbm_is_symbol_nil(curr)) return list2;
1106 lbm_set_cdr(curr, list2);
1107 return list1;
1108 }
1109 return ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
1110}
1111
1112lbm_value lbm_list_drop(unsigned int n, lbm_value ls) {
1113 lbm_value curr = ls;
1114 while (lbm_type_of_functional(curr) == LBM_TYPE_CONS0x10000000u &&
1115 n > 0) {
1116 curr = lbm_cdr(curr);
1117 n --;
1118 }
1119 return curr;
1120}
1121
1122lbm_value lbm_index_list(lbm_value l, int32_t n) {
1123 lbm_value curr = l;
1124
1125 if (n < 0) {
1126 int32_t len = (int32_t)lbm_list_length(l);
1127 n = len + n;
1128 if (n < 0) return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1129 }
1130
1131 while (lbm_is_cons(curr) &&
1132 n > 0) {
1133 curr = lbm_cdr(curr);
1134 n --;
1135 }
1136 if (lbm_is_cons(curr)) {
1137 return lbm_car(curr);
1138 } else {
1139 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1140 }
1141}
1142
1143// High-level arrays are just bytearrays but with a different tag and pointer type.
1144// These arrays will be inspected by GC and the elements of the array will be marked.
1145
1146// Arrays are part of the heap module because their lifespan is managed
1147// by the garbage collector. The data in the array is not stored
1148// in the "heap of cons cells".
1149int lbm_heap_allocate_array_base(lbm_value *res, bool_Bool byte_array, lbm_uint size){
1150
1151 lbm_array_header_t *array = NULL((void*)0);
1152
1153 if (byte_array) {
1154 array = (lbm_array_header_t*)lbm_malloc(sizeof(lbm_array_header_t));
1155 } else {
1156 // an extra 32bit quantity for a GC index.
1157 array = (lbm_array_header_t*)lbm_malloc(sizeof(lbm_array_header_extended_t));
1158 }
1159
1160 if (array == NULL((void*)0)) {
1161 *res = ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u);
1162 return 0;
1163 }
1164
1165 lbm_uint tag = ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u);
1166 lbm_uint type = LBM_TYPE_ARRAY0x80000000u;
1167 if (!byte_array) {
1168 tag = ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u);
1169 type = LBM_TYPE_LISPARRAY0xB0000000u;
1170 size = sizeof(lbm_value) * size;
1171 lbm_array_header_extended_t *ext_array = (lbm_array_header_extended_t*)array;
1172 ext_array->index = 0;
1173 }
1174
1175 array->data = (lbm_uint*)lbm_malloc(size);
1176
1177 if (array->data == NULL((void*)0)) {
1178 lbm_memory_free((lbm_uint*)array);
1179 *res = ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u);
1180 return 0;
1181 }
1182 // It is more important to zero out high-level arrays.
1183 // 0 is symbol NIL which is perfectly safe for the GC to inspect.
1184 memset(array->data, 0, size);
1185 array->size = size;
1186
1187 // allocating a cell for array's heap-presence
1188 lbm_value cell = lbm_heap_allocate_cell(type, (lbm_uint) array, tag);
1189
1190 *res = cell;
1191
1192 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) { // Out of heap memory
1193 lbm_memory_free((lbm_uint*)array->data);
1194 lbm_memory_free((lbm_uint*)array);
1195 *res = ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u);
1196 return 0;
1197 }
1198
1199 lbm_heap_state.num_alloc_arrays ++;
1200
1201 return 1;
1202}
1203
1204int lbm_heap_allocate_array(lbm_value *res, lbm_uint size){
1205 return lbm_heap_allocate_array_base(res, true1, size);
1206}
1207
1208int lbm_heap_allocate_lisp_array(lbm_value *res, lbm_uint size) {
1209 return lbm_heap_allocate_array_base(res, false0, size);
1210}
1211
1212// Convert a C array into an lbm_array.
1213// if the array is in LBM_MEMORY, the lifetime will be managed by the GC after lifting.
1214int lbm_lift_array(lbm_value *value, char *data, lbm_uint num_elt) {
1215
1216 lbm_array_header_t *array = NULL((void*)0);
1217 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u));
1218
1219 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) { // Out of heap memory
1220 *value = cell;
1221 return 0;
1222 }
1223
1224 array = (lbm_array_header_t*)lbm_malloc(sizeof(lbm_array_header_t));
1225
1226 if (array == NULL((void*)0)) {
1227 lbm_set_car_and_cdr(cell, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1228 *value = ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u);
1229 return 0;
1230 }
1231
1232 array->data = (lbm_uint*)data;
1233 array->size = num_elt;
1234
1235 lbm_set_car(cell, (lbm_uint)array);
1236
1237 cell = lbm_set_ptr_type(cell, LBM_TYPE_ARRAY0x80000000u);
1238 *value = cell;
1239 return 1;
1240}
1241
1242lbm_int lbm_heap_array_get_size(lbm_value arr) {
1243
1244 lbm_int r = -1;
1245 if (lbm_is_array_r(arr)) {
1246 lbm_array_header_t *header = (lbm_array_header_t*)lbm_car(arr);
1247 if (header == NULL((void*)0)) {
1248 return r;
1249 }
1250 r = (lbm_int)header->size;
1251 }
1252 return r;
1253}
1254
1255const uint8_t *lbm_heap_array_get_data_ro(lbm_value arr) {
1256 uint8_t *r = NULL((void*)0);
1257 if (lbm_is_array_r(arr)) {
1
Calling 'lbm_is_array_r'
→
4
←
Returning from 'lbm_is_array_r'
→
5
←
Taking true branch
→
1258 lbm_array_header_t *header = (lbm_array_header_t*)lbm_car(arr);
6
←
Calling 'lbm_car'
→
12
←
Returning from 'lbm_car'
→
13
←
'header' initialized to a null pointer value
→
1259 r = (uint8_t*)header->data;
14
←
Access to field 'data' results in a dereference of a null pointer (loaded from variable 'header')
1260 }
1261 return r;
1262}
1263
1264uint8_t *lbm_heap_array_get_data_rw(lbm_value arr) {
1265 uint8_t *r = NULL((void*)0);
1266 if (lbm_is_array_rw(arr)) {
1267 lbm_array_header_t *header = (lbm_array_header_t*)lbm_car(arr);
1268 r = (uint8_t*)header->data;
1269 }
1270 return r;
1271}
1272
1273
1274/* Explicitly freeing an array.
1275
1276 This is a highly unsafe operation and can only be safely
1277 used if the heap cell that points to the array has not been made
1278 accessible to the program.
1279
1280 So This function can be used to free an array in case an array
1281 is being constructed and some error case appears while doing so
1282 If the array still have not become available it can safely be
1283 "explicitly" freed.
1284
1285 The problem is that if the "array" heap-cell is made available to
1286 the program, this cell can easily be duplicated and we would have
1287 to search the entire heap to find all cells pointing to the array
1288 memory in question and "null"-them out before freeing the memory
1289*/
1290
1291int lbm_heap_explicit_free_array(lbm_value arr) {
1292
1293 int r = 0;
1294 if (lbm_is_array_rw(arr)) {
1295
1296 lbm_array_header_t *header = (lbm_array_header_t*)lbm_car(arr);
1297 if (header == NULL((void*)0)) {
1298 return 0;
1299 }
1300 lbm_memory_free((lbm_uint*)header->data);
1301 lbm_memory_free((lbm_uint*)header);
1302
1303 arr = lbm_set_ptr_type(arr, LBM_TYPE_CONS0x10000000u);
1304 lbm_set_car(arr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1305 lbm_set_cdr(arr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1306 r = 1;
1307 }
1308
1309 return r;
1310}
1311
1312lbm_uint lbm_size_of(lbm_type t) {
1313 lbm_uint s = 0;
1314 switch(t) {
1315 case LBM_TYPE_BYTE0x00000004u:
1316 s = 1;
1317 break;
1318 case LBM_TYPE_I0x00000008u: /* fall through */
1319 case LBM_TYPE_U0x0000000Cu:
1320 case LBM_TYPE_SYMBOL0x00000000u:
1321 s = sizeof(lbm_uint);
1322 break;
1323 case LBM_TYPE_I320x28000000u: /* fall through */
1324 case LBM_TYPE_U320x38000000u:
1325 case LBM_TYPE_FLOAT0x68000000u:
1326 s = 4;
1327 break;
1328 case LBM_TYPE_I640x48000000u: /* fall through */
1329 case LBM_TYPE_U640x58000000u:
1330 case LBM_TYPE_DOUBLE0x78000000u:
1331 s = 8;
1332 break;
1333 }
1334 return s;
1335}
1336
1337static bool_Bool dummy_flash_write(lbm_uint ix, lbm_uint val) {
1338 (void)ix;
1339 (void)val;
1340 return false0;
1341}
1342
1343static const_heap_write_fun const_heap_write = dummy_flash_write;
1344
1345int lbm_const_heap_init(const_heap_write_fun w_fun,
1346 lbm_const_heap_t *heap,
1347 lbm_uint *addr,
1348 lbm_uint num_words) {
1349 if (((uintptr_t)addr % 4) != 0) return 0;
1350 if ((num_words % 2) != 0) return 0;
1351
1352 if (!lbm_const_heap_mutex_initialized) {
1353 mutex_init(&lbm_const_heap_mutex);
1354 lbm_const_heap_mutex_initialized = true1;
1355 }
1356
1357 if (!lbm_mark_mutex_initialized) {
1358 mutex_init(&lbm_mark_mutex);
1359 lbm_mark_mutex_initialized = true1;
1360 }
1361
1362 const_heap_write = w_fun;
1363
1364 heap->heap = addr;
1365 heap->size = num_words;
1366 heap->next = 0;
1367
1368 lbm_const_heap_state = heap;
1369 // ref_cell views the lbm_uint array as an lbm_cons_t array
1370 lbm_heaps[1] = (lbm_cons_t*)addr;
1371 return 1;
1372}
1373
1374lbm_flash_status lbm_allocate_const_cell(lbm_value *res) {
1375 lbm_flash_status r = LBM_FLASH_FULL;
1376
1377 mutex_lock(&lbm_const_heap_mutex);
1378 // waste a cell if we have ended up unaligned after writing an array to flash.
1379 if (lbm_const_heap_state->next % 2 == 1) {
1380 lbm_const_heap_state->next++;
1381 }
1382
1383 if (lbm_const_heap_state &&
1384 (lbm_const_heap_state->next+1) < lbm_const_heap_state->size) {
1385 // A cons cell uses two words.
1386 lbm_value cell = lbm_const_heap_state->next;
1387 lbm_const_heap_state->next += 2;
1388 *res = (cell << LBM_ADDRESS_SHIFT2) | LBM_PTR_BIT0x00000001u | LBM_TYPE_CONS0x10000000u | LBM_PTR_TO_CONSTANT_BIT0x04000000u;
1389 r = LBM_FLASH_WRITE_OK;
1390 }
1391 mutex_unlock(&lbm_const_heap_mutex);
1392 return r;
1393}
1394
1395lbm_flash_status lbm_allocate_const_raw(lbm_uint nwords, lbm_uint *res) {
1396 lbm_flash_status r = LBM_FLASH_FULL;
1397
1398 if (lbm_const_heap_state &&
1399 (lbm_const_heap_state->next + nwords) < lbm_const_heap_state->size) {
1400 lbm_uint ix = lbm_const_heap_state->next;
1401 *res = (lbm_uint)&lbm_const_heap_state->heap[ix];
1402 lbm_const_heap_state->next += nwords;
1403 r = LBM_FLASH_WRITE_OK;
1404 }
1405 return r;
1406}
1407
1408lbm_flash_status lbm_write_const_raw(lbm_uint *data, lbm_uint n, lbm_uint *res) {
1409
1410 lbm_flash_status r = LBM_FLASH_FULL;
1411
1412 if (lbm_const_heap_state &&
1413 (lbm_const_heap_state->next + n) < lbm_const_heap_state->size) {
1414 lbm_uint ix = lbm_const_heap_state->next;
1415
1416 for (unsigned int i = 0; i < n; i ++) {
1417 if (!const_heap_write(ix + i, ((lbm_uint*)data)[i]))
1418 return LBM_FLASH_WRITE_ERROR;
1419 }
1420 lbm_const_heap_state->next += n;
1421 *res = (lbm_uint)&lbm_const_heap_state->heap[ix];
1422 r = LBM_FLASH_WRITE_OK;
1423 }
1424 return r;
1425}
1426
1427lbm_flash_status lbm_const_write(lbm_uint *tgt, lbm_uint val) {
1428
1429 if (lbm_const_heap_state) {
1430 lbm_uint flash = (lbm_uint)lbm_const_heap_state->heap;
1431 lbm_uint ix = (((lbm_uint)tgt - flash) / 4); // byte address to ix
1432 if (const_heap_write(ix, val)) {
1433 return LBM_FLASH_WRITE_OK;
1434 }
1435 return LBM_FLASH_WRITE_ERROR;
1436 }
1437 return LBM_FLASH_FULL;
1438}
1439
1440lbm_flash_status write_const_cdr(lbm_value cell, lbm_value val) {
1441 lbm_uint addr = lbm_dec_ptr(cell);
1442 if (const_heap_write(addr+1, val))
1443 return LBM_FLASH_WRITE_OK;
1444 return LBM_FLASH_WRITE_ERROR;
1445}
1446
1447lbm_flash_status write_const_car(lbm_value cell, lbm_value val) {
1448 lbm_uint addr = lbm_dec_ptr(cell);
1449 if (const_heap_write(addr, val))
1450 return LBM_FLASH_WRITE_OK;
1451 return LBM_FLASH_WRITE_ERROR;
1452}
1453
1454lbm_uint lbm_flash_memory_usage(void) {
1455 return lbm_const_heap_state->next;
1456}
+
+
←

./include/heap.h

+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1
2/*
3 Copyright 2018, 2024 Joel Svensson svenssonjoel@yahoo.se
4
5 This program is free software: you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation, either version 3 of the License, or
8 (at your option) any later version.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
14
15 You should have received a copy of the GNU General Public License
16 along with this program. If not, see <http://www.gnu.org/licenses/>.
17*/
18/** \file heap.h */
19
20#ifndef HEAP_H_
21#define HEAP_H_
22
23#include <string.h>
24#include <stdarg.h>
25
26#include "lbm_types.h"
27#include "symrepr.h"
28#include "stack.h"
29#include "lbm_memory.h"
30#include "lbm_defines.h"
31#include "lbm_channel.h"
32
33#ifdef __cplusplus
34extern "C" {
35#endif
36
37/*
38Planning for a more space efficient heap representation.
39TODO: Need to find a good reference to read up on this.
40 - List based heap
41 - Easy to implement and somewhat efficient
42
430000 0000 Size Free bits
44003F FFFF 4MB 10
45007F FFFF 8MB 9
4600FF FFFF 16MB 8
4701FF FFFF 32MB 7
4803FF FFFF 64MB 6 * Kind of heap size I am looking for
4907FF FFFF 128MB 5
500FFF FFFF 256MB 4
511FFF FFFF 512MB 3
52
53
54--- May 9 2021 ---
55Actually now I am much more interested in way smaller memories ;)
56
570000 0000 Size Free bits
580000 0FFF 4KB 20 |
590000 1FFF 8KB 19 |
600000 3FFF 16KB 18 |
610000 7FFF 32KB 17 |
620000 FFFF 64KB 16 |
630001 FFFF 128KB 15 |
640003 FFFF 256KB 14 | - This range is very interesting.
650007 FFFF 512KB 13
66000F FFFF 1MB 12
67001F FFFF 2MB 11
68003F FFFF 4MB 10
69007F FFFF 8MB 9
7000FF FFFF 16MB 8
7101FF FFFF 32MB 7
7203FF FFFF 64MB 6
7307FF FFFF 128MB 5
740FFF FFFF 256MB 4
751FFF FFFF 512MB 3
76
77Those are the kind of platforms that are fun... so a bunch of
78wasted bits in heap pointers if we run on small MCUs.
79
80-----------------
81
82it is also the case that not all addresses will be used if all "cells" are
83of the same size, 8 bytes...
84
85value 0: 0000 0000
86value 1: 0000 0008
87value 3: 0000 0010
88value 4: 0000 0018
89
90Means bits 0,1,2 will always be empty in a valid address.
91
92Cons cells also need to be have room for 2 pointers. So each ted cell from
93memory should be 8bytes.
94
95Things that needs to be represented within these bits:
96
97 - GC MARK one per cell
98 - TYPE: type of CAR and type of cons
99
100Types I would want:
101 - Full 32bit integer. Does not leave room for identification of type
102 - Float values. Same problem
103
104
105Free bits in pointers 64MB heap:
10631 30 29 28 27 26 2 1 0
1070 0 0 0 0 0 XX XXXX XXXX XXXX XXXX XXXX X 0 0 0
108
109
110Information needed for each cell:
111 Meaning | bits total | bits per car | bits per cdr
112 GC mark | 2 | 1 | 1 - only one of them will be used (the other is wasted)
113 Type | 2x | x | x
114 Ptr/!ptr | 2 | 1 | 1
115
116
117Types (unboxed):
118 - Symbols
119 - 28bit integer ( will need signed shift right functionality )
120 - 28bit unsigned integer
121 - Character
122
123If four types is all that should be possible (unboxed). then 2 bits are needed to differentiate.
1242 + 1 + 1 = 4 => 28bits for data.
125
126bit 0: ptr/!ptr
127bit 1: gc
128bit 2-3: type (if not ptr)
129bit 3 - 24 ptr (if ptr)
130bit 4 - 31 value (if value)
131
132An unboxed value can occupy a car or cdr field in a cons cell.
133
134types (boxed) extra information in pointer to cell can contain information
135 - 32 bit integer
136 - 32 bit unsigned integer
137 - 32 bit float
138
139boxed representation:
140 [ptr| cdr]
141 |
142 [Value | Aux + GC_MARK]
143
144Kinds of pointers:
145 - Pointer to cons cell.
146 - Pointer to unboxed value (fixnums not in a list, I hope this is so rare that it can be removed )
147 - integer
148 - unsigned integer
149 - symbol
150 - float
151 - Pointer to boxed value.
152 - 32 bit integer
153 - 32 bit unsigned integer
154 - 32 bit float
155 - (Maybe something else ? Vectors/strings allocated in memory not occupied by heap?)
156 - vector of int
157 - vector of uint
158 - vector of float
159 - vector of double
160 - String
161
16213 pointer"types" -> needs 4 bits
163for 64MB heap there are 6 free bits. So with this scheme going to 128MB or 256MB heap
164is also possible
165
166 a pointer to some off heap vector/string could be represented by
167
168 [ptr | cdr]
169 |
170 [full pointer | Aux + GC_MARK]
171 |
172 [VECTOR]
173
174Aux bits could be used for storing vector size. Up to 30bits should be available there
175>> This is problematic. Now the information that something is a vector is split up
176>> between 2 cons cells. This means GC needs both of these intact to be able to make
177>> proper decision.
178>> Will try to resolve this by adding some special symbols. But these must be symbols
179>> that cannot occur normally in programs. Then an array could be:
180
181 [Full pointer | ARRAY_SYM + GC_MARK]
182 |
183 [VECTOR]
184
185>> Boxed values same treatment as above.
186>> TODO: Could this be simpler?
187
188[ VALUE | TYPE_SYM + GC_MARK]
189
190
1910000 00XX XXXX XXXX XXXX XXXX XXXX X000 : 0x03FF FFF8
1921111 AA00 0000 0000 0000 0000 0000 0000 : 0xFC00 0000 (AA bits left unused for now, future heap growth?)
193 */
194
195typedef enum {
196 LBM_FLASH_WRITE_OK,
197 LBM_FLASH_FULL,
198 LBM_FLASH_WRITE_ERROR
199} lbm_flash_status;
200
201/** Struct representing a heap cons-cell.
202 *
203 */
204typedef struct {
205 lbm_value car;
206 lbm_value cdr;
207} lbm_cons_t;
208
209/**
210 * Heap state
211 */
212typedef struct {
213 lbm_cons_t *heap;
214 lbm_value freelist; // list of free cons cells.
215 lbm_stack_t gc_stack;
216
217 lbm_uint heap_size; // In number of cells.
218 lbm_uint heap_bytes; // In bytes.
219
220 lbm_uint num_alloc; // Number of cells allocated.
221 lbm_uint num_alloc_arrays; // Number of arrays allocated.
222
223 lbm_uint gc_num; // Number of times gc has been performed.
224 lbm_uint gc_marked; // Number of cells marked by mark phase.
225 lbm_uint gc_recovered; // Number of cells recovered by sweep phase.
226 lbm_uint gc_recovered_arrays;// Number of arrays recovered by sweep.
227 lbm_uint gc_least_free; // The smallest length of the freelist.
228 lbm_uint gc_last_free; // Number of elements on the freelist
229 // after most recent GC.
230} lbm_heap_state_t;
231
232extern lbm_heap_state_t lbm_heap_state;
233
234typedef bool_Bool (*const_heap_write_fun)(lbm_uint ix, lbm_uint w);
235
236typedef struct {
237 lbm_uint *heap;
238 lbm_uint next; // next free index.
239 lbm_uint size; // in lbm_uint words. (cons-cells = words / 2)
240} lbm_const_heap_t;
241
242/**
243 * The header portion of an array stored in array and symbol memory.
244 * An array is always a byte array. use the array-extensions for
245 * storing and reading larger values from arrays.
246 */
247typedef struct {
248 lbm_uint size; /// Number of elements
249 lbm_uint *data; /// pointer to lbm_memory array or C array.
250} lbm_array_header_t;
251
252typedef struct {
253 lbm_uint size;
254 lbm_uint *data;
255 uint32_t index; // Limits arrays to max 2^32-1 elements.
256} lbm_array_header_extended_t;
257
258/** Lock GC mutex
259 * Locks a mutex during GC marking when using the pointer reversal algorithm.
260 * Does nothing when using stack based GC mark.
261 */
262void lbm_gc_lock(void);
263/* Unlock GC mutex
264 */
265void lbm_gc_unlock(void);
266
267/** Initialize heap storage.
268 * \param addr Pointer to an array of lbm_cons_t elements. This array must at least be aligned 4.
269 * \param num_cells Number of lbm_cons_t elements in the array.
270 * \param gc_stack_size Size of the gc_stack in number of words.
271 * \return 1 on success or 0 for failure.
272 */
273int lbm_heap_init(lbm_cons_t *addr, lbm_uint num_cells,
274 lbm_uint gc_stack_size);
275
276/** Add GC time statistics to heap_stats
277 *
278 * \param dur Duration as reported by the timestamp callback.
279 */
280void lbm_heap_new_gc_time(lbm_uint dur);
281/** Add a new free_list length to the heap_stats.
282 * Calculates a new freelist length and updates
283 * the GC statistics.
284 */
285void lbm_heap_new_freelist_length(void);
286/** Check how many lbm_cons_t cells are on the free-list
287 *
288 * \return Number of free lbm_cons_t cells.
289 */
290lbm_uint lbm_heap_num_free(void);
291/** Check how many lbm_cons_t cells are allocated.
292 *
293 * \return Number of lbm_cons_t cells that are currently allocated.
294 */
295lbm_uint lbm_heap_num_allocated(void);
296/** Size of the heap in number of lbm_cons_t cells.
297 *
298 * \return Size of the heap in number of lbm_cons_t cells.
299 */
300lbm_uint lbm_heap_size(void);
301/** Size of the heap in bytes.
302 *
303 * \return Size of heap in bytes.
304 */
305lbm_uint lbm_heap_size_bytes(void);
306/** Allocate an lbm_cons_t cell from the heap.
307 *
308 * \param type A type that can be encoded onto the cell (most often LBM_PTR_TYPE_CONS).
309 * \param car Value to write into car position of allocated cell.
310 * \param cdr Value to write into cdr position of allocated cell.
311 * \return An lbm_value referring to a cons_cell or enc_sym(SYM_MERROR) in case the heap is full.
312 */
313lbm_value lbm_heap_allocate_cell(lbm_type type, lbm_value car, lbm_value cdr);
314/** Allocate a list of n heap-cells.
315 * \param n The number of heap-cells to allocate.
316 * \return A list of heap-cells of Memory error if unable to allocate.
317 */
318lbm_value lbm_heap_allocate_list(lbm_uint n);
319/** Allocate a list of n heap-cells and initialize the values.
320 * \pram ls The result list is passed through this ptr.
321 * \param n The length of list to allocate.
322 * \param valist The values in a va_list to initialize the list with.
323 * \return True of False depending on success of allocation.
324 */
325lbm_value lbm_heap_allocate_list_init_va(unsigned int n, va_list valist);
326/** Allocate a list of n heap-cells and initialize the values.
327 * \param n The length of list to allocate.
328 * \param ... The values to initialize the list with.
329 * \return allocated list or error symbol.
330 */
331lbm_value lbm_heap_allocate_list_init(unsigned int n, ...);
332/** Decode an lbm_value representing a string into a C string
333 *
334 * \param val Value
335 * \return allocated list or error symbol
336 */
337char *lbm_dec_str(lbm_value val);
338/** Decode an lbm_value representing a char channel into an lbm_char_channel_t pointer.
339 *
340 * \param val Value
341 * \return A pointer to an lbm_char_channel_t or NULL if the value does not encode a channel.
342 */
343lbm_char_channel_t *lbm_dec_channel(lbm_value val);
344/** Decode an lbm_value representing a custom type into a lbm_uint value.
345 *
346 * \param val Value.
347 * \return The custom type payload.
348 */
349lbm_uint lbm_dec_custom(lbm_value val);
350/** Decode a numerical value as if it is char
351 *
352 * \param val Value to decode
353 * \return The value encoded in val casted to a char. Returns 0 if val does not encode a number.
354 */
355uint8_t lbm_dec_as_char(lbm_value a);
356/** Decode a numerical value as if it is unsigned
357 *
358 * \param val Value to decode
359 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
360 */
361uint32_t lbm_dec_as_u32(lbm_value val);
362/** Decode a numerical value as a signed integer.
363 *
364 * \param val Value to decode
365 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
366 */
367int32_t lbm_dec_as_i32(lbm_value val);
368/** Decode a numerical value as a float.
369 *
370 * \param val Value to decode.
371 * \return The value encoded in val casted to a float. Returns 0 if val does not encode a number.
372 */
373float lbm_dec_as_float(lbm_value val);
374/** Decode a numerical value as if it is a 64bit unsigned
375 *
376 * \param val Value to decode
377 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
378 */
379uint64_t lbm_dec_as_u64(lbm_value val);
380/** Decode a numerical value as a 64bit signed integer.
381 *
382 * \param val Value to decode
383 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
384 */
385int64_t lbm_dec_as_i64(lbm_value val);
386/** Decode a numerical value as a float.
387 *
388 * \param val Value to decode.
389 * \return The value encoded in val casted to a float. Returns 0 if val does not encode a number.
390 */
391double lbm_dec_as_double(lbm_value val);
392
393/** Decode a numerical value into the architecture defined unsigned integer type.
394 *
395 * \param val Value to decode
396 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
397 */
398lbm_uint lbm_dec_as_uint(lbm_value val);
399
400/** Decode a numerical value into the architecture defined signed integer type.
401 *
402 * \param val Value to decode
403 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
404 */
405lbm_int lbm_dec_as_int(lbm_value val);
406
407lbm_uint lbm_dec_raw(lbm_value v);
408/** Allocates an lbm_cons_t cell from the heap and populates it.
409 *
410 * \param car The value to put in the car field of the allocated lbm_cons_t.
411 * \param cdr The value to put in the cdr field of the allocated lbm_cons_t.
412 * \return A value referencing the lbm_cons_t or enc_sym(SYM_MERROR) if heap is full.
413 */
414lbm_value lbm_cons(lbm_value car, lbm_value cdr);
415
416/** Accesses the car field of an lbm_cons_t.
417 *
418 * \param cons Value
419 * \return The car field of the lbm_cons_t if cons is a reference to a heap cell.
420 * If cons is nil, the return value is nil. If the value
421 * is not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
422 */
423lbm_value lbm_car(lbm_value cons);
424/** Accesses the car field the car field of an lbm_cons_t.
425 *
426 * \param cons Value
427 * \return The car of car field or nil.
428 */
429lbm_value lbm_caar(lbm_value c);
430/** Accesses the car of the cdr of an cons cell
431 *
432 * \param c Value
433 * \return the cdr field or type error.
434 */
435lbm_value lbm_cadr(lbm_value c);
436/** Accesses the cdr field of an lbm_cons_t.
437 *
438 * \param cons Value
439 * \return The cdr field of the lbm_cons_t if cons is a reference to a heap cell.
440 * If cons is nil, the return value is nil. If the value
441 * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
442 */
443lbm_value lbm_cdr(lbm_value cons);
444/** Accesses the cdr of an cdr field of an lbm_cons_t.
445 *
446 * \param cons Value
447 * \return The cdr of the cdr field of the lbm_cons_t if cons is a reference to a heap cell.
448 * If cons is nil, the return value is nil. If the value
449 * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
450 */
451lbm_value lbm_cddr(lbm_value c);
452/** Update the value stored in the car field of a heap cell.
453 *
454 * \param c Value referring to a heap cell.
455 * \param v Value to replace the car field with.
456 * \return 1 on success and 0 if the c value does not refer to a heap cell.
457 */
458int lbm_set_car(lbm_value c, lbm_value v);
459/** Update the value stored in the cdr field of a heap cell.
460 *
461 * \param c Value referring to a heap cell.
462 * \param v Value to replace the cdr field with.
463 * \return 1 on success and 0 if the c value does not refer to a heap cell.
464 */
465int lbm_set_cdr(lbm_value c, lbm_value v);
466/** Update the value stored in the car and cdr fields of a heap cell.
467 *
468 * \param c Value referring to a heap cell.
469 * \param car_val Value to replace the car field with.
470 * \param cdr_val Value to replace the cdr field with.
471 * \return 1 on success and 0 if the c value does not refer to a heap cell.
472 */
473int lbm_set_car_and_cdr(lbm_value c, lbm_value car_val, lbm_value cdr_val);
474// List functions
475/** Calculate the length of a proper list
476 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
477 * may lead to the function not terminating.
478 *
479 * \param c A list
480 * \return The length of the list. Unless the value is a cyclic structure on the heap, this function will terminate.
481 */
482lbm_uint lbm_list_length(lbm_value c);
483
484/** Calculate the length of a proper list and evaluate a predicate for each element.
485 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
486 * may lead to the function not terminating.
487 *
488 * \param c A list
489 * \param pres Boolean result of predicate, false if predicate is false for any of the elements in the list, otherwise true.
490 * \param pred Predicate to evaluate for each element of the list.
491 */
492unsigned int lbm_list_length_pred(lbm_value c, bool_Bool *pres, bool_Bool (*pred)(lbm_value));
493/** Reverse a proper list
494 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
495 * may lead to the function not terminating.
496 *
497 * \param list A list
498 * \return The list reversed or enc_sym(SYM_MERROR) if heap is full.
499 */
500lbm_value lbm_list_reverse(lbm_value list);
501/** Reverse a proper list destroying the original.
502 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
503 * may lead to the function not terminating.
504 *
505 * \param list A list
506 * \return The list reversed
507 */
508lbm_value lbm_list_destructive_reverse(lbm_value list);
509/** Copy a list
510 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
511 * may lead to the function not terminating.
512 *
513 * \param m Number of elements to copy or -1 for all. If 1, m will be updated with the length of the list
514 * \param list A list.
515 * \return Reversed list or enc_sym(SYM_MERROR) if heap is full.
516 */
517lbm_value lbm_list_copy(int *m, lbm_value list);
518
519/** A destructive append of two lists
520 *
521 * \param list1 A list
522 * \param list2 A list
523 * \return list1 with list2 appended at the end.
524 */
525lbm_value lbm_list_append(lbm_value list1, lbm_value list2);
526
527/** Drop values from the head of a list.
528 * \param n Number of values to drop.
529 * \param ls List to drop values from.
530 * \return The list with the n first elements removed.
531 */
532lbm_value lbm_list_drop(unsigned int n, lbm_value ls);
533/** Index into a list.
534 * \param l List to index into.
535 * \param n Position to read out of the list.
536 * \return Value at position n of l or nil if out of bounds.
537 */
538lbm_value lbm_index_list(lbm_value l, int32_t n);
539
540// State and statistics
541/** Get a copy of the heap statistics structure.
542 *
543 * \param A pointer to an lbm_heap_state_t to populate
544 * with the current statistics.
545 */
546void lbm_get_heap_state(lbm_heap_state_t *);
547/** Get the maximum stack level of the GC stack
548 * \return maximum value the gc stack sp reached so far.
549 */
550lbm_uint lbm_get_gc_stack_max(void);
551/** Get the size of the GC stack.
552 * \return the size of the gc stack.
553 */
554lbm_uint lbm_get_gc_stack_size(void);
555// Garbage collection
556/** Increment the counter that is counting the number of times GC ran
557 *
558 */
559void lbm_gc_state_inc(void);
560/** Set the freelist to NIL. Means that no memory will be available
561 * until after a garbage collection.
562 */
563void lbm_nil_freelist(void);
564/** Mark all heap cells reachable from an environment.
565 * \param environment.
566 */
567void lbm_gc_mark_env(lbm_value);
568/** Mark heap cells reachable from the lbm_value v.
569 * \param root
570 */
571void lbm_gc_mark_phase(lbm_value root);
572/** Performs lbm_gc_mark_phase on all the values of an array.
573 * This function is similar to lbm_gc_mark_roots but performs
574 * extra checks to not traverse into non-standard values.
575 * TODO: Check if this function is really needed.
576 * \param data Array of roots to traverse from.
577 * \param n Number of elements in roots-array.
578 */
579void lbm_gc_mark_aux(lbm_uint *data, lbm_uint n);
580/** Performs lbm_gc_mark_phase on all the values in the roots array.
581 * \param roots pointer to array of roots.
582 * \param num_roots size of array of roots.
583 */
584void lbm_gc_mark_roots(lbm_uint *roots, lbm_uint num_roots);
585/** Sweep up all non marked heap cells and place them on the free list.
586 *
587 * \return 1
588 */
589int lbm_gc_sweep_phase(void);
590
591// Array functionality
592/** Allocate an bytearray in symbols and arrays memory (lispbm_memory.h)
593 * and create a heap cell that refers to this bytearray.
594 * \param res The resulting lbm_value is returned through this argument.
595 * \param size Array size in number of 32 bit words.
596 * \return 1 for success of 0 for failure.
597 */
598int lbm_heap_allocate_array(lbm_value *res, lbm_uint size);
599/** Allocate an array in symbols and arrays memory (lispbm_memory.h)
600 * and create a heap cell that refers to this array.
601 * \param res The resulting lbm_value is returned through this argument.
602 * \param size Array size in number of 32 bit words.
603 * \return 1 for success of 0 for failure.
604 */
605int lbm_heap_allocate_lisp_array(lbm_value *res, lbm_uint size);
606/** Convert a C array into an lbm array. If the C array is allocated in LBM MEMORY
607 * the lifetime of the array will be managed by GC.
608 * \param res lbm_value result pointer for storage of the result array.
609 * \param data C array.
610 * \param type The type tag to assign to the resulting LBM array.
611 * \param num_elt Number of elements in the array.
612 * \return 1 for success and 0 for failure.
613 */
614int lbm_lift_array(lbm_value *value, char *data, lbm_uint num_elt);
615/** Get the size of an array value.
616 * \param arr lbm_value array to get size of.
617 * \return -1 for failure or length of array.
618 */
619lbm_int lbm_heap_array_get_size(lbm_value arr);
620/** Get a pointer to the data of an array for read only purposes.
621 * \param arr lbm_value array to get pointer from.
622 * \return NULL or valid pointer.
623 */
624const uint8_t *lbm_heap_array_get_data_ro(lbm_value arr);
625/** Get a pointer to the data of an array for read/write purposes.
626 * \param arr lbm_value array to get pointer from.
627 * \return NULL or valid pointer.
628 */
629uint8_t *lbm_heap_array_get_data_rw(lbm_value arr);
630/** Explicitly free an array.
631 * This function needs to be used with care and knowledge.
632 * \param arr Array value.
633 */
634int lbm_heap_explicit_free_array(lbm_value arr);
635/** Query the size in bytes of an lbm_type.
636 * \param t Type
637 * \return Size in bytes of type or 0 if the type represents a composite.
638 */
639lbm_uint lbm_size_of(lbm_type t);
640
641int lbm_const_heap_init(const_heap_write_fun w_fun,
642 lbm_const_heap_t *heap,
643 lbm_uint *addr,
644 lbm_uint num_words);
645
646lbm_flash_status lbm_allocate_const_cell(lbm_value *res);
647lbm_flash_status lbm_write_const_raw(lbm_uint *data, lbm_uint n, lbm_uint *res);
648lbm_flash_status lbm_allocate_const_raw(lbm_uint nwords, lbm_uint *res);
649lbm_flash_status write_const_cdr(lbm_value cell, lbm_value val);
650lbm_flash_status write_const_car(lbm_value cell, lbm_value val);
651lbm_flash_status lbm_const_write(lbm_uint *tgt, lbm_uint val);
652lbm_uint lbm_flash_memory_usage(void);
653
654/** Query the type information of a value.
655 *
656 * \param x Value to check the type of.
657 * \return The type information.
658 */
659static inline lbm_type lbm_type_of(lbm_value x) {
660 return (x & LBM_PTR_BIT0x00000001u) ? (x & LBM_PTR_TYPE_MASK0xFC000000u) : (x & LBM_VAL_TYPE_MASK0x0000000Cu);
661}
662
663// type-of check that is safe in functional code
664static inline lbm_type lbm_type_of_functional(lbm_value x) {
665 return (x & LBM_PTR_BIT0x00000001u) ?
666 (x & (LBM_PTR_TO_CONSTANT_MASK~0x04000000u & LBM_PTR_TYPE_MASK0xFC000000u)) :
667 (x & LBM_VAL_TYPE_MASK0x0000000Cu);
668}
669
670static inline lbm_value lbm_enc_cons_ptr(lbm_uint x) {
671 return ((x << LBM_ADDRESS_SHIFT2) | LBM_TYPE_CONS0x10000000u | LBM_PTR_BIT0x00000001u);
672}
673
674static inline lbm_uint lbm_dec_ptr(lbm_value p) {
675 return ((LBM_PTR_VAL_MASK0x03FFFFFCu & p) >> LBM_ADDRESS_SHIFT2);
676}
677
678extern lbm_cons_t *lbm_heaps[2];
679
680static inline lbm_uint lbm_dec_cons_cell_ptr(lbm_value p) {
681 lbm_uint h = (p & LBM_PTR_TO_CONSTANT_BIT0x04000000u) >> LBM_PTR_TO_CONSTANT_SHIFT26;
682 return lbm_dec_ptr(p) >> h;
683}
684
685static inline lbm_cons_t *lbm_dec_heap(lbm_value p) {
686 lbm_uint h = (p & LBM_PTR_TO_CONSTANT_BIT0x04000000u) >> LBM_PTR_TO_CONSTANT_SHIFT26;
687 return lbm_heaps[h];
688}
689
690static inline lbm_value lbm_set_ptr_type(lbm_value p, lbm_type t) {
691 return ((LBM_PTR_VAL_MASK0x03FFFFFCu & p) | t | LBM_PTR_BIT0x00000001u);
692}
693
694static inline lbm_value lbm_enc_sym(lbm_uint s) {
695 return (s << LBM_VAL_SHIFT4) | LBM_TYPE_SYMBOL0x00000000u;
696}
697
698static inline lbm_value lbm_enc_i(lbm_int x) {
699 return ((lbm_uint)x << LBM_VAL_SHIFT4) | LBM_TYPE_I0x00000008u;
700}
701
702static inline lbm_value lbm_enc_u(lbm_uint x) {
703 return (x << LBM_VAL_SHIFT4) | LBM_TYPE_U0x0000000Cu;
704}
705
706/** Encode 32 bit integer into an lbm_value.
707 * \param x Value to encode.
708 * \return result encoded value.
709 */
710extern lbm_value lbm_enc_i32(int32_t x);
711
712/** Encode 32 bit unsigned integer into an lbm_value.
713 * \param x Value to encode.
714 * \return result encoded value.
715 */
716extern lbm_value lbm_enc_u32(uint32_t x);
717
718/** Encode a float into an lbm_value.
719 * \param x float value to encode.
720 * \return result encoded value.
721 */
722extern lbm_value lbm_enc_float(float x);
723
724/** Encode a 64 bit integer into an lbm_value.
725 * \param x 64 bit integer to encode.
726 * \return result encoded value.
727 */
728extern lbm_value lbm_enc_i64(int64_t x);
729
730/** Encode a 64 bit unsigned integer into an lbm_value.
731 * \param x 64 bit unsigned integer to encode.
732 * \return result encoded value.
733 */
734extern lbm_value lbm_enc_u64(uint64_t x);
735
736/** Encode a double into an lbm_value.
737 * \param x double to encode.
738 * \return result encoded value.
739 */
740extern lbm_value lbm_enc_double(double x);
741
742static inline lbm_value lbm_enc_char(uint8_t x) {
743 return ((lbm_uint)x << LBM_VAL_SHIFT4) | LBM_TYPE_CHAR0x00000004u;
744}
745
746static inline lbm_int lbm_dec_i(lbm_value x) {
747 return (lbm_int)x >> LBM_VAL_SHIFT4;
748}
749
750static inline lbm_uint lbm_dec_u(lbm_value x) {
751 return x >> LBM_VAL_SHIFT4;
752}
753
754static inline uint8_t lbm_dec_char(lbm_value x) {
755 return (uint8_t)(x >> LBM_VAL_SHIFT4);
756}
757
758static inline lbm_uint lbm_dec_sym(lbm_value x) {
759 return x >> LBM_VAL_SHIFT4;
760}
761
762/** Decode an lbm_value representing a float.
763 * \param x Value to decode.
764 * \return decoded float.
765 */
766extern float lbm_dec_float(lbm_value x);
767
768/** Decode an lbm_value representing a double.
769 * \param x Value to decode.
770 * \return decoded float.
771 */
772extern double lbm_dec_double(lbm_value x);
773
774
775static inline uint32_t lbm_dec_u32(lbm_value x) {
776#ifndef LBM64
777 return (uint32_t)lbm_car(x);
778#else
779 return (uint32_t)(x >> LBM_VAL_SHIFT4);
780#endif
781}
782
783/** Decode an lbm_value representing a 64 bit unsigned integer.
784 * \param x Value to decode.
785 * \return decoded uint64_t.
786 */
787extern uint64_t lbm_dec_u64(lbm_value x);
788
789static inline int32_t lbm_dec_i32(lbm_value x) {
790#ifndef LBM64
791 return (int32_t)lbm_car(x);
792#else
793 return (int32_t)(x >> LBM_VAL_SHIFT4);
794#endif
795}
796
797/** Decode an lbm_value representing a 64 bit integer.
798 * \param x Value to decode.
799 * \return decoded int64_t.
800 */
801extern int64_t lbm_dec_i64(lbm_value x);
802
803/**
804 * Check if a value is a heap pointer
805 * \param x Value to check
806 * \return true if x is a pointer to a heap cell, false otherwise.
807 */
808static inline bool_Bool lbm_is_ptr(lbm_value x) {
809 return (x & LBM_PTR_BIT0x00000001u);
810}
811
812/**
813 * Check if a value is a Read/Writeable cons cell
814 * \param x Value to check
815 * \return true if x is a Read/Writeable cons cell, false otherwise.
816 */
817static inline bool_Bool lbm_is_cons_rw(lbm_value x) {
818 return (lbm_type_of(x) == LBM_TYPE_CONS0x10000000u);
819}
820
821/**
822 * Check if a value is a Readable cons cell
823 * \param x Value to check
824 * \return true if x is a readable cons cell, false otherwise.
825 */
826static inline bool_Bool lbm_is_cons(lbm_value x) {
827 return lbm_is_ptr(x) && ((x & LBM_CONS_TYPE_MASK0xF0000000u) == LBM_TYPE_CONS0x10000000u);
828}
829
830/** Check if a value represents a number
831 * \param x Value to check.
832 * \return true is x represents a number and false otherwise.
833 */
834static inline bool_Bool lbm_is_number(lbm_value x) {
835 return
836 (x & LBM_PTR_BIT0x00000001u) ?
837 ((x & LBM_NUMBER_MASK0x08000000u) == LBM_NUMBER_MASK0x08000000u) :
838 (x & LBM_VAL_TYPE_MASK0x0000000Cu);
839}
840
841/** Check if value is an array that can be READ
842 * \param x Value to check.
843 * \return true if x represents a readable array and false otherwise.
844 */
845static inline bool_Bool lbm_is_array_r(lbm_value x) {
846 lbm_type t = lbm_type_of(x);
847 return ((t & LBM_PTR_TO_CONSTANT_MASK~0x04000000u) == LBM_TYPE_ARRAY0x80000000u);
2
←
Assuming the condition is true
→
3
←
Returning the value 1, which participates in a condition later
→
848}
849
850static inline bool_Bool lbm_is_array_rw(lbm_value x) {
851 return( (lbm_type_of(x) == LBM_TYPE_ARRAY0x80000000u) && !(x & LBM_PTR_TO_CONSTANT_BIT0x04000000u));
852}
853
854static inline bool_Bool lbm_is_lisp_array_r(lbm_value x) {
855 lbm_type t = lbm_type_of(x);
856 return ((t & LBM_PTR_TO_CONSTANT_MASK~0x04000000u) == LBM_TYPE_LISPARRAY0xB0000000u);
857}
858
859static inline bool_Bool lbm_is_lisp_array_rw(lbm_value x) {
860 return( (lbm_type_of(x) == LBM_TYPE_LISPARRAY0xB0000000u) && !(x & LBM_PTR_TO_CONSTANT_BIT0x04000000u));
861}
862
863
864static inline bool_Bool lbm_is_channel(lbm_value x) {
865 return (lbm_type_of(x) == LBM_TYPE_CHANNEL0x90000000u &&
866 lbm_type_of(lbm_cdr(x)) == LBM_TYPE_SYMBOL0x00000000u &&
867 lbm_cdr(x) == ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
868}
869static inline bool_Bool lbm_is_char(lbm_value x) {
870 return (lbm_type_of(x) == LBM_TYPE_CHAR0x00000004u);
871}
872
873static inline bool_Bool lbm_is_special(lbm_value symrep) {
874 return ((lbm_type_of(symrep) == LBM_TYPE_SYMBOL0x00000000u) &&
875 (lbm_dec_sym(symrep) < SPECIAL_SYMBOLS_END0xFFFF));
876}
877
878static inline bool_Bool lbm_is_closure(lbm_value exp) {
879 return ((lbm_is_cons(exp)) &&
880 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
881 (lbm_car(exp) == ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u)));
882}
883
884static inline bool_Bool lbm_is_continuation(lbm_value exp) {
885 return ((lbm_type_of(exp) == LBM_TYPE_CONS0x10000000u) &&
886 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
887 (lbm_car(exp) == ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u)));
888}
889
890static inline bool_Bool lbm_is_macro(lbm_value exp) {
891 return ((lbm_type_of(exp) == LBM_TYPE_CONS0x10000000u) &&
892 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
893 (lbm_car(exp) == ENC_SYM_MACRO(((0x10D) << 4) | 0x00000000u)));
894}
895
896static inline bool_Bool lbm_is_match_binder(lbm_value exp) {
897 return (lbm_is_cons(exp) &&
898 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
899 (lbm_car(exp) == ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u)));
900}
901
902static inline bool_Bool lbm_is_comma_qualified_symbol(lbm_value exp) {
903 return (lbm_is_cons(exp) &&
904 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
905 (lbm_car(exp) == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) &&
906 (lbm_type_of(lbm_cadr(exp)) == LBM_TYPE_SYMBOL0x00000000u));
907}
908
909static inline bool_Bool lbm_is_symbol(lbm_value exp) {
910 return !(exp & LBM_LOW_RESERVED_BITS0x0000000Fu);
911}
912
913static inline bool_Bool lbm_is_symbol_nil(lbm_value exp) {
914 return !exp;
915}
916
917static inline bool_Bool lbm_is_symbol_true(lbm_value exp) {
918 return (lbm_is_symbol(exp) && exp == ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u));
919}
920
921static inline bool_Bool lbm_is_symbol_eval(lbm_value exp) {
922 return (lbm_is_symbol(exp) && exp == ENC_SYM_EVAL(((0x30008) << 4) | 0x00000000u));
923}
924
925static inline bool_Bool lbm_is_symbol_merror(lbm_value exp) {
926 return lbm_is_symbol(exp) && (exp == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
927}
928
929static inline bool_Bool lbm_is_list(lbm_value x) {
930 return (lbm_is_cons(x) || lbm_is_symbol_nil(x));
931}
932
933static inline bool_Bool lbm_is_list_rw(lbm_value x) {
934 return (lbm_is_cons_rw(x) || lbm_is_symbol_nil(x));
935}
936
937static inline bool_Bool lbm_is_quoted_list(lbm_value x) {
938 return (lbm_is_cons(x) &&
939 lbm_is_symbol(lbm_car(x)) &&
940 (lbm_car(x) == ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u)) &&
941 lbm_is_cons(lbm_cdr(x)) &&
942 lbm_is_cons(lbm_cadr(x)));
943}
944
945#ifndef LBM64
946#define ERROR_SYMBOL_MASK0xFFFFFFF0 0xFFFFFFF0
947#else
948#define ERROR_SYMBOL_MASK0xFFFFFFF0 0xFFFFFFFFFFFFFFF0
949#endif
950
951/* all error signaling symbols are in the range 0x20 - 0x2F */
952static inline bool_Bool lbm_is_error(lbm_value v){
953 return (lbm_is_symbol(v) &&
954 ((lbm_dec_sym(v) & ERROR_SYMBOL_MASK0xFFFFFFF0) == 0x20));
955}
956
957// ref_cell: returns a reference to the cell addressed by bits 3 - 26
958// Assumes user has checked that is_ptr was set
959static inline lbm_cons_t* lbm_ref_cell(lbm_value addr) {
960 return &lbm_dec_heap(addr)[lbm_dec_cons_cell_ptr(addr)];
961 //return &lbm_heap_state.heap[lbm_dec_ptr(addr)];
962}
963
964
965// lbm_uint a = lbm_heaps[0];
966// lbm_uint b = lbm_heaps[1];
967// lbm_uint i = (addr & LBM_PTR_TO_CONSTANT_BIT) >> LBM_PTR_TO_CONSTANT_SHIFT) - 1;
968// lbm_uint h = (a & i) | (b & ~i);
969
970#ifdef __cplusplus
971}
972#endif
973#endif
diff --git a/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-f2a4bc.html b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-f2a4bc.html new file mode 100644 index 00000000..c781e70d --- /dev/null +++ b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-f2a4bc.html @@ -0,0 +1,6533 @@ + + + +src/eval_cps.c + + + + + + + + + + + + + + + + + + + + + + + + + + +

Bug Summary

+ + + + +
File:eval_cps.c
Warning:line 4599, column 36
Access to field 'data' results in a dereference of a null pointer (loaded from variable 'tgt_arr')
+ +

Annotated Source Code

+

Press '?' + to see keyboard shortcuts

+ + +
clang -cc1 -triple i386-pc-linux-gnu -analyze -disable-free -disable-llvm-verifier -discard-value-names -main-file-name eval_cps.c -analyzer-store=region -analyzer-opt-analyze-nested-blocks -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -mrelocation-model static -mthread-model posix -mframe-pointer=none -fmath-errno -fno-rounding-math -masm-verbose -mconstructor-aliases -target-cpu i686 -dwarf-column-info -fno-split-dwarf-inlining -debugger-tuning=gdb -resource-dir /usr/lib/llvm-10/lib/clang/10.0.0 -I ./include -I ./include/extensions -I platform/linux/include -D _PRELUDE -internal-isystem /usr/local/include -internal-isystem /usr/lib/llvm-10/lib/clang/10.0.0/include -internal-externc-isystem /usr/include/i386-linux-gnu -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -std=c99 -fdebug-compilation-dir /home/joels/Current/lispbm -ferror-limit 19 -fmessage-length 0 -fgnuc-version=4.2.1 -fobjc-runtime=gcc -fdiagnostics-show-option -vectorize-loops -vectorize-slp -analyzer-output=html -faddrsig -o /home/joels/Current/lispbm/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1 -x c src/eval_cps.c +
+ + + +
+ + +
+ + + + +
+

src/eval_cps.c

+
→
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1/*
2 Copyright 2018, 2020 - 2024 Joel Svensson svenssonjoel@yahoo.se
3
4 This program is free software: you can redistribute it and/or modify
5 it under the terms of the GNU General Public License as published by
6 the Free Software Foundation, either version 3 of the License, or
7 (at your option) any later version.
8
9 This program is distributed in the hope that it will be useful,
10 but WITHOUT ANY WARRANTY; without even the implied warranty of
11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 GNU General Public License for more details.
13
14 You should have received a copy of the GNU General Public License
15 along with this program. If not, see <http://www.gnu.org/licenses/>.
16*/
17
18#include <lbm_memory.h>
19#include <lbm_types.h>
20#include "symrepr.h"
21#include "heap.h"
22#include "env.h"
23#include "eval_cps.h"
24#include "stack.h"
25#include "fundamental.h"
26#include "extensions.h"
27#include "tokpar.h"
28#include "lbm_channel.h"
29#include "print.h"
30#include "platform_mutex.h"
31#include "lbm_flat_value.h"
32#include "lbm_flags.h"
33
34#ifdef VISUALIZE_HEAP
35#include "heap_vis.h"
36#endif
37
38#include <setjmp.h>
39#include <stdarg.h>
40
41static jmp_buf error_jmp_buf;
42static jmp_buf critical_error_jmp_buf;
43
44#define S_TO_US(X)(lbm_uint)((X) * 1000000) (lbm_uint)((X) * 1000000)
45
46#define DEC_CONTINUATION(x)(((x) & ~0xF8000001u) >> 2) (((x) & ~LBM_CONTINUATION_INTERNAL0xF8000001u) >> LBM_ADDRESS_SHIFT2)
47#define IS_CONTINUATION(x)(((x) & 0xF8000001u) == 0xF8000001u) (((x) & LBM_CONTINUATION_INTERNAL0xF8000001u) == LBM_CONTINUATION_INTERNAL0xF8000001u)
48#define CONTINUATION(x)(((x) << 2) | 0xF8000001u) (((x) << LBM_ADDRESS_SHIFT2) | LBM_CONTINUATION_INTERNAL0xF8000001u)
49
50#define DONE(((0) << 2) | 0xF8000001u) CONTINUATION(0)(((0) << 2) | 0xF8000001u)
51#define SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u) CONTINUATION(1)(((1) << 2) | 0xF8000001u)
52#define BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u) CONTINUATION(2)(((2) << 2) | 0xF8000001u)
53#define IF(((3) << 2) | 0xF8000001u) CONTINUATION(3)(((3) << 2) | 0xF8000001u)
54#define PROGN_REST(((4) << 2) | 0xF8000001u) CONTINUATION(4)(((4) << 2) | 0xF8000001u)
55#define APPLICATION_ARGS(((5) << 2) | 0xF8000001u) CONTINUATION(5)(((5) << 2) | 0xF8000001u)
56#define AND(((6) << 2) | 0xF8000001u) CONTINUATION(6)(((6) << 2) | 0xF8000001u)
57#define OR(((7) << 2) | 0xF8000001u) CONTINUATION(7)(((7) << 2) | 0xF8000001u)
58#define WAIT(((8) << 2) | 0xF8000001u) CONTINUATION(8)(((8) << 2) | 0xF8000001u)
59#define MATCH(((9) << 2) | 0xF8000001u) CONTINUATION(9)(((9) << 2) | 0xF8000001u)
60#define APPLICATION_START(((10) << 2) | 0xF8000001u) CONTINUATION(10)(((10) << 2) | 0xF8000001u)
61#define EVAL_R(((11) << 2) | 0xF8000001u) CONTINUATION(11)(((11) << 2) | 0xF8000001u)
62#define RESUME(((12) << 2) | 0xF8000001u) CONTINUATION(12)(((12) << 2) | 0xF8000001u)
63#define CLOSURE_ARGS(((13) << 2) | 0xF8000001u) CONTINUATION(13)(((13) << 2) | 0xF8000001u)
64#define EXIT_ATOMIC(((14) << 2) | 0xF8000001u) CONTINUATION(14)(((14) << 2) | 0xF8000001u)
65#define READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u) CONTINUATION(15)(((15) << 2) | 0xF8000001u)
66#define READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u) CONTINUATION(16)(((16) << 2) | 0xF8000001u)
67#define READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u) CONTINUATION(17)(((17) << 2) | 0xF8000001u)
68#define READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u) CONTINUATION(18)(((18) << 2) | 0xF8000001u)
69#define READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u) CONTINUATION(19)(((19) << 2) | 0xF8000001u)
70#define READ_DONE(((20) << 2) | 0xF8000001u) CONTINUATION(20)(((20) << 2) | 0xF8000001u)
71#define READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u) CONTINUATION(21)(((21) << 2) | 0xF8000001u)
72#define READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u) CONTINUATION(22)(((22) << 2) | 0xF8000001u)
73#define READ_COMMA_RESULT(((23) << 2) | 0xF8000001u) CONTINUATION(23)(((23) << 2) | 0xF8000001u)
74#define READ_START_ARRAY(((24) << 2) | 0xF8000001u) CONTINUATION(24)(((24) << 2) | 0xF8000001u)
75#define READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u) CONTINUATION(25)(((25) << 2) | 0xF8000001u)
76#define MAP(((26) << 2) | 0xF8000001u) CONTINUATION(26)(((26) << 2) | 0xF8000001u)
77#define MATCH_GUARD(((27) << 2) | 0xF8000001u) CONTINUATION(27)(((27) << 2) | 0xF8000001u)
78#define TERMINATE(((28) << 2) | 0xF8000001u) CONTINUATION(28)(((28) << 2) | 0xF8000001u)
79#define PROGN_VAR(((29) << 2) | 0xF8000001u) CONTINUATION(29)(((29) << 2) | 0xF8000001u)
80#define SETQ(((30) << 2) | 0xF8000001u) CONTINUATION(30)(((30) << 2) | 0xF8000001u)
81#define MOVE_TO_FLASH(((31) << 2) | 0xF8000001u) CONTINUATION(31)(((31) << 2) | 0xF8000001u)
82#define MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u) CONTINUATION(32)(((32) << 2) | 0xF8000001u)
83#define MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u) CONTINUATION(33)(((33) << 2) | 0xF8000001u)
84#define CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u) CONTINUATION(34)(((34) << 2) | 0xF8000001u)
85#define QQ_EXPAND_START(((35) << 2) | 0xF8000001u) CONTINUATION(35)(((35) << 2) | 0xF8000001u)
86#define QQ_EXPAND(((36) << 2) | 0xF8000001u) CONTINUATION(36)(((36) << 2) | 0xF8000001u)
87#define QQ_APPEND(((37) << 2) | 0xF8000001u) CONTINUATION(37)(((37) << 2) | 0xF8000001u)
88#define QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u) CONTINUATION(38)(((38) << 2) | 0xF8000001u)
89#define QQ_LIST(((39) << 2) | 0xF8000001u) CONTINUATION(39)(((39) << 2) | 0xF8000001u)
90#define KILL(((40) << 2) | 0xF8000001u) CONTINUATION(40)(((40) << 2) | 0xF8000001u)
91#define LOOP(((41) << 2) | 0xF8000001u) CONTINUATION(41)(((41) << 2) | 0xF8000001u)
92#define LOOP_CONDITION(((42) << 2) | 0xF8000001u) CONTINUATION(42)(((42) << 2) | 0xF8000001u)
93#define MERGE_REST(((43) << 2) | 0xF8000001u) CONTINUATION(43)(((43) << 2) | 0xF8000001u)
94#define MERGE_LAYER(((44) << 2) | 0xF8000001u) CONTINUATION(44)(((44) << 2) | 0xF8000001u)
95#define CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u) CONTINUATION(45)(((45) << 2) | 0xF8000001u)
96#define MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u) CONTINUATION(46)(((46) << 2) | 0xF8000001u)
97#define POP_READER_FLAGS(((47) << 2) | 0xF8000001u) CONTINUATION(47)(((47) << 2) | 0xF8000001u)
98#define EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u) CONTINUATION(48)(((48) << 2) | 0xF8000001u)
99#define NUM_CONTINUATIONS49 49
100
101#define FM_NEED_GC-1 -1
102#define FM_NO_MATCH-2 -2
103#define FM_PATTERN_ERROR-3 -3
104
105typedef enum {
106 BL_OK = 0,
107 BL_NO_MEMORY,
108 BL_INCORRECT_KEY
109} binding_location_status;
110
111#define FB_OK0 0
112#define FB_TYPE_ERROR-1 -1
113
114const char* lbm_error_str_parse_eof = "End of parse stream.";
115const char* lbm_error_str_parse_dot = "Incorrect usage of '.'.";
116const char* lbm_error_str_parse_close = "Expected closing parenthesis.";
117const char* lbm_error_str_num_args = "Incorrect number of arguments.";
118const char* lbm_error_str_forbidden_in_atomic = "Operation is forbidden in an atomic block.";
119const char* lbm_error_str_no_number = "Argument(s) must be a number.";
120const char* lbm_error_str_not_a_boolean = "Argument must be t or nil (true or false).";
121const char* lbm_error_str_incorrect_arg = "Incorrect argument.";
122const char* lbm_error_str_var_outside_progn = "Usage of var outside of progn.";
123const char* lbm_error_str_flash_not_possible = "Value cannot be written to flash.";
124const char* lbm_error_str_flash_error = "Error writing to flash.";
125const char* lbm_error_str_flash_full = "Flash memory is full.";
126const char* lbm_error_str_variable_not_bound = "Variable not bound.";
127
128static lbm_value lbm_error_suspect;
129static bool_Bool lbm_error_has_suspect = false0;
130#ifdef LBM_ALWAYS_GC
131
132#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
133 gc(); \
134 (y) = (x); \
135 if (lbm_is_symbol_merror((y))) { \
136 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
137 }
138
139#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
140 lbm_gc_mark_phase(r); \
141 gc(); \
142 (y) = (x); \
143 if (lbm_is_symbol_merror((y))) { \
144 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
145 }
146
147#else
148
149#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
150 (y) = (x); \
151 if (lbm_is_symbol_merror((y))) { \
152 gc(); \
153 (y) = (x); \
154 if (lbm_is_symbol_merror((y))) { \
155 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
156 } \
157 /* continue executing statements below */ \
158 }
159#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
160 (y) = (x); \
161 if (lbm_is_symbol_merror((y))) { \
162 lbm_gc_mark_phase(r); \
163 gc(); \
164 (y) = (x); \
165 if (lbm_is_symbol_merror((y))) { \
166 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
167 } \
168 /* continue executing statements below */ \
169 }
170
171#endif
172
173typedef struct {
174 eval_context_t *first;
175 eval_context_t *last;
176} eval_context_queue_t;
177
178#ifdef CLEAN_UP_CLOSURES
179static lbm_value clean_cl_env_symbol = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
180#endif
181
182static int gc(void);
183static void error_ctx(lbm_value);
184static void error_at_ctx(lbm_value err_val, lbm_value at);
185static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx);
186static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail);
187
188// The currently executing context.
189eval_context_t *ctx_running = NULL((void*)0);
190volatile bool_Bool lbm_system_sleeping = false0;
191
192static volatile bool_Bool gc_requested = false0;
193void lbm_request_gc(void) {
194 gc_requested = true1;
195}
196
197/*
198 On ChibiOs the CH_CFG_ST_FREQUENCY setting in chconf.h sets the
199 resolution of the timer used for sleep operations. If this is set
200 to 10KHz the resolution is 100us.
201
202 The CH_CFG_ST_TIMEDELTA specifies the minimum number of ticks that
203 can be safely specified in a timeout directive (wonder if that
204 means sleep-period). The timedelta is set to 2.
205
206 If I have understood these correctly it means that the minimum
207 sleep duration possible is 2 * 100us = 200us.
208*/
209
210#define EVAL_CPS_DEFAULT_STACK_SIZE256 256
211#define EVAL_CPS_MIN_SLEEP200 200
212#define EVAL_STEPS_QUOTA10 10
213
214static volatile uint32_t eval_steps_refill = EVAL_STEPS_QUOTA10;
215static uint32_t eval_steps_quota = EVAL_STEPS_QUOTA10;
216
217void lbm_set_eval_step_quota(uint32_t quota) {
218 eval_steps_refill = quota;
219}
220
221static uint32_t eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
222static volatile uint32_t eval_cps_next_state = EVAL_CPS_STATE_NONE0;
223static volatile uint32_t eval_cps_next_state_arg = 0;
224static volatile bool_Bool eval_cps_state_changed = false0;
225
226static void usleep_nonsense(uint32_t us) {
227 (void) us;
228}
229
230static bool_Bool dynamic_load_nonsense(const char *sym, const char **code) {
231 (void) sym;
232 (void) code;
233 return false0;
234}
235
236static uint32_t timestamp_nonsense(void) {
237 return 0;
238}
239
240static int printf_nonsense(const char *fmt, ...) {
241 (void) fmt;
242 return 0;
243}
244
245static void ctx_done_nonsense(eval_context_t *ctx) {
246 (void) ctx;
247}
248
249static void critical_nonsense(void) {
250 return;
251}
252
253static void (*critical_error_callback)(void) = critical_nonsense;
254static void (*usleep_callback)(uint32_t) = usleep_nonsense;
255static uint32_t (*timestamp_us_callback)(void) = timestamp_nonsense;
256static void (*ctx_done_callback)(eval_context_t *) = ctx_done_nonsense;
257static int (*printf_callback)(const char *, ...) = printf_nonsense;
258static bool_Bool (*dynamic_load_callback)(const char *, const char **) = dynamic_load_nonsense;
259
260void lbm_set_critical_error_callback(void (*fptr)(void)) {
261 if (fptr == NULL((void*)0)) critical_error_callback = critical_nonsense;
262 else critical_error_callback = fptr;
263}
264
265void lbm_set_usleep_callback(void (*fptr)(uint32_t)) {
266 if (fptr == NULL((void*)0)) usleep_callback = usleep_nonsense;
267 else usleep_callback = fptr;
268}
269
270void lbm_set_timestamp_us_callback(uint32_t (*fptr)(void)) {
271 if (fptr == NULL((void*)0)) timestamp_us_callback = timestamp_nonsense;
272 else timestamp_us_callback = fptr;
273}
274
275void lbm_set_ctx_done_callback(void (*fptr)(eval_context_t *)) {
276 if (fptr == NULL((void*)0)) ctx_done_callback = ctx_done_nonsense;
277 else ctx_done_callback = fptr;
278}
279
280void lbm_set_printf_callback(int (*fptr)(const char*, ...)){
281 if (fptr == NULL((void*)0)) printf_callback = printf_nonsense;
282 else printf_callback = fptr;
283}
284
285void lbm_set_dynamic_load_callback(bool_Bool (*fptr)(const char *, const char **)) {
286 if (fptr == NULL((void*)0)) dynamic_load_callback = dynamic_load_nonsense;
287 else dynamic_load_callback = fptr;
288}
289
290static volatile lbm_event_t *lbm_events = NULL((void*)0);
291static unsigned int lbm_events_head = 0;
292static unsigned int lbm_events_tail = 0;
293static unsigned int lbm_events_max = 0;
294static bool_Bool lbm_events_full = false0;
295static mutex_t lbm_events_mutex;
296static bool_Bool lbm_events_mutex_initialized = false0;
297static volatile lbm_cid lbm_event_handler_pid = -1;
298
299lbm_cid lbm_get_event_handler_pid(void) {
300 return lbm_event_handler_pid;
301}
302
303void lbm_set_event_handler_pid(lbm_cid pid) {
304 lbm_event_handler_pid = pid;
305}
306
307bool_Bool lbm_event_handler_exists(void) {
308 return(lbm_event_handler_pid > 0);
309}
310
311
312static bool_Bool event_internal(lbm_event_type_t event_type, lbm_uint parameter, lbm_uint buf_ptr, lbm_uint buf_len) {
313 bool_Bool r = false0;
314 if (lbm_events) {
315 mutex_lock(&lbm_events_mutex);
316 if (!lbm_events_full) {
317 lbm_event_t event;
318 event.type = event_type;
319 event.parameter = parameter;
320 event.buf_ptr = buf_ptr;
321 event.buf_len = buf_len;
322 lbm_events[lbm_events_head] = event;
323 lbm_events_head = (lbm_events_head + 1) % lbm_events_max;
324 lbm_events_full = lbm_events_head == lbm_events_tail;
325 r = true1;
326 }
327 mutex_unlock(&lbm_events_mutex);
328 }
329 return r;
330}
331
332bool_Bool lbm_event_define(lbm_value key, lbm_flat_value_t *fv) {
333 return event_internal(LBM_EVENT_DEFINE, key, (lbm_uint)fv->buf, fv->buf_size);
334}
335
336bool_Bool lbm_event_unboxed(lbm_value unboxed) {
337 lbm_uint t = lbm_type_of(unboxed);
338 if (t == LBM_TYPE_SYMBOL0x00000000u ||
339 t == LBM_TYPE_I0x00000008u ||
340 t == LBM_TYPE_U0x0000000Cu ||
341 t == LBM_TYPE_CHAR0x00000004u) {
342 if (lbm_event_handler_pid > 0) {
343 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)unboxed, 0);
344 }
345 }
346 return false0;
347}
348
349bool_Bool lbm_event(lbm_flat_value_t *fv) {
350 if (lbm_event_handler_pid > 0) {
351 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)fv->buf, fv->buf_size);
352 }
353 return false0;
354}
355
356static bool_Bool lbm_event_pop(lbm_event_t *event) {
357 mutex_lock(&lbm_events_mutex);
358 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
359 mutex_unlock(&lbm_events_mutex);
360 return false0;
361 }
362 *event = lbm_events[lbm_events_tail];
363 lbm_events_tail = (lbm_events_tail + 1) % lbm_events_max;
364 lbm_events_full = false0;
365 mutex_unlock(&lbm_events_mutex);
366 return true1;
367}
368
369bool_Bool lbm_event_queue_is_empty(void) {
370 mutex_lock(&lbm_events_mutex);
371 bool_Bool empty = false0;
372 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
373 empty = true1;
374 }
375 mutex_unlock(&lbm_events_mutex);
376 return empty;
377}
378
379static bool_Bool eval_running = false0;
380static volatile bool_Bool blocking_extension = false0;
381static mutex_t blocking_extension_mutex;
382static bool_Bool blocking_extension_mutex_initialized = false0;
383static lbm_uint blocking_extension_timeout_us = 0;
384static bool_Bool blocking_extension_timeout = false0;
385
386static uint32_t is_atomic = 0;
387
388/* Process queues */
389static eval_context_queue_t blocked = {NULL((void*)0), NULL((void*)0)};
390static eval_context_queue_t queue = {NULL((void*)0), NULL((void*)0)};
391
392/* one mutex for all queue operations */
393mutex_t qmutex;
394bool_Bool qmutex_initialized = false0;
395
396
397// MODES
398static volatile bool_Bool lbm_verbose = false0;
399
400void lbm_toggle_verbose(void) {
401 lbm_verbose = !lbm_verbose;
402}
403
404void lbm_set_verbose(bool_Bool verbose) {
405 lbm_verbose = verbose;
406}
407
408lbm_cid lbm_get_current_cid(void) {
409 if (ctx_running)
410 return ctx_running->id;
411 else
412 return -1;
413}
414
415eval_context_t *lbm_get_current_context(void) {
416 return ctx_running;
417}
418
419/****************************************************/
420/* Utilities used locally in this file */
421
422static lbm_value cons_with_gc(lbm_value head, lbm_value tail, lbm_value remember) {
423#ifdef LBM_ALWAYS_GC
424 lbm_value roots[3] = {head, tail, remember};
425 lbm_gc_mark_roots(roots, 3);
426 gc();
427 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
428 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
429 if (lbm_is_symbol_merror(res)) {
430 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
431 }
432 return res;
433#else
434 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
435 if (lbm_is_symbol_merror(res)) {
436 lbm_value roots[3] = {head, tail, remember};
437 lbm_gc_mark_roots(roots,3);
438 gc();
439 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
440 if (lbm_is_symbol_merror(res)) {
441 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
442 }
443 }
444 return res;
445#endif
446}
447
448static lbm_uint *get_stack_ptr(eval_context_t *ctx, unsigned int n) {
449 if (n <= ctx->K.sp) {
450 lbm_uint index = ctx->K.sp - n;
451 return &ctx->K.data[index];
452 }
453 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
454 return 0; // dead code cannot be reached, but C compiler doesn't realise.
455}
456
457// pop_stack_ptr is safe when no GC is performed and
458// the values of the stack will be dropped.
459static lbm_uint *pop_stack_ptr(eval_context_t *ctx, unsigned int n) {
460 if (n <= ctx->K.sp) {
461 ctx->K.sp -= n;
462 return &ctx->K.data[ctx->K.sp];
463 }
464 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
465 return 0; // dead code cannot be reached, but C compiler doesn't realise.
466}
467
468static inline lbm_uint *stack_reserve(eval_context_t *ctx, unsigned int n) {
469 if (ctx->K.sp + n < ctx->K.size) {
470 lbm_uint *ptr = &ctx->K.data[ctx->K.sp];
471 ctx->K.sp += n;
472 return ptr;
473 }
474 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
475 return 0; // dead code cannot be reached, but C compiler doesn't realise.
476}
477
478static void handle_flash_status(lbm_flash_status s) {
479 if ( s == LBM_FLASH_FULL) {
480 lbm_set_error_reason((char*)lbm_error_str_flash_full);
481 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
482 }
483 if (s == LBM_FLASH_WRITE_ERROR) {
484 lbm_set_error_reason((char*)lbm_error_str_flash_error);
485 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
486 }
487}
488
489static void lift_array_flash(lbm_value flash_cell, bool_Bool bytearray, char *data, lbm_uint num_elt) {
490
491 lbm_array_header_t flash_array_header;
492 flash_array_header.size = num_elt;
493 flash_array_header.data = (lbm_uint*)data;
494 lbm_uint flash_array_header_ptr;
495 handle_flash_status(lbm_write_const_raw((lbm_uint*)&flash_array_header,
496 sizeof(lbm_array_header_t) / sizeof(lbm_uint),
497 &flash_array_header_ptr));
498 handle_flash_status(write_const_car(flash_cell, flash_array_header_ptr));
499 lbm_uint t = bytearray ? ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u) : ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u);
500 handle_flash_status(write_const_cdr(flash_cell, t));
501}
502
503static void get_car_and_cdr(lbm_value a, lbm_value *a_car, lbm_value *a_cdr) {
504 if (lbm_is_ptr(a)) {
505 lbm_cons_t *cell = lbm_ref_cell(a);
506 *a_car = cell->car;
507 *a_cdr = cell->cdr;
508 } else if (lbm_is_symbol_nil(a)) {
509 *a_car = *a_cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
510 } else {
511 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
512 }
513}
514
515/* car cdr caar cadr replacements that are evaluator safe. */
516static lbm_value get_car(lbm_value a) {
517 if (lbm_is_ptr(a)) {
2
←
Assuming the condition is false
→
3
←
Taking false branch
→
518 lbm_cons_t *cell = lbm_ref_cell(a);
519 return cell->car;
520 } else if (lbm_is_symbol_nil(a)) {
4
←
Calling 'lbm_is_symbol_nil'
→
7
←
Returning from 'lbm_is_symbol_nil'
→
8
←
Taking true branch
→
521 return a;
9
←
Returning zero (loaded from 'a')
→
522 }
523 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
524 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
525}
526
527static lbm_value get_cdr(lbm_value a) {
528 if (lbm_is_ptr(a)) {
529 lbm_cons_t *cell = lbm_ref_cell(a);
530 return cell->cdr;
531 } else if (lbm_is_symbol_nil(a)) {
532 return a;
533 }
534 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
535 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
536}
537
538static lbm_value get_cadr(lbm_value a) {
539 if (lbm_is_ptr(a)) {
540 lbm_cons_t *cell = lbm_ref_cell(a);
541 lbm_value tmp = cell->cdr;
542 if (lbm_is_ptr(tmp)) {
543 return lbm_ref_cell(tmp)->car;
544 } else if (lbm_is_symbol_nil(tmp)) {
545 return tmp;
546 }
547 } else if (lbm_is_symbol_nil(a)) {
548 return a;
549 }
550 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
551 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
552}
553
554static lbm_value allocate_closure(lbm_value params, lbm_value body, lbm_value env) {
555
556#ifdef LBM_ALWAYS_GC
557 gc();
558 if (lbm_heap_num_free() < 4) {
559 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
560 }
561#else
562 if (lbm_heap_num_free() < 4) {
563 gc();
564 if (lbm_heap_num_free() < 4) {
565 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
566 }
567 }
568#endif
569 // The freelist will always contain just plain heap-cells.
570 // So dec_ptr is sufficient.
571 lbm_value res = lbm_heap_state.freelist;
572 if (lbm_type_of(res) == LBM_TYPE_CONS0x10000000u) {
573 lbm_cons_t *heap = lbm_heap_state.heap;
574 lbm_uint ix = lbm_dec_ptr(res);
575 heap[ix].car = ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u);
576 ix = lbm_dec_ptr(heap[ix].cdr);
577 heap[ix].car = params;
578 ix = lbm_dec_ptr(heap[ix].cdr);
579 heap[ix].car = body;
580 ix = lbm_dec_ptr(heap[ix].cdr);
581 heap[ix].car = env;
582 lbm_heap_state.freelist = heap[ix].cdr;
583 heap[ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
584 lbm_heap_state.num_alloc+=4;
585 } else {
586 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
587 }
588 return res;
589}
590
591// Allocate a binding and attach it to a list (if so desired)
592static lbm_value allocate_binding(lbm_value key, lbm_value val, lbm_value the_cdr) {
593 if (lbm_heap_num_free() < 2) {
594 gc();
595 if (lbm_heap_num_free() < 2) {
596 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
597 }
598 }
599 lbm_cons_t* heap = lbm_heap_state.heap;
600 lbm_value binding_cell = lbm_heap_state.freelist;
601 lbm_uint binding_cell_ix = lbm_dec_ptr(binding_cell);
602 lbm_value list_cell = heap[binding_cell_ix].cdr;
603 lbm_uint list_cell_ix = lbm_dec_ptr(list_cell);
604 lbm_heap_state.freelist = heap[list_cell_ix].cdr;
605 lbm_heap_state.num_alloc += 2;
606 heap[binding_cell_ix].car = key;
607 heap[binding_cell_ix].cdr = val;
608 heap[list_cell_ix].car = binding_cell;
609 heap[list_cell_ix].cdr = the_cdr;
610 return list_cell;
611}
612
613#define CLO_PARAMS0 0
614#define CLO_BODY1 1
615#define CLO_ENV2 2
616#define LOOP_BINDS0 0
617#define LOOP_COND1 1
618#define LOOP_BODY2 2
619
620// (a b c) -> [a b c]
621static lbm_value extract_n(lbm_value curr, lbm_value *res, unsigned int n) {
622 for (unsigned int i = 0; i < n; i ++) {
623 if (lbm_is_ptr(curr)) {
624 lbm_cons_t *cell = lbm_ref_cell(curr);
625 res[i] = cell->car;
626 curr = cell->cdr;
627 } else {
628 res[i] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
629 }
630 }
631 return curr; // Rest of list is returned here.
632}
633
634static void call_fundamental(lbm_uint fundamental, lbm_value *args, lbm_uint arg_count, eval_context_t *ctx) {
635 lbm_value res;
636 res = fundamental_table[fundamental](args, arg_count, ctx);
637 if (lbm_is_error(res)) {
638 if (lbm_is_symbol_merror(res)) {
639 gc();
640 res = fundamental_table[fundamental](args, arg_count, ctx);
641 }
642 if (lbm_is_error(res)) {
643 error_at_ctx(res, lbm_enc_sym(FUNDAMENTAL_SYMBOLS_START0x20000 | fundamental));
644 }
645 }
646 lbm_stack_drop(&ctx->K, arg_count+1);
647 ctx->app_cont = true1;
648 ctx->r = res;
649}
650
651// block_current_ctx blocks a context until it is
652// woken up externally or a timeout period of time passes.
653static void block_current_ctx(uint32_t state, lbm_uint sleep_us, bool_Bool do_cont) {
654 ctx_running->timestamp = timestamp_us_callback();
655 ctx_running->sleep_us = sleep_us;
656 ctx_running->state = state;
657 ctx_running->app_cont = do_cont;
658 enqueue_ctx(&blocked, ctx_running);
659 ctx_running = NULL((void*)0);
660}
661
662lbm_flash_status lbm_write_const_array_padded(uint8_t *data, lbm_uint n, lbm_uint *res) {
663 lbm_uint full_words = n / sizeof(lbm_uint);
664 lbm_uint n_mod = n % sizeof(lbm_uint);
665
666 if (n_mod == 0) { // perfect fit.
667 return lbm_write_const_raw((lbm_uint*)data, full_words, res);
668 } else {
669 lbm_uint last_word = 0;
670 memcpy(&last_word, &data[full_words * sizeof(lbm_uint)], n_mod);
671 if (full_words >= 1) {
672 lbm_flash_status s = lbm_write_const_raw((lbm_uint*)data, full_words, res);
673 if ( s == LBM_FLASH_WRITE_OK) {
674 lbm_uint dummy;
675 s = lbm_write_const_raw(&last_word, 1, &dummy);
676 }
677 return s;
678 } else {
679 return lbm_write_const_raw(&last_word, 1, res);
680 }
681 }
682}
683
684/****************************************************/
685/* Error message creation */
686
687#define ERROR_MESSAGE_BUFFER_SIZE_BYTES256 256
688
689void print_environments(char *buf, unsigned int size) {
690
691 lbm_value curr_l = ctx_running->curr_env;
692 printf_callback("\tCurrent local environment:\n");
693 while (lbm_type_of(curr_l) == LBM_TYPE_CONS0x10000000u) {
694 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_l));
695 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_l)));
696 printf_callback("\t%s = %s\n", buf, buf+(size/2));
697 curr_l = lbm_cdr(curr_l);
698 }
699 printf_callback("\n\n");
700 printf_callback("\tCurrent global environment:\n");
701 lbm_value *glob_env = lbm_get_global_env();
702
703 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
704 lbm_value curr_g = glob_env[i];;
705 while (lbm_type_of(curr_g) == LBM_TYPE_CONS0x10000000u) {
706
707 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_g));
708 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_g)));
709 printf_callback("\t%s = %s\n", buf, buf+(size/2));
710 curr_g = lbm_cdr(curr_g);
711 }
712 }
713}
714
715void print_error_message(lbm_value error, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int col, lbm_int row0, lbm_int row1) {
716 if (!printf_callback) return;
717
718 /* try to allocate a lbm_print_value buffer on the lbm_memory */
719 char *buf = lbm_malloc_reserve(ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
720 if (!buf) {
721 printf_callback("Error: Not enough free memory to create a human readable error message\n");
722 return;
723 }
724
725 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, error);
726 printf_callback( "*** Error: %s\n", buf);
727 if (has_at) {
728 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, at);
729 printf_callback("*** In: %s\n",buf);
730 if (lbm_error_has_suspect) {
731 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, lbm_error_suspect);
732 lbm_error_has_suspect = false0;
733 printf_callback("*** At: %s\n", buf);
734 } else {
735 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
736 printf_callback("*** After: %s\n",buf);
737 }
738 } else {
739 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
740 printf_callback("*** Near: %s\n",buf);
741 }
742
743 printf_callback("\n");
744
745 if (lbm_is_symbol(error) &&
746 error == ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u)) {
747 printf_callback("*** Line: %u\n", row);
748 printf_callback("*** Column: %u\n", col);
749 } else if (row0 != -1 || row1 != -1 ) {
750 printf_callback("*** Between rows: (-1 unknown) \n");
751 printf_callback("*** Start: %d\n", (int32_t)row0);
752 printf_callback("*** End: %d\n", (int32_t)row1);
753 }
754
755 printf_callback("\n");
756
757 if (ctx_running->error_reason) {
758 printf_callback("Reason:\n %s\n\n", ctx_running->error_reason);
759 }
760 if (lbm_verbose) {
761 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
762 printf_callback(" In context: %d\n", ctx_running->id);
763 printf_callback(" Current intermediate result: %s\n\n", buf);
764
765 print_environments(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
766 printf_callback("\n\n");
767
768 printf_callback(" Stack:\n");
769 for (unsigned int i = 0; i < ctx_running->K.sp; i ++) {
770 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->K.data[i]);
771 printf_callback(" %s\n", buf);
772 }
773 }
774 lbm_free(buf);
775}
776
777/****************************************************/
778/* Tokenizing and parsing */
779
780bool_Bool create_string_channel(char *str, lbm_value *res) {
781
782 lbm_char_channel_t *chan = NULL((void*)0);
783 lbm_string_channel_state_t *st = NULL((void*)0);
784
785 st = (lbm_string_channel_state_t*)lbm_memory_allocate(sizeof(lbm_string_channel_state_t) / sizeof(lbm_uint) +1);
786 if (st == NULL((void*)0)) {
787 return false0;
788 }
789 chan = (lbm_char_channel_t*)lbm_memory_allocate(sizeof(lbm_char_channel_t) / sizeof(lbm_uint) + 1);
790 if (chan == NULL((void*)0)) {
791 lbm_memory_free((lbm_uint*)st);
792 return false0;
793 }
794
795 lbm_create_string_char_channel(st, chan, str);
796 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
797 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
798 lbm_memory_free((lbm_uint*)st);
799 lbm_memory_free((lbm_uint*)chan);
800 return false0;
801 }
802
803 *res = cell;
804 return true1;
805}
806
807bool_Bool lift_char_channel(lbm_char_channel_t *chan , lbm_value *res) {
808 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
809 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
810 return false0;
811 }
812 *res = cell;
813 return true1;
814}
815
816
817/****************************************************/
818/* Queue functions */
819
820static void queue_iterator_nm(eval_context_queue_t *q, ctx_fun f, void *arg1, void *arg2) {
821 eval_context_t *curr;
822 curr = q->first;
823
824 while (curr != NULL((void*)0)) {
825 f(curr, arg1, arg2);
826 curr = curr->next;
827 }
828}
829
830void lbm_running_iterator(ctx_fun f, void *arg1, void *arg2){
831 mutex_lock(&qmutex);
832 queue_iterator_nm(&queue, f, arg1, arg2);
833 mutex_unlock(&qmutex);
834}
835
836void lbm_blocked_iterator(ctx_fun f, void *arg1, void *arg2){
837 mutex_lock(&qmutex);
838 queue_iterator_nm(&blocked, f, arg1, arg2);
839 mutex_unlock(&qmutex);
840}
841
842static void enqueue_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
843 if (q->last == NULL((void*)0)) {
844 ctx->prev = NULL((void*)0);
845 ctx->next = NULL((void*)0);
846 q->first = ctx;
847 q->last = ctx;
848 } else {
849 ctx->prev = q->last;
850 ctx->next = NULL((void*)0);
851 q->last->next = ctx;
852 q->last = ctx;
853 }
854}
855
856static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx) {
857 mutex_lock(&qmutex);
858 enqueue_ctx_nm(q,ctx);
859 mutex_unlock(&qmutex);
860}
861
862static eval_context_t *lookup_ctx_nm(eval_context_queue_t *q, lbm_cid cid) {
863 eval_context_t *curr;
864 curr = q->first;
865 while (curr != NULL((void*)0)) {
866 if (curr->id == cid) {
867 return curr;
868 }
869 curr = curr->next;
870 }
871 return NULL((void*)0);
872}
873
874static bool_Bool drop_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
875
876 bool_Bool res = false0;
877 if (q->first == NULL((void*)0) || q->last == NULL((void*)0)) {
878 if (!(q->last == NULL((void*)0) && q->first == NULL((void*)0))) {
879 /* error state that should not happen */
880 return res;
881 }
882 /* Queue is empty */
883 return res;
884 }
885
886 eval_context_t *curr = q->first;
887 while (curr) {
888 if (curr->id == ctx->id) {
889 res = true1;
890 eval_context_t *tmp = curr->next;
891 if (curr->prev == NULL((void*)0)) {
892 if (curr->next == NULL((void*)0)) {
893 q->last = NULL((void*)0);
894 q->first = NULL((void*)0);
895 } else {
896 q->first = tmp;
897 tmp->prev = NULL((void*)0);
898 }
899 } else { /* curr->prev != NULL */
900 if (curr->next == NULL((void*)0)) {
901 q->last = curr->prev;
902 q->last->next = NULL((void*)0);
903 } else {
904 curr->prev->next = tmp;
905 tmp->prev = curr->prev;
906 }
907 }
908 break;
909 }
910 curr = curr->next;
911 }
912 return res;
913}
914
915/* End execution of the running context. */
916static void finish_ctx(void) {
917
918 if (!ctx_running) {
919 return;
920 }
921 /* Drop the continuation stack immediately to free up lbm_memory */
922 lbm_stack_free(&ctx_running->K);
923 ctx_done_callback(ctx_running);
924 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->name)) {
925 lbm_free(ctx_running->name);
926 }
927 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->error_reason)) {
928 lbm_memory_free((lbm_uint*)ctx_running->error_reason);
929 }
930 lbm_memory_free((lbm_uint*)ctx_running->mailbox);
931 lbm_memory_free((lbm_uint*)ctx_running);
932 ctx_running = NULL((void*)0);
933}
934
935static void context_exists(eval_context_t *ctx, void *cid, void *b) {
936 if (ctx->id == *(lbm_cid*)cid) {
937 *(bool_Bool*)b = true1;
938 }
939}
940
941bool_Bool lbm_wait_ctx(lbm_cid cid, lbm_uint timeout_ms) {
942
943 bool_Bool exists;
944 uint32_t i = 0;
945
946 do {
947 exists = false0;
948 lbm_blocked_iterator(context_exists, &cid, &exists);
949 lbm_running_iterator(context_exists, &cid, &exists);
950
951 if (ctx_running &&
952 ctx_running->id == cid) {
953 exists = true1;
954 }
955
956 if (exists) {
957 if (usleep_callback) {
958 usleep_callback(1000);
959 }
960 if (timeout_ms > 0) i ++;
961 }
962 } while (exists && i < timeout_ms);
963
964 if (exists) return false0;
965 return true1;
966}
967
968void lbm_set_error_suspect(lbm_value suspect) {
969 lbm_error_suspect = suspect;
970 lbm_error_has_suspect = true1;
971}
972
973void lbm_set_error_reason(char *error_str) {
974 if (ctx_running != NULL((void*)0)) {
975 ctx_running->error_reason = error_str;
976 }
977}
978
979// Not possible to CONS_WITH_GC in error_ctx_base (potential loop)
980static void error_ctx_base(lbm_value err_val, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int column) {
981
982 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
983 if (lbm_heap_num_free() < 3) {
984 gc();
985 }
986
987 if (lbm_heap_num_free() >= 3) {
988 lbm_value msg = lbm_cons(err_val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
989 msg = lbm_cons(lbm_enc_i(ctx_running->id), msg);
990 msg = lbm_cons(ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u), msg);
991 if (!lbm_is_symbol_merror(msg)) {
992 lbm_find_receiver_and_send(ctx_running->parent, msg);
993 goto error_ctx_base_done;
994 }
995 }
996 }
997 if ((ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10) &&
998 (err_val != ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u))) {
999 lbm_uint v;
1000 while (ctx_running->K.sp > 0) {
1001 lbm_pop(&ctx_running->K, &v);
1002 if (v == EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u)) {
1003 lbm_value *sptr = get_stack_ptr(ctx_running, 2);
1004 lbm_set_car(sptr[0], ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
1005 stack_reserve(ctx_running, 1)[0] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1006 ctx_running->app_cont = true1;
1007 ctx_running->r = err_val;
1008 longjmp(error_jmp_buf, 1);
1009 }
1010 }
1011 err_val = ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u);
1012 }
1013 print_error_message(err_val,
1014 has_at,
1015 at,
1016 row,
1017 column,
1018 ctx_running->row0,
1019 ctx_running->row1);
1020 error_ctx_base_done:
1021 ctx_running->r = err_val;
1022 finish_ctx();
1023 longjmp(error_jmp_buf, 1);
1024}
1025
1026static void error_at_ctx(lbm_value err_val, lbm_value at) {
1027 error_ctx_base(err_val, true1, at, 0, 0);
1028}
1029
1030static void error_ctx(lbm_value err_val) {
1031 error_ctx_base(err_val, false0, 0, 0, 0);
1032}
1033
1034static void read_error_ctx(unsigned int row, unsigned int column) {
1035 error_ctx_base(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u), false0, 0, row, column);
1036}
1037
1038void lbm_critical_error(void) {
1039 longjmp(critical_error_jmp_buf, 1);
1040}
1041
1042// successfully finish a context
1043static void ok_ctx(void) {
1044 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
1045 lbm_value msg;
1046 WITH_GC(msg, lbm_heap_allocate_list_init(3,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1047 ENC_SYM_EXIT_OK,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1048 lbm_enc_i(ctx_running->id),(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1049 ctx_running->r))(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
1050 lbm_find_receiver_and_send(ctx_running->parent, msg);
1051 }
1052 finish_ctx();
1053}
1054
1055static eval_context_t *dequeue_ctx_nm(eval_context_queue_t *q) {
1056 if (q->last == NULL((void*)0)) {
1057 return NULL((void*)0);
1058 }
1059 // q->first should only be NULL if q->last is.
1060 eval_context_t *res = q->first;
1061
1062 if (q->first == q->last) { // One thing in queue
1063 q->first = NULL((void*)0);
1064 q->last = NULL((void*)0);
1065 } else {
1066 q->first = q->first->next;
1067 q->first->prev = NULL((void*)0);
1068 }
1069 res->prev = NULL((void*)0);
1070 res->next = NULL((void*)0);
1071 return res;
1072}
1073
1074static void wake_up_ctxs_nm(void) {
1075 lbm_uint t_now;
1076
1077 if (timestamp_us_callback) {
1078 t_now = timestamp_us_callback();
1079 } else {
1080 t_now = 0;
1081 }
1082
1083 eval_context_queue_t *q = &blocked;
1084 eval_context_t *curr = q->first;
1085
1086 while (curr != NULL((void*)0)) {
1087 lbm_uint t_diff;
1088 eval_context_t *next = curr->next;
1089 if (curr->state != LBM_THREAD_STATE_BLOCKED(uint32_t)1) {
1090 if ( curr->timestamp > t_now) {
1091 /* There was an overflow on the counter */
1092#ifndef LBM64
1093 t_diff = (0xFFFFFFFF - curr->timestamp) + t_now;
1094#else
1095 t_diff = (0xFFFFFFFFFFFFFFFF - curr->timestamp) + t_now;
1096#endif
1097 } else {
1098 t_diff = t_now - curr->timestamp;
1099 }
1100
1101 if (t_diff >= curr->sleep_us) {
1102 eval_context_t *wake_ctx = curr;
1103 if (curr == q->last) {
1104 if (curr->prev) {
1105 q->last = curr->prev;
1106 q->last->next = NULL((void*)0);
1107 } else {
1108 q->first = NULL((void*)0);
1109 q->last = NULL((void*)0);
1110 }
1111 } else if (curr->prev == NULL((void*)0)) {
1112 q->first = curr->next;
1113 q->first->prev = NULL((void*)0);
1114 } else {
1115 curr->prev->next = curr->next;
1116 if (curr->next) {
1117 curr->next->prev = curr->prev;
1118 }
1119 }
1120 wake_ctx->next = NULL((void*)0);
1121 wake_ctx->prev = NULL((void*)0);
1122 if (curr->state == LBM_THREAD_STATE_TIMEOUT(uint32_t)2) {
1123 mailbox_add_mail(wake_ctx, ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u));
1124 wake_ctx->r = ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u);
1125 }
1126 wake_ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1127 enqueue_ctx_nm(&queue, wake_ctx);
1128 }
1129 }
1130 curr = next;
1131 }
1132}
1133
1134static void yield_ctx(lbm_uint sleep_us) {
1135 if (timestamp_us_callback) {
1136 ctx_running->timestamp = timestamp_us_callback();
1137 ctx_running->sleep_us = sleep_us;
1138 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1139 } else {
1140 ctx_running->timestamp = 0;
1141 ctx_running->sleep_us = 0;
1142 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1143 }
1144 ctx_running->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1145 ctx_running->app_cont = true1;
1146 enqueue_ctx(&blocked,ctx_running);
1147 ctx_running = NULL((void*)0);
1148}
1149
1150static lbm_cid lbm_create_ctx_parent(lbm_value program, lbm_value env, lbm_uint stack_size, lbm_cid parent, uint32_t context_flags, char *name) {
1151
1152 if (!lbm_is_cons(program)) return -1;
1153
1154 eval_context_t *ctx = NULL((void*)0);
1155
1156 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1157 if (ctx == NULL((void*)0)) {
1158 lbm_uint roots[2] = {program, env};
1159 lbm_gc_mark_roots(roots, 2);
1160 gc();
1161 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1162 }
1163 if (ctx == NULL((void*)0)) return -1;
1164
1165 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1166 lbm_uint roots[2] = {program, env};
1167 lbm_gc_mark_roots(roots, 2);
1168 gc();
1169 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1170 lbm_memory_free((lbm_uint*)ctx);
1171 return -1;
1172 }
1173 }
1174
1175 lbm_value *mailbox = NULL((void*)0);
1176 mailbox = (lbm_value*)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1177 if (mailbox == NULL((void*)0)) {
1178 lbm_value roots[2] = {program, env};
1179 lbm_gc_mark_roots(roots,2);
1180 gc();
1181 mailbox = (lbm_value *)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1182 }
1183 if (mailbox == NULL((void*)0)) {
1184 lbm_stack_free(&ctx->K);
1185 lbm_memory_free((lbm_uint*)ctx);
1186 return -1;
1187 }
1188
1189 // TODO: Limit names to 19 chars + 1 char for 0? (or something similar).
1190 if (name) {
1191 lbm_uint name_len = strlen(name) + 1;
1192 ctx->name = lbm_malloc(strlen(name) + 1);
1193 if (ctx->name == NULL((void*)0)) {
1194 lbm_value roots[2] = {program, env};
1195 lbm_gc_mark_roots(roots, 2);
1196 gc();
1197 ctx->name = lbm_malloc(strlen(name) + 1);
1198 }
1199 if (ctx->name == NULL((void*)0)) {
1200 lbm_stack_free(&ctx->K);
1201 lbm_memory_free((lbm_uint*)mailbox);
1202 lbm_memory_free((lbm_uint*)ctx);
1203 return -1;
1204 }
1205 memcpy(ctx->name, name, name_len+1);
1206 } else {
1207 ctx->name = NULL((void*)0);
1208 }
1209
1210 lbm_int cid = lbm_memory_address_to_ix((lbm_uint*)ctx);
1211
1212 ctx->program = lbm_cdr(program);
1213 ctx->curr_exp = lbm_car(program);
1214 ctx->curr_env = env;
1215 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1216 ctx->error_reason = NULL((void*)0);
1217 ctx->mailbox = mailbox;
1218 ctx->mailbox_size = EVAL_CPS_DEFAULT_MAILBOX_SIZE10;
1219 ctx->flags = context_flags;
1220 ctx->num_mail = 0;
1221 ctx->app_cont = false0;
1222 ctx->timestamp = 0;
1223 ctx->sleep_us = 0;
1224 ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1225 ctx->prev = NULL((void*)0);
1226 ctx->next = NULL((void*)0);
1227
1228 ctx->row0 = -1;
1229 ctx->row1 = -1;
1230
1231 ctx->id = cid;
1232 ctx->parent = parent;
1233
1234 if (!lbm_push(&ctx->K, DONE(((0) << 2) | 0xF8000001u))) {
1235 lbm_memory_free((lbm_uint*)ctx->mailbox);
1236 lbm_stack_free(&ctx->K);
1237 lbm_memory_free((lbm_uint*)ctx);
1238 return -1;
1239 }
1240
1241 enqueue_ctx(&queue,ctx);
1242
1243 return ctx->id;
1244}
1245
1246lbm_cid lbm_create_ctx(lbm_value program, lbm_value env, lbm_uint stack_size, char *name) {
1247 // Creates a parentless context.
1248 return lbm_create_ctx_parent(program,
1249 env,
1250 stack_size,
1251 -1,
1252 EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00,
1253 name);
1254}
1255
1256bool_Bool lbm_mailbox_change_size(eval_context_t *ctx, lbm_uint new_size) {
1257
1258 lbm_value *mailbox = NULL((void*)0);
1259 mailbox = (lbm_value*)lbm_memory_allocate(new_size);
1260 if (mailbox == NULL((void*)0)) {
1261 gc();
1262 mailbox = (lbm_value *)lbm_memory_allocate(new_size);
1263 }
1264 if (mailbox == NULL((void*)0)) {
1265 return false0;
1266 }
1267
1268 for (lbm_uint i = 0; i < ctx->num_mail; i ++ ) {
1269 mailbox[i] = ctx->mailbox[i];
1270 }
1271 lbm_memory_free(ctx->mailbox);
1272 ctx->mailbox = mailbox;
1273 ctx->mailbox_size = (uint32_t)new_size;
1274 return true1;
1275}
1276
1277static void mailbox_remove_mail(eval_context_t *ctx, lbm_uint ix) {
1278
1279 for (lbm_uint i = ix; i < ctx->num_mail-1; i ++) {
1280 ctx->mailbox[i] = ctx->mailbox[i+1];
1281 }
1282 ctx->num_mail --;
1283}
1284
1285static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail) {
1286
1287 if (ctx->num_mail >= ctx->mailbox_size) {
1288 mailbox_remove_mail(ctx, 0);
1289 }
1290
1291 ctx->mailbox[ctx->num_mail] = mail;
1292 ctx->num_mail ++;
1293 return true1;
1294}
1295
1296/* Advance execution to the next expression in the program */
1297static void advance_ctx(eval_context_t *ctx) {
1298 if (lbm_is_cons(ctx->program)) {
1299 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);;
1300 get_car_and_cdr(ctx->program, &ctx->curr_exp, &ctx->program);
1301 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1302 } else {
1303 if (ctx_running == ctx) { // This should always be the case because of odd historical reasons.
1304 ok_ctx();
1305 }
1306 }
1307}
1308
1309bool_Bool lbm_unblock_ctx(lbm_cid cid, lbm_flat_value_t *fv) {
1310 return event_internal(LBM_EVENT_UNBLOCK_CTX, (lbm_uint)cid, (lbm_uint)fv->buf, fv->buf_size);
1311}
1312
1313bool_Bool lbm_unblock_ctx_r(lbm_cid cid) {
1314 mutex_lock(&blocking_extension_mutex);
1315 bool_Bool r = false0;
1316 eval_context_t *found = NULL((void*)0);
1317 mutex_lock(&qmutex);
1318 found = lookup_ctx_nm(&blocked, cid);
1319 if (found) {
1320 drop_ctx_nm(&blocked,found);
1321 enqueue_ctx_nm(&queue,found);
1322 r = true1;
1323 }
1324 mutex_unlock(&qmutex);
1325 mutex_unlock(&blocking_extension_mutex);
1326 return r;
1327}
1328
1329// unblock unboxed is also safe for rmbr:ed things.
1330bool_Bool lbm_unblock_ctx_unboxed(lbm_cid cid, lbm_value unboxed) {
1331 mutex_lock(&blocking_extension_mutex);
1332 bool_Bool r = false0;
1333 eval_context_t *found = NULL((void*)0);
1334 mutex_lock(&qmutex);
1335 found = lookup_ctx_nm(&blocked, cid);
1336 if (found) {
1337 drop_ctx_nm(&blocked,found);
1338 found->r = unboxed;
1339 if (lbm_is_error(unboxed)) {
1340 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
1341 found->app_cont = true1;
1342 }
1343 enqueue_ctx_nm(&queue,found);
1344 r = true1;
1345 }
1346 mutex_unlock(&qmutex);
1347 mutex_unlock(&blocking_extension_mutex);
1348 return r;
1349}
1350
1351static bool_Bool lbm_block_ctx_base(bool_Bool timeout, float t_s) {
1352 mutex_lock(&blocking_extension_mutex);
1353 blocking_extension = true1;
1354 if (timeout) {
1355 blocking_extension_timeout_us = S_TO_US(t_s)(lbm_uint)((t_s) * 1000000);
1356 blocking_extension_timeout = true1;
1357 } else {
1358 blocking_extension_timeout = false0;
1359 }
1360 return true1;
1361}
1362
1363void lbm_block_ctx_from_extension_timeout(float s) {
1364 lbm_block_ctx_base(true1, s);
1365}
1366
1367void lbm_block_ctx_from_extension(void) {
1368 lbm_block_ctx_base(false0, 0);
1369}
1370
1371// todo: May need to pop rmbrs from stack, if present.
1372// Suspect that the letting the discard cont run is really not a problem.
1373// Either way will be quite confusing what happens to allocated things when undoing block.
1374void lbm_undo_block_ctx_from_extension(void) {
1375 blocking_extension = false0;
1376 blocking_extension_timeout_us = 0;
1377 blocking_extension_timeout = false0;
1378 mutex_unlock(&blocking_extension_mutex);
1379}
1380
1381lbm_value lbm_find_receiver_and_send(lbm_cid cid, lbm_value msg) {
1382 mutex_lock(&qmutex);
1383 eval_context_t *found = NULL((void*)0);
1384 bool_Bool found_blocked = false0;
1385
1386 found = lookup_ctx_nm(&blocked, cid);
1387 if (found) found_blocked = true1;
1388
1389 if (found == NULL((void*)0)) {
1390 found = lookup_ctx_nm(&queue, cid);
1391 }
1392
1393 if (found) {
1394 if (!mailbox_add_mail(found, msg)) {
1395 mutex_unlock(&qmutex);
1396 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1397 }
1398
1399 if (found_blocked){
1400 drop_ctx_nm(&blocked,found);
1401 enqueue_ctx_nm(&queue,found);
1402 }
1403 mutex_unlock(&qmutex);
1404 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1405 }
1406
1407 /* check the current context */
1408 if (ctx_running && ctx_running->id == cid) {
1409 if (!mailbox_add_mail(ctx_running, msg)) {
1410 mutex_unlock(&qmutex);
1411 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1412 }
1413 mutex_unlock(&qmutex);
1414 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1415 }
1416 mutex_unlock(&qmutex);
1417 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1418}
1419
1420/* Pattern matching is currently implemented as a recursive
1421 function and make use of stack relative to the size of
1422 expressions that are being matched. */
1423static bool_Bool match(lbm_value p, lbm_value e, lbm_value *env, bool_Bool *gc) {
1424
1425 lbm_value binding;
1426
1427 if (lbm_is_match_binder(p)) {
1428 lbm_value var = get_cadr(p);
1429 lbm_value bindertype = get_car(p);
1430
1431 if (!lbm_is_symbol(var)) return false0;
1432
1433 switch (bindertype) {
1434 case ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u):
1435 if ( var == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) {
1436 return true1;
1437 }
1438 break;
1439 default: /* this should be an error case */
1440 return false0;
1441 }
1442 binding = lbm_cons(var, e);
1443 if ( lbm_type_of(binding) == LBM_TYPE_SYMBOL0x00000000u ) {
1444 *gc = true1;
1445 return false0;
1446 }
1447 *env = lbm_cons(binding, *env);
1448 if ( lbm_type_of(*env) == LBM_TYPE_SYMBOL0x00000000u ) {
1449 *gc = true1;
1450 return false0;
1451 }
1452 return true1;
1453 }
1454
1455 if (lbm_is_symbol(p)) {
1456 if (p == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return true1;
1457 return (p == e);
1458 }
1459 if (lbm_is_cons(p) &&
1460 lbm_is_cons(e) ) {
1461
1462 lbm_value headp, tailp;
1463 lbm_value heade, taile;
1464 get_car_and_cdr(p, &headp, &tailp);
1465 get_car_and_cdr(e, &heade, &taile); // Static analysis warns, but execution does not
1466 // past this point unless head and tail get initialized.
1467 if (!match(headp, heade, env, gc)) {
1468 return false0;
1469 }
1470 return match (tailp, taile, env, gc);
1471 }
1472 return struct_eq(p, e);
1473}
1474
1475// Find match is not very picky about syntax.
1476// A completely malformed recv form is most likely to
1477// just return no_match.
1478static int find_match(lbm_value plist, lbm_value *earr, lbm_uint num, lbm_value *e, lbm_value *env) {
1479
1480 // A pattern list is a list of pattern, expression lists.
1481 // ( (p1 e1) (p2 e2) ... (pn en))
1482 lbm_value curr_p = plist;
1483 int n = 0;
1484 bool_Bool gc = false0;
1485 for (int i = 0; i < (int)num; i ++ ) {
1486 lbm_value curr_e = earr[i];
1487 while (!lbm_is_symbol_nil(curr_p)) {
1488 lbm_value me = get_car(curr_p);
1489 if (match(get_car(me), curr_e, env, &gc)) {
1490 if (gc) return FM_NEED_GC-1;
1491 *e = get_cadr(me);
1492
1493 if (!lbm_is_symbol_nil(get_cadr(get_cdr(me)))) {
1494 return FM_PATTERN_ERROR-3;
1495 }
1496 return n;
1497 }
1498 curr_p = get_cdr(curr_p);
1499 }
1500 curr_p = plist; /* search all patterns against next exp */
1501 n ++;
1502 }
1503
1504 return FM_NO_MATCH-2;
1505}
1506
1507/****************************************************/
1508/* Garbage collection */
1509
1510static void mark_context(eval_context_t *ctx, void *arg1, void *arg2) {
1511 (void) arg1;
1512 (void) arg2;
1513 lbm_value roots[3] = {ctx->curr_exp, ctx->program, ctx->r };
1514 lbm_gc_mark_env(ctx->curr_env);
1515 lbm_gc_mark_roots(roots, 3);
1516 lbm_gc_mark_roots(ctx->mailbox, ctx->num_mail);
1517 lbm_gc_mark_aux(ctx->K.data, ctx->K.sp);
1518}
1519
1520static int gc(void) {
1521 if (ctx_running) {
1522 ctx_running->state = ctx_running->state | LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1523 }
1524
1525 gc_requested = false0;
1526 lbm_gc_state_inc();
1527
1528 // The freelist should generally be NIL when GC runs.
1529 lbm_nil_freelist();
1530 lbm_value *env = lbm_get_global_env();
1531 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
1532 lbm_gc_mark_env(env[i]);
1533 }
1534
1535 mutex_lock(&qmutex); // Lock the queues.
1536 // Any concurrent messing with the queues
1537 // while doing GC cannot possibly be good.
1538 queue_iterator_nm(&queue, mark_context, NULL((void*)0), NULL((void*)0));
1539 queue_iterator_nm(&blocked, mark_context, NULL((void*)0), NULL((void*)0));
1540
1541 if (ctx_running) {
1542 mark_context(ctx_running, NULL((void*)0), NULL((void*)0));
1543 }
1544 mutex_unlock(&qmutex);
1545
1546#ifdef VISUALIZE_HEAP
1547 heap_vis_gen_image();
1548#endif
1549
1550 int r = lbm_gc_sweep_phase();
1551 lbm_heap_new_freelist_length();
1552
1553 if (ctx_running) {
1554 ctx_running->state = ctx_running->state & ~LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1555 }
1556 return r;
1557}
1558
1559int lbm_perform_gc(void) {
1560 return gc();
1561}
1562
1563/****************************************************/
1564/* Evaluation functions */
1565
1566
1567static void eval_symbol(eval_context_t *ctx) {
1568 lbm_uint s = lbm_dec_sym(ctx->curr_exp);
1569 if (s >= RUNTIME_SYMBOLS_START0x40000) {
1570 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1571 if (lbm_env_lookup_b(&res, ctx->curr_exp, ctx->curr_env) ||
1572 lbm_global_env_lookup(&res, ctx->curr_exp)) {
1573 ctx->r = res;
1574 ctx->app_cont = true1;
1575 return;
1576 }
1577 // Dynamic load attempt
1578 // Only symbols of kind RUNTIME can be dynamically loaded.
1579 const char *sym_str = lbm_get_name_by_symbol(s);
1580 const char *code_str = NULL((void*)0);
1581 if (!dynamic_load_callback(sym_str, &code_str)) {
1582 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), ctx->curr_exp);
1583 }
1584 lbm_value *sptr = stack_reserve(ctx, 3);
1585 sptr[0] = ctx->curr_exp;
1586 sptr[1] = ctx->curr_env;
1587 sptr[2] = RESUME(((12) << 2) | 0xF8000001u);
1588
1589 lbm_value chan;
1590 if (!create_string_channel((char *)code_str, &chan)) {
1591 gc();
1592 if (!create_string_channel((char *)code_str, &chan)) {
1593 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1594 }
1595 }
1596
1597 lbm_value loader;
1598 WITH_GC_RMBR_1(loader, lbm_heap_allocate_list_init(2,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1599 ENC_SYM_READ,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1600 chan), chan)(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} };
1601 lbm_value evaluator;
1602 WITH_GC_RMBR_1(evaluator, lbm_heap_allocate_list_init(2,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1603 ENC_SYM_EVAL,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1604 loader), loader)(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } };
1605 ctx->curr_exp = evaluator;
1606 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // dynamics should be evaluable in empty local env
1607 } else {
1608 //special symbols and extensions can be handled the same way.
1609 ctx->r = ctx->curr_exp;
1610 ctx->app_cont = true1;
1611 }
1612}
1613
1614static void eval_quote(eval_context_t *ctx) {
1615 ctx->r = get_cadr(ctx->curr_exp);
1616 ctx->app_cont = true1;
1617}
1618
1619static void eval_selfevaluating(eval_context_t *ctx) {
1620 ctx->r = ctx->curr_exp;
1621 ctx->app_cont = true1;
1622}
1623
1624static void eval_progn(eval_context_t *ctx) {
1625 lbm_value exps = get_cdr(ctx->curr_exp);
1626
1627 if (lbm_is_cons(exps)) {
1628 lbm_uint *sptr = stack_reserve(ctx, 4);
1629 sptr[0] = ctx->curr_env; // env to restore between expressions in progn
1630 sptr[1] = lbm_enc_u(0); // Has env been copied (needed for progn local bindings)
1631 sptr[3] = PROGN_REST(((4) << 2) | 0xF8000001u);
1632 get_car_and_cdr(exps, &ctx->curr_exp, &sptr[2]);
1633 if (lbm_is_symbol(sptr[2])) /* The only symbol it can be is nil */
1634 lbm_stack_drop(&ctx->K, 4);
1635 } else if (lbm_is_symbol_nil(exps)) {
1636 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1637 ctx->app_cont = true1;
1638 } else {
1639 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1640 }
1641}
1642
1643static void eval_atomic(eval_context_t *ctx) {
1644 if (is_atomic) {
1645 lbm_set_error_reason("Atomic blocks cannot be nested!");
1646 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1647 }
1648 stack_reserve(ctx, 1)[0] = EXIT_ATOMIC(((14) << 2) | 0xF8000001u);
1649 is_atomic ++;
1650 eval_progn(ctx);
1651}
1652
1653/* (call-cc (lambda (k) .... )) */
1654static void eval_callcc(eval_context_t *ctx) {
1655 lbm_value cont_array;
1656 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1657 gc();
1658 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1659 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1660 return; // dead return but static analysis doesn't know :)
1661 }
1662 }
1663 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(cont_array);
1664 memcpy(arr->data, ctx->K.data, ctx->K.sp * sizeof(lbm_uint));
1665
1666 lbm_value acont = cons_with_gc(ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u), cont_array, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1667 lbm_value arg_list = cons_with_gc(acont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1668 // Go directly into application evaluation without passing go
1669 lbm_uint *sptr = stack_reserve(ctx, 3);
1670 sptr[0] = ctx->curr_env;
1671 sptr[1] = arg_list;
1672 sptr[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
1673 ctx->curr_exp = get_cadr(ctx->curr_exp);
1674}
1675
1676// (define sym exp)
1677#define KEY1 1
1678#define VAL2 2
1679static void eval_define(eval_context_t *ctx) {
1680 lbm_value parts[3];
1681 lbm_value rest = extract_n(ctx->curr_exp, parts, 3);
1682 lbm_uint *sptr = stack_reserve(ctx, 2);
1683 if (lbm_is_symbol(parts[KEY1]) && lbm_is_symbol_nil(rest)) {
1684 lbm_uint sym_val = lbm_dec_sym(parts[KEY1]);
1685 sptr[0] = parts[KEY1];
1686 if (sym_val >= RUNTIME_SYMBOLS_START0x40000) {
1687 sptr[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
1688 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02) {
1689 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
1690 }
1691 ctx->curr_exp = parts[VAL2];
1692 return;
1693 }
1694 }
1695 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
1696}
1697
1698
1699/* Eval lambda is cheating, a lot! It does this
1700 for performance reasons. The cheats are that
1701 1. When closure is created, a reference to the local env
1702 in which the lambda was evaluated is added to the closure.
1703 Ideally it should have created a list of free variables in the function
1704 and then looked up the values of these creating a new environment.
1705 2. The global env is considered global constant. As there is no copying
1706 of environment bindings into the closure, undefine may break closures.
1707
1708 Correct closure creation is a lot more expensive than what happens here.
1709 However, one can try to write programs in such a way that closures are created
1710 seldomly. If one does that the space-usage benefits of "correct" closures
1711 may outweigh the performance gain of "incorrect" ones.
1712
1713 some obscure programs such as test_setq_local_closure.lisp does not
1714 work properly due to this cheating.
1715 */
1716// (lambda param-list body-exp) -> (closure param-list body-exp env)
1717static void eval_lambda(eval_context_t *ctx) {
1718 lbm_value vals[3];
1719 extract_n(ctx->curr_exp, vals, 3);
1720 ctx->r = allocate_closure(vals[1],vals[2], ctx->curr_env);
1721#ifdef CLEAN_UP_CLOSURES
1722 lbm_uint sym_id = 0;
1723 if (clean_cl_env_symbol) {
1724 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1725 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1726 ctx->curr_exp = app;
1727 } else if (lbm_get_symbol_by_name("clean-cl-env", &sym_id)) {
1728 clean_cl_env_symbol = lbm_enc_sym(sym_id);
1729 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1730 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1731 ctx->curr_exp = app;
1732 } else {
1733 ctx->app_cont = true1;
1734 }
1735#else
1736 ctx->app_cont = true1;
1737#endif
1738}
1739
1740// (if cond-expr then-expr else-expr)
1741static void eval_if(eval_context_t *ctx) {
1742 lbm_value cdr = get_cdr(ctx->curr_exp);
1743 lbm_value *sptr = stack_reserve(ctx, 3);
1744 sptr[0] = get_cdr(cdr);
1745 sptr[1] = ctx->curr_env;
1746 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1747 ctx->curr_exp = get_car(cdr);
1748}
1749
1750// (cond (cond-expr-1 expr-1)
1751// ...
1752// (cond-expr-N expr-N))
1753static void eval_cond(eval_context_t *ctx) {
1754 lbm_value cond1[2];
1755 lbm_value rest_conds = extract_n(ctx->curr_exp, cond1, 2);
1756
1757 // end recursion at (cond )
1758 if (lbm_is_symbol_nil(cond1[1])) {
1759 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1760 ctx->app_cont = true1;
1761 } else {
1762 // Cond is one of the few places where a bit of syntax checking takes place at runtime..
1763 // Maybe dont bother?
1764 lbm_uint len = lbm_list_length(cond1[1]);
1765 if (len != 2) {
1766 lbm_set_error_reason("Incorrect syntax in cond");
1767 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1768 }
1769 lbm_value cond_expr[2];
1770 extract_n(cond1[1], cond_expr, 2);
1771 lbm_value rest;
1772 WITH_GC(rest, lbm_heap_allocate_list_init(2,(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1773 cond_expr[1], // Then branch(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1774 cons_with_gc(ENC_SYM_COND, rest_conds , ENC_SYM_NIL)))(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
1775 lbm_value *sptr = stack_reserve(ctx, 3);
1776 sptr[0] = rest;
1777 sptr[1] = ctx->curr_env;
1778 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1779 ctx->curr_exp = cond_expr[0]; //condition;
1780 }
1781}
1782
1783static void eval_app_cont(eval_context_t *ctx) {
1784 lbm_stack_drop(&ctx->K, 1);
1785 ctx->app_cont = true1;
1786}
1787
1788// Create a named location in an environment to later receive a value.
1789static binding_location_status create_binding_location_internal(lbm_value key, lbm_value *env) {
1790
1791 if (lbm_is_symbol(key) &&
1792 (key == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u) ||
1793 key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)))
1794 return BL_OK;
1795
1796 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) { // default case
1797 lbm_value binding;
1798 lbm_value new_env_tmp;
1799 binding = lbm_cons(key, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1800 new_env_tmp = lbm_cons(binding, *env);
1801 if (lbm_is_symbol(binding) || lbm_is_symbol(new_env_tmp)) {
1802 return BL_NO_MEMORY;
1803 }
1804 *env = new_env_tmp;
1805 } else if (lbm_is_cons(key)) { // deconstruct case
1806 int r = create_binding_location_internal(get_car(key), env);
1807 if (r == BL_OK) {
1808 r = create_binding_location_internal(get_cdr(key), env);
1809 }
1810 return r;
1811 }
1812 return BL_OK;
1813}
1814
1815static void create_binding_location(lbm_value key, lbm_value *env) {
1816
1817 lbm_value env_tmp = *env;
1818 binding_location_status r = create_binding_location_internal(key, &env_tmp);
1819 if (r != BL_OK) {
1820 if (r == BL_NO_MEMORY) {
1821 env_tmp = *env;
1822 lbm_gc_mark_phase(env_tmp);
1823 gc();
1824 r = create_binding_location_internal(key, &env_tmp);
1825 }
1826 switch(r) {
1827 case BL_OK:
1828 break;
1829 case BL_NO_MEMORY:
1830 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1831 break;
1832 case BL_INCORRECT_KEY:
1833 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
1834 break;
1835 }
1836 }
1837 *env = env_tmp;
1838}
1839
1840static void let_bind_values_eval(lbm_value binds, lbm_value exp, lbm_value env, eval_context_t *ctx) {
1841
1842 if (!lbm_is_cons(binds)) {
1843 // binds better be nil or there is a programmer error.
1844 ctx->curr_exp = exp;
1845 return;
1846 }
1847
1848 // Preallocate binding locations.
1849 lbm_value curr = binds;
1850 while (lbm_is_cons(curr)) {
1851 lbm_value new_env_tmp = env;
1852 lbm_value car_curr, cdr_curr;
1853 get_car_and_cdr(curr, &car_curr, &cdr_curr);
1854 lbm_value key = get_car(car_curr);
1855 create_binding_location(key, &new_env_tmp);
1856 env = new_env_tmp;
1857 curr = cdr_curr;
1858 }
1859
1860 lbm_value car_binds;
1861 lbm_value cdr_binds;
1862 get_car_and_cdr(binds, &car_binds, &cdr_binds);
1863 lbm_value key_val[2];
1864 extract_n(car_binds, key_val, 2);
1865
1866 lbm_uint *sptr = stack_reserve(ctx, 5);
1867 sptr[0] = exp;
1868 sptr[1] = cdr_binds;
1869 sptr[2] = env;
1870 sptr[3] = key_val[0];
1871 sptr[4] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
1872 ctx->curr_exp = key_val[1];
1873 ctx->curr_env = env;
1874}
1875
1876// (var x (...)) - local binding inside of an progn
1877// var has to take, place root-level nesting within progn.
1878// (progn ... (var a 10) ...) OK!
1879// (progn ... (something (var a 10)) ... ) NOT OK!
1880/* progn stack
1881 sp-4 : env
1882 sp-3 : 0
1883 sp-2 : rest
1884 sp-1 : PROGN_REST
1885*/
1886static void eval_var(eval_context_t *ctx) {
1887
1888 if (ctx->K.sp >= 4) { // Possibly in progn
1889 lbm_value sv = ctx->K.data[ctx->K.sp - 1];
1890 if (IS_CONTINUATION(sv)(((sv) & 0xF8000001u) == 0xF8000001u) && (sv == PROGN_REST(((4) << 2) | 0xF8000001u))) {
1891 lbm_uint sp = ctx->K.sp;
1892 uint32_t is_copied = lbm_dec_as_u32(ctx->K.data[sp-3]);
1893 if (is_copied == 0) {
1894 lbm_value env;
1895 WITH_GC(env, lbm_env_copy_spine(ctx->K.data[sp-4]))(env) = (lbm_env_copy_spine(ctx->K.data[sp-4])); if (lbm_is_symbol_merror
((env))) { gc(); (env) = (lbm_env_copy_spine(ctx->K.data[sp
-4])); if (lbm_is_symbol_merror((env))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1896 ctx->K.data[sp-3] = lbm_enc_u(1);
1897 ctx->K.data[sp-4] = env;
1898 }
1899 lbm_value new_env = ctx->K.data[sp-4];
1900 lbm_value args = get_cdr(ctx->curr_exp);
1901 lbm_value key = get_car(args);
1902 create_binding_location(key, &new_env);
1903 ctx->K.data[sp-4] = new_env;
1904
1905 lbm_value v_exp = get_cadr(args);
1906 lbm_value *sptr = stack_reserve(ctx, 3);
1907 sptr[0] = new_env;
1908 sptr[1] = key;
1909 sptr[2] = PROGN_VAR(((29) << 2) | 0xF8000001u);
1910 // Activating the new environment before the evaluation of the value to be bound,
1911 // means that other variables with same name will be shadowed already in the value
1912 // body.
1913 // The way closures work, the var-variable needs to be in scope during val evaluation
1914 // for a recursive closure to be possible.
1915 ctx->curr_env = new_env;
1916 ctx->curr_exp = v_exp;
1917 return;
1918 }
1919 }
1920 lbm_set_error_reason((char*)lbm_error_str_var_outside_progn);
1921 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1922}
1923
1924// (setq x (...)) - same as (set 'x (...)) or (setvar 'x (...))
1925static void eval_setq(eval_context_t *ctx) {
1926 lbm_value parts[3];
1927 extract_n(ctx->curr_exp, parts, 3);
1928 lbm_value *sptr = stack_reserve(ctx, 3);
1929 sptr[0] = ctx->curr_env;
1930 sptr[1] = parts[1];
1931 sptr[2] = SETQ(((30) << 2) | 0xF8000001u);
1932 ctx->curr_exp = parts[2];
1933}
1934
1935static void eval_move_to_flash(eval_context_t *ctx) {
1936 lbm_value args = get_cdr(ctx->curr_exp);
1937 lbm_value *sptr = stack_reserve(ctx,2);
1938 sptr[0] = args;
1939 sptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
1940 ctx->app_cont = true1;
1941}
1942
1943// (loop list-of-local-bindings
1944// condition-exp
1945// body-exp)
1946static void eval_loop(eval_context_t *ctx) {
1947 lbm_value env = ctx->curr_env;
1948 lbm_value parts[3];
1949 extract_n(get_cdr(ctx->curr_exp), parts, 3);
1950 lbm_value *sptr = stack_reserve(ctx, 3);
1951 sptr[0] = parts[LOOP_BODY2];
1952 sptr[1] = parts[LOOP_COND1];
1953 sptr[2] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
1954 let_bind_values_eval(parts[LOOP_BINDS0], parts[LOOP_COND1], env, ctx);
1955}
1956
1957/* (trap expression)
1958 *
1959 * suggested use:
1960 * (match (trap expression)
1961 * ((exit-error (? err)) (error-handler err))
1962 * ((exit-ok (? v)) (value-handler v)))
1963 */
1964static void eval_trap(eval_context_t *ctx) {
1965
1966 lbm_value expr = get_cadr(ctx->curr_exp);
1967 lbm_value retval;
1968 WITH_GC(retval, lbm_heap_allocate_list(2))(retval) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((retval))) { gc(); (retval) = (lbm_heap_allocate_list(2)); if
(lbm_is_symbol_merror((retval))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1969 lbm_set_car(retval, ENC_SYM_EXIT_OK(((0x3000B) << 4) | 0x00000000u)); // Assume things will go well.
1970 lbm_uint *sptr = stack_reserve(ctx,3);
1971 sptr[0] = retval;
1972 sptr[1] = ctx->flags;
1973 sptr[2] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1974 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10;
1975 ctx->curr_exp = expr;
1976}
1977
1978// (let list-of-binding s
1979// body-exp)
1980static void eval_let(eval_context_t *ctx) {
1981 lbm_value env = ctx->curr_env;
1982 lbm_value parts[3];
1983 extract_n(ctx->curr_exp, parts, 3);
1984 let_bind_values_eval(parts[1], parts[2], env, ctx);
1985}
1986
1987// (and exp0 ... expN)
1988static void eval_and(eval_context_t *ctx) {
1989 lbm_value rest = get_cdr(ctx->curr_exp);
1990 if (lbm_is_symbol_nil(rest)) {
1991 ctx->app_cont = true1;
1992 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1993 } else {
1994 lbm_value *sptr = stack_reserve(ctx, 3);
1995 sptr[0] = ctx->curr_env;
1996 sptr[1] = get_cdr(rest);
1997 sptr[2] = AND(((6) << 2) | 0xF8000001u);
1998 ctx->curr_exp = get_car(rest);
1999 }
2000}
2001
2002// (or exp0 ... expN)
2003static void eval_or(eval_context_t *ctx) {
2004 lbm_value rest = get_cdr(ctx->curr_exp);
2005 if (lbm_is_symbol_nil(rest)) {
2006 ctx->app_cont = true1;
2007 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2008 } else {
2009 lbm_value *sptr = stack_reserve(ctx, 3);
2010 sptr[0] = ctx->curr_env;
2011 sptr[1] = get_cdr(rest);
2012 sptr[2] = OR(((7) << 2) | 0xF8000001u);
2013 ctx->curr_exp = get_car(rest);
2014 }
2015}
2016
2017// Pattern matching
2018// format:
2019// (match e (pattern body)
2020// (pattern body)
2021// ... )
2022//
2023// There can be an optional pattern guard:
2024// (match e (pattern guard body)
2025// ... )
2026// a guard is a boolean expression.
2027// Guards make match, pattern matching more complicated
2028// than the recv pattern matching and requires staged execution
2029// via the continuation system rather than a while loop over a list.
2030static void eval_match(eval_context_t *ctx) {
2031
2032 lbm_value rest = get_cdr(ctx->curr_exp);
2033 if (lbm_type_of(rest) == LBM_TYPE_SYMBOL0x00000000u &&
2034 rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
2035 // Someone wrote the program (match)
2036 ctx->app_cont = true1;
2037 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2038 } else {
2039 lbm_value cdr_rest;
2040 get_car_and_cdr(rest, &ctx->curr_exp, &cdr_rest);
2041 lbm_value *sptr = stack_reserve(ctx, 3);
2042 sptr[0] = cdr_rest;
2043 sptr[1] = ctx->curr_env;
2044 sptr[2] = MATCH(((9) << 2) | 0xF8000001u);
2045 }
2046}
2047
2048static void receive_base(eval_context_t *ctx, lbm_value pats, float timeout_time, bool_Bool timeout) {
2049 if (ctx->num_mail == 0) {
2050 if (timeout) {
2051 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000), false0);
2052 } else {
2053 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1,0,false0);
2054 }
2055 } else {
2056 lbm_value *msgs = ctx->mailbox;
2057 lbm_uint num = ctx->num_mail;
2058
2059 if (lbm_is_symbol_nil(pats)) {
2060 /* A receive statement without any patterns */
2061 ctx->app_cont = true1;
2062 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2063 } else {
2064 /* The common case */
2065 lbm_value e;
2066 lbm_value new_env = ctx->curr_env;
2067 int n = find_match(pats, msgs, num, &e, &new_env);
2068 if (n == FM_NEED_GC-1) {
2069 gc();
2070 new_env = ctx->curr_env;
2071 n = find_match(pats, msgs, num, &e, &new_env);
2072 if (n == FM_NEED_GC-1) {
2073 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2074 }
2075 }
2076 if (n == FM_PATTERN_ERROR-3) {
2077 lbm_set_error_reason("Incorrect pattern format for recv");
2078 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),pats);
2079 } else if (n >= 0 ) { /* Match */
2080 mailbox_remove_mail(ctx, (lbm_uint)n);
2081 ctx->curr_env = new_env;
2082 ctx->curr_exp = e;
2083 } else { /* No match go back to sleep */
2084 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
2085 if (timeout) {
2086 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2,S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000),false0);
2087 } else {
2088 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,false0);
2089 }
2090 }
2091 }
2092 }
2093 return;
2094}
2095
2096static void eval_receive_timeout(eval_context_t *ctx) {
2097 if (is_atomic) {
2098 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2099 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2100 }
2101 lbm_value timeout_val = get_cadr(ctx->curr_exp);
2102 if (!lbm_is_number(timeout_val)) {
2103 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2104 }
2105 float timeout_time = lbm_dec_as_float(timeout_val);
2106 lbm_value pats = get_cdr(get_cdr(ctx->curr_exp));
2107 receive_base(ctx, pats, timeout_time, true1);
2108}
2109
2110// Receive
2111// (recv (pattern expr)
2112// (pattern expr))
2113static void eval_receive(eval_context_t *ctx) {
2114
2115 if (is_atomic) {
2116 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2117 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
2118 }
2119 lbm_value pats = get_cdr(ctx->curr_exp);
2120 receive_base(ctx, pats, 0, false0);
2121}
2122
2123/*********************************************************/
2124/* Continuation functions */
2125
2126/* cont_set_global_env
2127 sp-1 : Key-symbol
2128 */
2129static void cont_set_global_env(eval_context_t *ctx){
2130
2131 lbm_value key;
2132 lbm_value val = ctx->r;
2133
2134 lbm_pop(&ctx->K, &key);
2135 lbm_uint dec_key = lbm_dec_sym(key);
2136 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
2137 lbm_value *global_env = lbm_get_global_env();
2138 lbm_uint orig_env = global_env[ix_key];
2139 lbm_value new_env;
2140 // A key is a symbol and should not need to be remembered.
2141 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2142
2143 global_env[ix_key] = new_env;
2144 ctx->r = val;
2145
2146 ctx->app_cont = true1;
2147
2148 return;
2149}
2150
2151static void cont_resume(eval_context_t *ctx) {
2152 lbm_pop_2(&ctx->K, &ctx->curr_env, &ctx->curr_exp);
2153}
2154
2155static void cont_progn_rest(eval_context_t *ctx) {
2156 lbm_value *sptr = get_stack_ptr(ctx, 3);
2157
2158 lbm_value rest = sptr[2];
2159 lbm_value env = sptr[0];
2160
2161 lbm_value rest_car, rest_cdr;
2162 get_car_and_cdr(rest, &rest_car, &rest_cdr);
2163 ctx->curr_exp = rest_car;
2164 ctx->curr_env = env;
2165 if (lbm_is_symbol_nil(rest_cdr)) {
2166 // allow for tail recursion
2167 lbm_stack_drop(&ctx->K, 3);
2168 } else {
2169 sptr[2] = rest_cdr;
2170 stack_reserve(ctx, 1)[0] = PROGN_REST(((4) << 2) | 0xF8000001u);
2171 }
2172}
2173
2174static void cont_wait(eval_context_t *ctx) {
2175
2176 lbm_value cid_val;
2177 lbm_pop(&ctx->K, &cid_val);
2178 lbm_cid cid = (lbm_cid)lbm_dec_i(cid_val);
2179
2180 bool_Bool exists = false0;
2181
2182 lbm_blocked_iterator(context_exists, &cid, &exists);
2183 lbm_running_iterator(context_exists, &cid, &exists);
2184
2185 if (ctx_running->id == cid) {
2186 exists = true1;
2187 }
2188
2189 if (exists) {
2190 lbm_value *sptr = stack_reserve(ctx, 2);
2191 sptr[0] = lbm_enc_i(cid);
2192 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2193 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2194 ctx->app_cont = true1;
2195 yield_ctx(50000);
2196 } else {
2197 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2198 ctx->app_cont = true1;
2199 }
2200}
2201
2202static lbm_value perform_setvar(lbm_value key, lbm_value val, lbm_value env) {
2203
2204 lbm_uint s = lbm_dec_sym(key);
2205 if (s >= RUNTIME_SYMBOLS_START0x40000) {
2206 lbm_value new_env = lbm_env_modify_binding(env, key, val);
2207 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2208 lbm_uint ix_key = lbm_dec_sym(key) & GLOBAL_ENV_MASK0x1F;
2209 lbm_value *glob_env = lbm_get_global_env();
2210 new_env = lbm_env_modify_binding(glob_env[ix_key], key, val);
2211 glob_env[ix_key] = new_env;
2212 }
2213 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2214 lbm_set_error_reason((char*)lbm_error_str_variable_not_bound);
2215 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), key);
2216 }
2217 return val;
2218 }
2219 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2220 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // unreachable
2221}
2222
2223static void apply_setvar(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2224 if (nargs == 2 && lbm_is_symbol(args[0])) {
2225 lbm_value res;
2226 WITH_GC(res, perform_setvar(args[0], args[1], ctx->curr_env))(res) = (perform_setvar(args[0], args[1], ctx->curr_env));
if (lbm_is_symbol_merror((res))) { gc(); (res) = (perform_setvar
(args[0], args[1], ctx->curr_env)); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2227 ctx->r = args[1];
2228 lbm_stack_drop(&ctx->K, nargs+1);
2229 ctx->app_cont = true1;
2230 } else {
2231 if (nargs == 2) lbm_set_error_reason((char*)lbm_error_str_incorrect_arg);
2232 else lbm_set_error_reason((char*)lbm_error_str_num_args);
2233 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2234 }
2235}
2236
2237static void apply_read_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, bool_Bool program, bool_Bool incremental) {
2238 if (nargs == 1) {
2239 lbm_value chan = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2240 if (lbm_type_of_functional(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2241 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2242 gc();
2243 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2244 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2245 }
2246 }
2247 } else if (lbm_type_of(args[0]) == LBM_TYPE_CHANNEL0x90000000u) {
2248 chan = args[0];
2249 } else {
2250 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2251 }
2252 lbm_value *sptr = get_stack_ptr(ctx, 2);
2253
2254 // If we are inside a reader, its settings are stored.
2255 sptr[0] = lbm_enc_u(ctx->flags); // flags stored.
2256 sptr[1] = chan;
2257 lbm_value *rptr = stack_reserve(ctx,1);
2258 rptr[0] = READ_DONE(((20) << 2) | 0xF8000001u);
2259
2260 // Each reader starts in a fresh situation
2261 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
2262
2263 if (program) {
2264 if (incremental) {
2265 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2266 lbm_value *rptr1 = stack_reserve(ctx,3);
2267 rptr1[0] = chan;
2268 rptr1[1] = ctx->curr_env;
2269 rptr1[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
2270 } else {
2271 ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2272 lbm_value *rptr1 = stack_reserve(ctx,4);
2273 rptr1[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2274 rptr1[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2275 rptr1[2] = chan;
2276 rptr1[3] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
2277 }
2278 }
2279 rptr = stack_reserve(ctx,3); // reuse of variable rptr
2280 rptr[0] = chan;
2281 rptr[1] = lbm_enc_u(1);
2282 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
2283 ctx->app_cont = true1;
2284 } else {
2285 lbm_set_error_reason((char*)lbm_error_str_num_args);
2286 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2287 }
2288}
2289
2290static void apply_read_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2291 apply_read_base(args,nargs,ctx,true1,false0);
2292}
2293
2294static void apply_read_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2295 apply_read_base(args,nargs,ctx,true1,true1);
2296}
2297
2298static void apply_read(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2299 apply_read_base(args,nargs,ctx,false0,false0);
2300}
2301
2302static void apply_spawn_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, uint32_t context_flags) {
2303
2304 lbm_uint stack_size = EVAL_CPS_DEFAULT_STACK_SIZE256;
2305 lbm_uint closure_pos = 0;
2306 char *name = NULL((void*)0);
2307
2308 if (nargs >= 1 &&
2309 lbm_is_closure(args[0])) {
2310 closure_pos = 0;
2311 } else if (nargs >= 2 &&
2312 lbm_is_number(args[0]) &&
2313 lbm_is_closure(args[1])) {
2314 stack_size = lbm_dec_as_u32(args[0]);
2315 closure_pos = 1;
2316 } else if (nargs >= 2 &&
2317 lbm_is_array_r(args[0]) &&
2318 lbm_is_closure(args[1])) {
2319 name = lbm_dec_str(args[0]);
2320 closure_pos = 1;
2321 }else if (nargs >= 3 &&
2322 lbm_is_array_r(args[0]) &&
2323 lbm_is_number(args[1]) &&
2324 lbm_is_closure(args[2])) {
2325 stack_size = lbm_dec_as_u32(args[1]);
2326 closure_pos = 2;
2327 name = lbm_dec_str(args[0]);
2328 } else {
2329 if (context_flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01)
2330 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN_TRAP(((0x30005) << 4) | 0x00000000u));
2331 else
2332 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN(((0x30004) << 4) | 0x00000000u));
2333 }
2334
2335 lbm_value cl[3];
2336 extract_n(get_cdr(args[closure_pos]), cl, 3);
2337 lbm_value curr_param = cl[CLO_PARAMS0];
2338 lbm_value clo_env = cl[CLO_ENV2];
2339 lbm_uint i = closure_pos + 1;
2340 while (lbm_is_cons(curr_param) && i <= nargs) {
2341 lbm_value entry = cons_with_gc(get_car(curr_param), args[i], clo_env);
2342 lbm_value aug_env = cons_with_gc(entry, clo_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2343 clo_env = aug_env;
2344 curr_param = get_cdr(curr_param);
2345 i ++;
2346 }
2347
2348 lbm_stack_drop(&ctx->K, nargs+1);
2349
2350 lbm_value program = cons_with_gc(cl[CLO_BODY1], ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), clo_env);
2351
2352 lbm_cid cid = lbm_create_ctx_parent(program,
2353 clo_env,
2354 stack_size,
2355 lbm_get_current_cid(),
2356 context_flags,
2357 name);
2358 ctx->r = lbm_enc_i(cid);
2359 ctx->app_cont = true1;
2360}
2361
2362static void apply_spawn(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2363 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00);
2364}
2365
2366static void apply_spawn_trap(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2367 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01);
2368}
2369
2370static void apply_yield(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2371 if (is_atomic) {
2372 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2373 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2374 }
2375 if (nargs == 1 && lbm_is_number(args[0])) {
2376 lbm_uint ts = lbm_dec_as_u32(args[0]);
2377 lbm_stack_drop(&ctx->K, nargs+1);
2378 yield_ctx(ts);
2379 } else {
2380 lbm_set_error_reason((char*)lbm_error_str_no_number);
2381 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2382 }
2383}
2384
2385static void apply_sleep(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2386 if (is_atomic) {
2387 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2388 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2389 }
2390 if (nargs == 1 && lbm_is_number(args[0])) {
2391 lbm_uint ts = (lbm_uint)(1000000.0f * lbm_dec_as_float(args[0]));
2392 lbm_stack_drop(&ctx->K, nargs+1);
2393 yield_ctx(ts);
2394 } else {
2395 lbm_set_error_reason((char*)lbm_error_str_no_number);
2396 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2397 }
2398}
2399
2400static void apply_wait(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2401 if (nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2402 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2403 lbm_value *sptr = get_stack_ptr(ctx, 2);
2404 sptr[0] = lbm_enc_i(cid);
2405 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2406 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2407 ctx->app_cont = true1;
2408 yield_ctx(50000);
2409 } else {
2410 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_WAIT(((0x30007) << 4) | 0x00000000u));
2411 }
2412}
2413
2414/* (eval expr)
2415 (eval env expr) */
2416static void apply_eval(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2417 if ( nargs == 1) {
2418 ctx->curr_exp = args[0];
2419 } else if (nargs == 2) {
2420 ctx->curr_exp = args[1];
2421 ctx->curr_env = args[0];
2422 } else {
2423 lbm_set_error_reason((char*)lbm_error_str_num_args);
2424 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL(((0x30008) << 4) | 0x00000000u));
2425 }
2426 lbm_stack_drop(&ctx->K, nargs+1);
2427}
2428
2429static void apply_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2430 int prg_pos = 0;
2431 if (nargs == 2) {
2432 prg_pos = 1;
2433 ctx->curr_env = args[0];
2434 }
2435 if (nargs == 1 || nargs == 2) {
2436 lbm_value prg = args[prg_pos];
2437 lbm_value app_cont;
2438 lbm_value app_cont_prg;
2439 lbm_value new_prg;
2440 lbm_value prg_copy;
2441
2442 int len = -1;
2443 WITH_GC(prg_copy, lbm_list_copy(&len, prg))(prg_copy) = (lbm_list_copy(&len, prg)); if (lbm_is_symbol_merror
((prg_copy))) { gc(); (prg_copy) = (lbm_list_copy(&len, prg
)); if (lbm_is_symbol_merror((prg_copy))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2444 lbm_stack_drop(&ctx->K, nargs+1);
2445
2446 if (ctx->K.sp > nargs+2) { // if there is a continuation
2447 app_cont = cons_with_gc(ENC_SYM_APP_CONT(((0x111) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2448 app_cont_prg = cons_with_gc(app_cont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2449 new_prg = lbm_list_append(app_cont_prg, ctx->program);
2450 new_prg = lbm_list_append(prg_copy, new_prg);
2451 } else {
2452 new_prg = lbm_list_append(prg_copy, ctx->program);
2453 }
2454 if (!lbm_is_list(new_prg)) {
2455 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2456 }
2457 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);
2458 ctx->program = get_cdr(new_prg);
2459 ctx->curr_exp = get_car(new_prg);
2460 } else {
2461 lbm_set_error_reason((char*)lbm_error_str_num_args);
2462 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2463 }
2464}
2465
2466static void apply_send(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2467 if (nargs == 2) {
2468 if (lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2469 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2470 lbm_value msg = args[1];
2471 lbm_value status = lbm_find_receiver_and_send(cid, msg);
2472 /* return the status */
2473 lbm_stack_drop(&ctx->K, nargs+1);
2474 ctx->r = status;
2475 ctx->app_cont = true1;
2476 } else {
2477 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2478 }
2479 } else {
2480 lbm_set_error_reason((char*)lbm_error_str_num_args);
2481 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2482 }
2483}
2484
2485static void apply_ok(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2486 lbm_value ok_val = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2487 if (nargs >= 1) {
2488 ok_val = args[0];
2489 }
2490 ctx->r = ok_val;
2491 ok_ctx();
2492}
2493
2494static void apply_error(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2495 (void) ctx;
2496 lbm_value err_val = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
2497 if (nargs >= 1) {
2498 err_val = args[0];
2499 }
2500 error_at_ctx(err_val, ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
2501}
2502
2503// (map f arg-list)
2504static void apply_map(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2505 if (nargs == 2 && lbm_is_cons(args[1])) {
2506 lbm_value *sptr = get_stack_ptr(ctx, 3);
2507
2508 lbm_value f = args[0];
2509 lbm_value h = get_car(args[1]);
2510 lbm_value t = get_cdr(args[1]);
2511
2512 lbm_value appli_1;
2513 lbm_value appli;
2514 WITH_GC(appli_1, lbm_heap_allocate_list(2))(appli_1) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli_1))) { gc(); (appli_1) = (lbm_heap_allocate_list(2));
if (lbm_is_symbol_merror((appli_1))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2515 WITH_GC_RMBR_1(appli, lbm_heap_allocate_list(2), appli_1)(appli) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli))) { lbm_gc_mark_phase(appli_1); gc(); (appli) = (lbm_heap_allocate_list
(2)); if (lbm_is_symbol_merror((appli))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2516
2517 lbm_value appli_0 = get_cdr(appli_1);
2518
2519 lbm_set_car_and_cdr(appli_0, h, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2520 lbm_set_car(appli_1, ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u));
2521
2522 lbm_set_car_and_cdr(get_cdr(appli), appli_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2523 lbm_set_car(appli, f);
2524
2525 lbm_value elt = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), appli);
2526 sptr[0] = t; // reuse stack space
2527 sptr[1] = ctx->curr_env;
2528 sptr[2] = elt;
2529 lbm_value *rptr = stack_reserve(ctx,4);
2530 rptr[0] = elt;
2531 rptr[1] = appli;
2532 rptr[2] = appli_0;
2533 rptr[3] = MAP(((26) << 2) | 0xF8000001u);
2534 ctx->curr_exp = appli;
2535 } else if (nargs == 2 && lbm_is_symbol_nil(args[1])) {
2536 lbm_stack_drop(&ctx->K, 3);
2537 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2538 ctx->app_cont = true1;
2539 return;
2540 } else {
2541 lbm_set_error_reason((char*)lbm_error_str_num_args);
2542 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_MAP(((0x3000D) << 4) | 0x00000000u));
2543 }
2544}
2545
2546static void apply_reverse(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2547 if (nargs == 1 && lbm_is_list(args[0])) {
2548 lbm_value curr = args[0];
2549
2550 lbm_value new_list = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2551 while (lbm_is_cons(curr)) {
2552 lbm_value tmp = cons_with_gc(get_car(curr), new_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2553 new_list = tmp;
2554 curr = get_cdr(curr);
2555 }
2556 lbm_stack_drop(&ctx->K, 2);
2557 ctx->r = new_list;
2558 ctx->app_cont = true1;
2559 } else {
2560 lbm_set_error_reason("Reverse requires a list argument");
2561 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_REVERSE(((0x3000E) << 4) | 0x00000000u));
2562 }
2563}
2564
2565static void apply_flatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2566 if (nargs == 1) {
2567
2568 lbm_value v = flatten_value(args[0]);
2569 if ( v == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)) {
2570 gc();
2571 v = flatten_value(args[0]);
2572 }
2573
2574 if (lbm_is_symbol(v)) {
2575 error_at_ctx(v, ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2576 } else {
2577 lbm_stack_drop(&ctx->K, 2);
2578 ctx->r = v;
2579 ctx->app_cont = true1;
2580 }
2581 return;
2582 }
2583 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2584}
2585
2586static void apply_unflatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2587 if(nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2588 lbm_array_header_t *array;
2589 array = (lbm_array_header_t *)get_car(args[0]);
2590
2591 lbm_flat_value_t fv;
2592 fv.buf = (uint8_t*)array->data;
2593 fv.buf_size = array->size;
2594 fv.buf_pos = 0;
2595
2596 lbm_value res;
2597
2598 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2599 if (lbm_unflatten_value(&fv, &res)) {
2600 ctx->r = res;
2601 }
2602 lbm_stack_drop(&ctx->K, 2);
2603 ctx->app_cont = true1;
2604 return;
2605 }
2606 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_UNFLATTEN(((0x30010) << 4) | 0x00000000u));
2607}
2608
2609static void apply_kill(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2610 if (nargs == 2 && lbm_is_number(args[0])) {
2611 lbm_cid cid = lbm_dec_as_i32(args[0]);
2612
2613 if (ctx->id == cid) {
2614 ctx->r = args[1];
2615 finish_ctx();
2616 return;
2617 }
2618 mutex_lock(&qmutex);
2619 eval_context_t *found = NULL((void*)0);
2620 found = lookup_ctx_nm(&blocked, cid);
2621 if (found)
2622 drop_ctx_nm(&blocked, found);
2623 else
2624 found = lookup_ctx_nm(&queue, cid);
2625 if (found)
2626 drop_ctx_nm(&queue, found);
2627
2628 if (found) {
2629 found->K.data[found->K.sp - 1] = KILL(((40) << 2) | 0xF8000001u);
2630 found->r = args[1];
2631 found->app_cont = true1;
2632 enqueue_ctx_nm(&queue,found);
2633 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2634 } else {
2635 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2636 }
2637 lbm_stack_drop(&ctx->K, 3);
2638 ctx->app_cont = true1;
2639 mutex_unlock(&qmutex);
2640 return;
2641 }
2642 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_KILL(((0x30011) << 4) | 0x00000000u));
2643}
2644
2645// (merge comparator list1 list2)
2646static void apply_merge(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2647 if (nargs == 3 && lbm_is_list(args[1]) && lbm_is_list(args[2])) {
2648
2649 if (!lbm_is_closure(args[0])) {
2650 lbm_value closure;
2651 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2652 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2653 lbm_value cl1 = lbm_cdr(closure);
2654 lbm_value par;
2655 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2656 lbm_set_car(cl1, par);
2657 lbm_value cl2 = lbm_cdr(cl1);
2658 lbm_value body;
2659 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2660 lbm_set_car(cl2, body);
2661 lbm_value cl3 = lbm_cdr(cl2);
2662 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2663
2664 // Replace operator on stack with closure and rest of the code is
2665 // compatible.
2666 args[0] = closure;
2667 }
2668
2669 // Copy input lists for functional behaviour at top-level
2670 // merge itself is in-place in the copied lists.
2671 lbm_value a;
2672 lbm_value b;
2673 int len_a = -1;
2674 int len_b = -1;
2675 WITH_GC(a, lbm_list_copy(&len_a, args[1]))(a) = (lbm_list_copy(&len_a, args[1])); if (lbm_is_symbol_merror
((a))) { gc(); (a) = (lbm_list_copy(&len_a, args[1])); if
(lbm_is_symbol_merror((a))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } };
2676 WITH_GC_RMBR_1(b, lbm_list_copy(&len_b, args[2]), a)(b) = (lbm_list_copy(&len_b, args[2])); if (lbm_is_symbol_merror
((b))) { lbm_gc_mark_phase(a); gc(); (b) = (lbm_list_copy(&
len_b, args[2])); if (lbm_is_symbol_merror((b))) { error_ctx(
(((0x23) << 4) | 0x00000000u)); } };
2677
2678 if (len_a == 0) {
2679 ctx->r = b;
2680 lbm_stack_drop(&ctx->K, 4);
2681 ctx->app_cont = true1;
2682 return;
2683 }
2684 if (len_b == 0) {
2685 ctx->r = a;
2686 lbm_stack_drop(&ctx->K, 4);
2687 ctx->app_cont = true1;
2688 return;
2689 }
2690
2691 args[1] = a; // keep safe by replacing the original on stack.
2692 args[2] = b;
2693
2694 lbm_value a_1 = a;
2695 lbm_value a_rest = lbm_cdr(a);
2696 lbm_value b_1 = b;
2697 lbm_value b_rest = lbm_cdr(b);
2698
2699 lbm_value cl[3]; // Comparator closure
2700 extract_n(lbm_cdr(args[0]), cl, 3);
2701 lbm_value cmp_env = cl[CLO_ENV2];
2702 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2703 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2704 lbm_uint len = lbm_list_length(cl[CLO_PARAMS0]);
2705 if (len == 2) {
2706 par1 = get_car(cl[CLO_PARAMS0]);
2707 par2 = get_cadr(cl[CLO_PARAMS0]);
2708 lbm_value new_env0;
2709 lbm_value new_env;
2710 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a_1)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a_1))); if (
lbm_is_symbol_merror((new_env0))) { gc(); (new_env0) = (lbm_env_set
(cmp_env, par1, lbm_car(a_1))); if (lbm_is_symbol_merror((new_env0
))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2711 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b_1)),new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1))); if (
lbm_is_symbol_merror((new_env))) { lbm_gc_mark_phase(new_env0
); gc(); (new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1
))); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2712 cmp_env = new_env;
2713 } else {
2714 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2715 }
2716 lbm_set_cdr(a_1, b_1);
2717 lbm_set_cdr(b_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2718 lbm_value cmp = cl[CLO_BODY1];
2719
2720 lbm_stack_drop(&ctx->K, 4); // TODO: Optimize drop 4 alloc 10 into alloc 6
2721 lbm_uint *sptr = stack_reserve(ctx, 10);
2722 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged list
2723 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged list
2724 sptr[2] = a_1;
2725 sptr[3] = a_rest;
2726 sptr[4] = b_rest;
2727 sptr[5] = cmp;
2728 sptr[6] = cmp_env;
2729 sptr[7] = par1;
2730 sptr[8] = par2;
2731 sptr[9] = MERGE_REST(((43) << 2) | 0xF8000001u);
2732 ctx->curr_exp = cl[CLO_BODY1];
2733 ctx->curr_env = cmp_env;
2734 return;
2735 }
2736 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MERGE(((0x30013) << 4) | 0x00000000u));
2737}
2738
2739// (sort comparator list)
2740static void apply_sort(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2741 if (nargs == 2 && lbm_is_list(args[1])) {
2742
2743 if (!lbm_is_closure(args[0])) {
2744 lbm_value closure;
2745 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2746 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2747 lbm_value cl1 = lbm_cdr(closure);
2748 lbm_value par;
2749 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2750 lbm_set_car(cl1, par);
2751 lbm_value cl2 = lbm_cdr(cl1);
2752 lbm_value body;
2753 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2754 lbm_set_car(cl2, body);
2755 lbm_value cl3 = lbm_cdr(cl2);
2756 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2757
2758 // Replace operator on stack with closure and rest of the code is
2759 // compatible.
2760 args[0] = closure;
2761 }
2762
2763 int len = -1;
2764 lbm_value list_copy;
2765 WITH_GC(list_copy, lbm_list_copy(&len, args[1]))(list_copy) = (lbm_list_copy(&len, args[1])); if (lbm_is_symbol_merror
((list_copy))) { gc(); (list_copy) = (lbm_list_copy(&len,
args[1])); if (lbm_is_symbol_merror((list_copy))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2766 if (len <= 1) {
2767 lbm_stack_drop(&ctx->K, 3);
2768 ctx->r = list_copy;
2769 ctx->app_cont = true1;
2770 return;
2771 }
2772
2773 args[1] = list_copy; // Keep safe, original replaced on stack.
2774
2775 // Take the headmost 2, 1-element sublists.
2776 lbm_value a = list_copy;
2777 lbm_value b = lbm_cdr(a);
2778 lbm_value rest = lbm_cdr(b);
2779 // Do not terminate b. keep rest of list safe from GC in the following
2780 // closure extraction.
2781 //lbm_set_cdr(a, b); // This is void
2782
2783 lbm_value cl[3]; // Comparator closure
2784 extract_n(lbm_cdr(args[0]), cl, 3);
2785 lbm_value cmp_env = cl[CLO_ENV2];
2786 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2787 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2788 lbm_uint cl_len = lbm_list_length(cl[CLO_PARAMS0]);
2789 if (cl_len == 2) {
2790 par1 = get_car(cl[CLO_PARAMS0]);
2791 par2 = get_cadr(cl[CLO_PARAMS0]);
2792 lbm_value new_env0;
2793 lbm_value new_env;
2794 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a))); if (lbm_is_symbol_merror
((new_env0))) { gc(); (new_env0) = (lbm_env_set(cmp_env, par1
, lbm_car(a))); if (lbm_is_symbol_merror((new_env0))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2795 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b)), new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { lbm_gc_mark_phase(new_env0); gc(); (new_env) =
(lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { error_ctx((((0x23) << 4) | 0x00000000u))
; } };
2796 cmp_env = new_env;
2797 } else {
2798 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2799 }
2800 lbm_value cmp = cl[CLO_BODY1];
2801
2802 // Terminate the comparator argument list.
2803 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2804
2805 lbm_stack_drop(&ctx->K, 3); //TODO: optimize drop 3, alloc 20 into alloc 17
2806 lbm_uint *sptr = stack_reserve(ctx, 20);
2807 sptr[0] = cmp;
2808 sptr[1] = cmp_env;
2809 sptr[2] = par1;
2810 sptr[3] = par2;
2811 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged accumulation of sublists
2812 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged accumulation of sublists
2813 sptr[6] = rest;
2814 sptr[7] = lbm_enc_i(1);
2815 sptr[8] = lbm_enc_i(len); //TODO: 28 bit i vs 32 bit i
2816 sptr[9] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
2817 sptr[10] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged sublist
2818 sptr[11] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged sublist
2819 sptr[12] = a;
2820 sptr[13] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no a_rest, 1 element lists in layer 1.
2821 sptr[14] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no b_rest, 1 element lists in layer 1.
2822 sptr[15] = cmp;
2823 sptr[16] = cmp_env;
2824 sptr[17] = par1;
2825 sptr[18] = par2;
2826 sptr[19] = MERGE_REST(((43) << 2) | 0xF8000001u);
2827 ctx->curr_exp = cmp;
2828 ctx->curr_env = cmp_env;
2829 return;
2830 }
2831 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
2832}
2833
2834static void apply_rest_args(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2835 lbm_value res;
2836 if (lbm_env_lookup_b(&res, ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ctx->curr_env)) {
2837 if (nargs == 1 && lbm_is_number(args[0])) {
2838 int32_t ix = lbm_dec_as_i32(args[0]);
2839 res = lbm_index_list(res, ix);
2840 }
2841 ctx->r = res;
2842 } else {
2843 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2844 }
2845 lbm_stack_drop(&ctx->K, nargs+1);
2846 ctx->app_cont = true1;
2847}
2848
2849/* (rotate list-expr dist/dir-expr) */
2850static void apply_rotate(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2851 if (nargs == 2 && lbm_is_list(args[0]) && lbm_is_number(args[1])) {
2852 int len = -1;
2853 lbm_value ls = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2854 WITH_GC(ls, lbm_list_copy(&len, args[0]))(ls) = (lbm_list_copy(&len, args[0])); if (lbm_is_symbol_merror
((ls))) { gc(); (ls) = (lbm_list_copy(&len, args[0])); if
(lbm_is_symbol_merror((ls))) { error_ctx((((0x23) << 4
) | 0x00000000u)); } };
2855 int dist = lbm_dec_as_i32(args[1]);
2856 if (len > 0 && dist != 0) {
2857 int d = dist;
2858 if (dist > 0) {
2859 ls = lbm_list_destructive_reverse(ls);
2860 } else {
2861 d = -dist;
2862 }
2863
2864 lbm_value start = ls;
2865 lbm_value end = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2866 lbm_value curr = start;
2867 while (lbm_is_cons(curr)) {
2868 end = curr;
2869 curr = get_cdr(curr);
2870 }
2871
2872 for (int i = 0; i < d; i ++) {
2873 lbm_value a = start;
2874 start = lbm_cdr(start);
2875 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2876 lbm_set_cdr(end, a);
2877 end = a;
2878 }
2879 ls = start;
2880 if (dist > 0) {
2881 ls = lbm_list_destructive_reverse(ls);
2882 }
2883 }
2884 lbm_stack_drop(&ctx->K, nargs+1);
2885 ctx->app_cont = true1;
2886 ctx->r = ls;
2887 return;
2888 }
2889 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2890}
2891
2892/***************************************************/
2893/* Application lookup table */
2894
2895typedef void (*apply_fun)(lbm_value *, lbm_uint, eval_context_t *);
2896static const apply_fun fun_table[] =
2897 {
2898 apply_setvar,
2899 apply_read,
2900 apply_read_program,
2901 apply_read_eval_program,
2902 apply_spawn,
2903 apply_spawn_trap,
2904 apply_yield,
2905 apply_wait,
2906 apply_eval,
2907 apply_eval_program,
2908 apply_send,
2909 apply_ok,
2910 apply_error,
2911 apply_map,
2912 apply_reverse,
2913 apply_flatten,
2914 apply_unflatten,
2915 apply_kill,
2916 apply_sleep,
2917 apply_merge,
2918 apply_sort,
2919 apply_rest_args,
2920 apply_rotate,
2921 };
2922
2923/***************************************************/
2924/* Application of function that takes arguments */
2925/* passed over the stack. */
2926
2927static void application(eval_context_t *ctx, lbm_value *fun_args, lbm_uint arg_count) {
2928 /* If arriving here, we know that the fun is a symbol.
2929 * and can be a built in operation or an extension.
2930 */
2931 lbm_value fun = fun_args[0];
2932
2933 lbm_uint fun_val = lbm_dec_sym(fun);
2934 lbm_uint fun_kind = SYMBOL_KIND(fun_val)((fun_val) >> 16);
2935
2936 switch (fun_kind) {
2937 case SYMBOL_KIND_EXTENSION1: {
2938 extension_fptr f = extension_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)].fptr;
2939
2940 lbm_value ext_res;
2941 WITH_GC(ext_res, f(&fun_args[1], arg_count))(ext_res) = (f(&fun_args[1], arg_count)); if (lbm_is_symbol_merror
((ext_res))) { gc(); (ext_res) = (f(&fun_args[1], arg_count
)); if (lbm_is_symbol_merror((ext_res))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2942 if (lbm_is_error(ext_res)) { //Error other than merror
2943 error_at_ctx(ext_res, fun);
2944 }
2945 lbm_stack_drop(&ctx->K, arg_count + 1);
2946
2947 ctx->app_cont = true1;
2948 ctx->r = ext_res;
2949
2950 if (blocking_extension) {
2951 blocking_extension = false0;
2952 if (blocking_extension_timeout) {
2953 blocking_extension_timeout = false0;
2954 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, blocking_extension_timeout_us,true1);
2955 } else {
2956 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,true1);
2957 }
2958 mutex_unlock(&blocking_extension_mutex);
2959 }
2960 } break;
2961 case SYMBOL_KIND_FUNDAMENTAL2:
2962 call_fundamental(SYMBOL_IX(fun_val)((fun_val) & 0xFFFF), &fun_args[1], arg_count, ctx);
2963 break;
2964 case SYMBOL_KIND_APPFUN3:
2965 fun_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)](&fun_args[1], arg_count, ctx);
2966 break;
2967 default:
2968 // Symbols that are "special" but not in the way caught above
2969 // ends up here.
2970 lbm_set_error_reason("Symbol does not represent a function");
2971 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),fun_args[0]);
2972 break;
2973 }
2974}
2975
2976static void cont_closure_application_args(eval_context_t *ctx) {
2977 lbm_uint* sptr = get_stack_ptr(ctx, 5);
2978
2979 lbm_value arg_env = (lbm_value)sptr[0];
2980 lbm_value exp = (lbm_value)sptr[1];
2981 lbm_value clo_env = (lbm_value)sptr[2];
2982 lbm_value params = (lbm_value)sptr[3];
2983 lbm_value args = (lbm_value)sptr[4];
2984
2985 lbm_value car_params, cdr_params;
2986 get_car_and_cdr(params, &car_params, &cdr_params);
2987
2988 bool_Bool a_nil = lbm_is_symbol_nil(args);
2989 bool_Bool p_nil = lbm_is_symbol_nil(cdr_params);
2990
2991 lbm_value binder = allocate_binding(car_params, ctx->r, clo_env);
2992
2993 if (!a_nil && !p_nil) {
2994 lbm_value car_args, cdr_args;
2995 get_car_and_cdr(args, &car_args, &cdr_args);
2996 sptr[2] = binder;
2997 sptr[3] = cdr_params;
2998 sptr[4] = cdr_args;
2999 stack_reserve(ctx,1)[0] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
3000 ctx->curr_exp = car_args;
3001 ctx->curr_env = arg_env;
3002 } else if (a_nil && p_nil) {
3003 // Arguments and parameters match up in number
3004 lbm_stack_drop(&ctx->K, 5);
3005 ctx->curr_env = binder;
3006 ctx->curr_exp = exp;
3007 } else if (p_nil) {
3008 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), binder);
3009 sptr[2] = rest_binder;
3010 sptr[3] = get_cdr(args);
3011 sptr[4] = get_car(rest_binder); // last element of rest_args so far
3012 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3013 ctx->curr_exp = get_car(args);
3014 ctx->curr_env = arg_env;
3015 } else {
3016 lbm_set_error_reason((char*)lbm_error_str_num_args);
3017 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
3018 }
3019}
3020
3021
3022static void cont_closure_args_rest(eval_context_t *ctx) {
3023 lbm_uint* sptr = get_stack_ptr(ctx, 5);
3024 lbm_value arg_env = (lbm_value)sptr[0];
3025 lbm_value exp = (lbm_value)sptr[1];
3026 lbm_value clo_env = (lbm_value)sptr[2];
3027 lbm_value args = (lbm_value)sptr[3];
3028 lbm_value last = (lbm_value)sptr[4];
3029 lbm_cons_t* heap = lbm_heap_state.heap;
3030
3031 lbm_value binding = lbm_heap_state.freelist;
3032 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3033 gc();
3034 binding = lbm_heap_state.freelist;
3035 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3036 }
3037 lbm_uint binding_ix = lbm_dec_ptr(binding);
3038 lbm_heap_state.freelist = heap[binding_ix].cdr;
3039 lbm_heap_state.num_alloc += 1;
3040 heap[binding_ix].car = ctx->r;
3041 heap[binding_ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3042
3043
3044 lbm_set_cdr(last, binding);
3045 sptr[4] = binding;
3046
3047 if (args == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3048 lbm_stack_drop(&ctx->K, 5);
3049 ctx->curr_env = clo_env;
3050 ctx->curr_exp = exp;
3051 } else {
3052 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3053 sptr[3] = get_cdr(args);
3054 ctx->curr_exp = get_car(args);
3055 ctx->curr_env = arg_env;
3056 }
3057}
3058
3059static void cont_application_args(eval_context_t *ctx) {
3060 lbm_uint *sptr = get_stack_ptr(ctx, 3);
3061
3062 lbm_value env = sptr[0];
3063 lbm_value rest = sptr[1];
3064 lbm_value count = sptr[2];
3065
3066 ctx->curr_env = env;
3067 sptr[0] = ctx->r; // Function 1st then Arguments
3068 if (lbm_is_cons(rest)) {
3069 lbm_cons_t *cell = lbm_ref_cell(rest);
3070 sptr[1] = env;
3071 sptr[2] = cell->cdr;
3072 lbm_value *rptr = stack_reserve(ctx,2);
3073 rptr[0] = count + (1 << LBM_VAL_SHIFT4);
3074 rptr[1] = APPLICATION_ARGS(((5) << 2) | 0xF8000001u);
3075 ctx->curr_exp = cell->car;
3076 } else {
3077 // No more arguments
3078 lbm_stack_drop(&ctx->K, 2);
3079 lbm_uint nargs = lbm_dec_u(count);
3080 lbm_value *args = get_stack_ptr(ctx, (uint32_t)(nargs + 1));
3081 application(ctx,args, nargs);
3082 }
3083}
3084
3085static void cont_and(eval_context_t *ctx) {
3086 lbm_value env;
3087 lbm_value rest;
3088 lbm_value arg = ctx->r;
3089 lbm_pop_2(&ctx->K, &rest, &env);
3090 if (lbm_is_symbol_nil(arg)) {
3091 ctx->app_cont = true1;
3092 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3093 } else if (lbm_is_symbol_nil(rest)) {
3094 ctx->app_cont = true1;
3095 } else {
3096 lbm_value *sptr = stack_reserve(ctx, 3);
3097 sptr[0] = env;
3098 sptr[1] = get_cdr(rest);
3099 sptr[2] = AND(((6) << 2) | 0xF8000001u);
3100 ctx->curr_env = env;
3101 ctx->curr_exp = get_car(rest);
3102 }
3103}
3104
3105static void cont_or(eval_context_t *ctx) {
3106 lbm_value env;
3107 lbm_value rest;
3108 lbm_value arg = ctx->r;
3109 lbm_pop_2(&ctx->K, &rest, &env);
3110 if (!lbm_is_symbol_nil(arg)) {
3111 ctx->app_cont = true1;
3112 } else if (lbm_is_symbol_nil(rest)) {
3113 ctx->app_cont = true1;
3114 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3115 } else {
3116 lbm_value *sptr = stack_reserve(ctx, 3);
3117 sptr[0] = env;
3118 sptr[1] = get_cdr(rest);
3119 sptr[2] = OR(((7) << 2) | 0xF8000001u);
3120 ctx->curr_exp = get_car(rest);
3121 ctx->curr_env = env;
3122 }
3123}
3124
3125static int fill_binding_location(lbm_value key, lbm_value value, lbm_value env) {
3126 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) {
3127 if (key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return FB_OK0;
3128 lbm_env_modify_binding(env,key,value);
3129 return FB_OK0;
3130 } else if (lbm_is_cons(key) &&
3131 lbm_is_cons(value)) {
3132 int r = fill_binding_location(get_car(key), get_car(value), env);
3133 if (r == FB_OK0) {
3134 r = fill_binding_location(get_cdr(key), get_cdr(value), env);
3135 }
3136 return r;
3137 }
3138 return FB_TYPE_ERROR-1;
3139}
3140
3141static void cont_bind_to_key_rest(eval_context_t *ctx) {
3142
3143 lbm_value *sptr = get_stack_ptr(ctx, 4);
3144
3145 lbm_value rest = sptr[1];
3146 lbm_value env = sptr[2];
3147 lbm_value key = sptr[3];
3148
3149 if (fill_binding_location(key, ctx->r, env) < 0) {
3150 lbm_set_error_reason("Incorrect type of name/key in let-binding");
3151 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
3152 }
3153
3154 if (lbm_is_cons(rest)) {
3155 lbm_value car_rest = get_car(rest);
3156 lbm_value key_val[2];
3157 extract_n(car_rest, key_val, 2);
3158
3159 sptr[1] = get_cdr(rest);
3160 sptr[3] = key_val[0];
3161 stack_reserve(ctx,1)[0] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
3162 ctx->curr_exp = key_val[1];
3163 ctx->curr_env = env;
3164 } else {
3165 // Otherwise evaluate the expression in the populated env
3166 ctx->curr_exp = sptr[0];
3167 ctx->curr_env = env;
3168 lbm_stack_drop(&ctx->K, 4);
3169 }
3170}
3171
3172static void cont_if(eval_context_t *ctx) {
3173
3174 lbm_value arg = ctx->r;
3175
3176 lbm_value *sptr = pop_stack_ptr(ctx, 2);
3177
3178 ctx->curr_env = sptr[1];
3179 if (lbm_is_symbol_nil(arg)) {
3180 ctx->curr_exp = get_cadr(sptr[0]); // else branch
3181 } else {
3182 ctx->curr_exp = get_car(sptr[0]); // then branch
3183 }
3184}
3185
3186static void cont_match(eval_context_t *ctx) {
3187 lbm_value e = ctx->r;
3188 bool_Bool do_gc = false0;
3189
3190 lbm_uint *sptr = get_stack_ptr(ctx, 2);
3191 lbm_value patterns = (lbm_value)sptr[0];
3192 lbm_value orig_env = (lbm_value)sptr[1]; // restore enclosing environment.
3193 lbm_value new_env = orig_env;
3194
3195 if (lbm_is_symbol_nil(patterns)) {
3196 // no more patterns
3197 lbm_stack_drop(&ctx->K, 2);
3198 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
3199 ctx->app_cont = true1;
3200 } else if (lbm_is_cons(patterns)) {
3201 lbm_value match_case = get_car(patterns);
3202 lbm_value pattern = get_car(match_case);
3203 lbm_value n1 = get_cadr(match_case);
3204 lbm_value n2 = get_cadr(get_cdr(match_case));
3205 lbm_value body;
3206 bool_Bool check_guard = false0;
3207 if (lbm_is_symbol_nil(n2)) { // TODO: Not a very robust check.
3208 body = n1;
3209 } else {
3210 body = n2;
3211 check_guard = true1;
3212 }
3213
3214 bool_Bool is_match = match(pattern, e, &new_env, &do_gc);
3215 if (do_gc) {
3216 gc();
3217 do_gc = false0;
3218 new_env = orig_env;
3219 is_match = match(pattern, e, &new_env, &do_gc);
3220 if (do_gc) {
3221 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3222 }
3223 }
3224 if (is_match) {
3225 if (check_guard) {
3226 lbm_value *rptr = stack_reserve(ctx,5);
3227 sptr[0] = get_cdr(patterns);
3228 sptr[1] = ctx->curr_env;
3229 rptr[0] = MATCH(((9) << 2) | 0xF8000001u);
3230 rptr[1] = new_env;
3231 rptr[2] = body;
3232 rptr[3] = e;
3233 rptr[4] = MATCH_GUARD(((27) << 2) | 0xF8000001u);
3234 ctx->curr_env = new_env;
3235 ctx->curr_exp = n1; // The guard
3236 } else {
3237 lbm_stack_drop(&ctx->K, 2);
3238 ctx->curr_env = new_env;
3239 ctx->curr_exp = body;
3240 }
3241 } else {
3242 // set up for checking of next pattern
3243 sptr[0] = get_cdr(patterns);
3244 sptr[1] = orig_env;
3245 stack_reserve(ctx,1)[0] = MATCH(((9) << 2) | 0xF8000001u);
3246 // leave r unaltered
3247 ctx->app_cont = true1;
3248 }
3249 } else {
3250 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MATCH(((0x108) << 4) | 0x00000000u));
3251 }
3252}
3253
3254static void cont_exit_atomic(eval_context_t *ctx) {
3255 is_atomic --;
3256 ctx->app_cont = true1;
3257}
3258
3259static void cont_map(eval_context_t *ctx) {
3260 lbm_value *sptr = get_stack_ptr(ctx, 6);
3261
3262 lbm_value ls = sptr[0];
3263 lbm_value env = sptr[1];
3264 lbm_value t = sptr[3];
3265 lbm_set_car(t, ctx->r); // update car field tailmost position.
3266 if (lbm_is_cons(ls)) {
3267 lbm_value next, rest;
3268 get_car_and_cdr(ls, &next, &rest);
3269 sptr[0] = rest;
3270 stack_reserve(ctx,1)[0] = MAP(((26) << 2) | 0xF8000001u);
3271 lbm_set_car(sptr[5], next); // new arguments
3272
3273 lbm_value elt = cons_with_gc(ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3274 lbm_set_cdr(t, elt);
3275 sptr[3] = elt; // (r1 ... rN . (nil . nil))
3276 ctx->curr_exp = sptr[4];
3277 ctx->curr_env = env;
3278 } else {
3279 ctx->r = sptr[2]; //head of result list
3280 ctx->curr_env = env;
3281 lbm_stack_drop(&ctx->K, 6);
3282 ctx->app_cont = true1;
3283 }
3284}
3285
3286static void cont_match_guard(eval_context_t *ctx) {
3287 if (lbm_is_symbol_nil(ctx->r)) {
3288 lbm_value e;
3289 lbm_pop(&ctx->K, &e);
3290 lbm_stack_drop(&ctx->K, 2);
3291 ctx->r = e;
3292 ctx->app_cont = true1;
3293 } else {
3294 lbm_value body;
3295 lbm_value env;
3296 lbm_stack_drop(&ctx->K, 1);
3297 lbm_pop_2(&ctx->K, &body, &env);
3298 lbm_stack_drop(&ctx->K, 3);
3299 ctx->curr_env = env;
3300 ctx->curr_exp = body;
3301 }
3302}
3303
3304static void cont_terminate(eval_context_t *ctx) {
3305 error_ctx(ctx->r);
3306}
3307
3308static void cont_loop(eval_context_t *ctx) {
3309 lbm_value *sptr = get_stack_ptr(ctx, 2);
3310 stack_reserve(ctx,1)[0] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
3311 ctx->curr_exp = sptr[1];
3312}
3313
3314static void cont_loop_condition(eval_context_t *ctx) {
3315 if (lbm_is_symbol_nil(ctx->r)) {
3316 lbm_stack_drop(&ctx->K, 2);
3317 ctx->app_cont = true1; // A loop returns nil? Makes sense to me... but in general?
3318 return;
3319 }
3320 lbm_value *sptr = get_stack_ptr(ctx, 2);
3321 stack_reserve(ctx,1)[0] = LOOP(((41) << 2) | 0xF8000001u);
3322 ctx->curr_exp = sptr[0];
3323}
3324
3325static void cont_merge_rest(eval_context_t *ctx) {
3326 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3327
3328 // If comparator returns true (result is in ctx->r):
3329 // "a" should be moved to the last element position in merged list.
3330 // A new element from "a_rest" should be moved into comparator argument 1 pos.
3331 // else
3332 // "b" should be moved to last element position in merged list.
3333 // A new element from "b_rest" should be moved into comparator argument 2 pos.
3334 //
3335 // If a_rest or b_rest is NIL:
3336 // we are done, the remaining elements of
3337 // non_nil list should be appended to merged list.
3338 // else
3339 // Set up for a new comparator evaluation and recurse.
3340 lbm_value a = sptr[2];
3341 lbm_value b = lbm_cdr(a);
3342 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate 1 element list
3343
3344 if (ctx->r == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) { // Comparison false
3345
3346 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3347 sptr[0] = b;
3348 sptr[1] = b;
3349 } else {
3350 lbm_set_cdr(sptr[1], b);
3351 sptr[1] = b;
3352 }
3353 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3354 lbm_set_cdr(a, sptr[3]);
3355 lbm_set_cdr(sptr[1], a);
3356 ctx->r = sptr[0];
3357 lbm_stack_drop(&ctx->K, 9);
3358 ctx->app_cont = true1;
3359 return;
3360 } else {
3361 b = sptr[4];
3362 sptr[4] = lbm_cdr(sptr[4]);
3363 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3364 }
3365 } else {
3366 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3367 sptr[0] = a;
3368 sptr[1] = a;
3369 } else {
3370 lbm_set_cdr(sptr[1], a);
3371 sptr[1] = a;
3372 }
3373
3374 if (sptr[3] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3375 lbm_set_cdr(b, sptr[4]);
3376 lbm_set_cdr(sptr[1], b);
3377 ctx->r = sptr[0];
3378 lbm_stack_drop(&ctx->K, 9);
3379 ctx->app_cont = true1;
3380 return;
3381 } else {
3382 a = sptr[3];
3383 sptr[3] = lbm_cdr(sptr[3]);
3384 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3385 }
3386 }
3387 lbm_set_cdr(a, b);
3388 sptr[2] = a;
3389
3390 lbm_value par1 = sptr[7];
3391 lbm_value par2 = sptr[8];
3392 lbm_value cmp_body = sptr[5];
3393 lbm_value cmp_env = sptr[6];
3394 // Environment should be preallocated already at this point
3395 // and the operations below should never need GC.
3396 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3397 lbm_value new_env = lbm_env_set(new_env0, par2, lbm_car(b));
3398 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3399 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3400 }
3401 cmp_env = new_env;
3402
3403 stack_reserve(ctx,1)[0] = MERGE_REST(((43) << 2) | 0xF8000001u);
3404 ctx->curr_exp = cmp_body;
3405 ctx->curr_env = cmp_env;
3406}
3407
3408// merge_layer stack contents
3409// s[sp-9] = cmp
3410// s[sp-8] = cmp_env
3411// s[sp-7] = par1
3412// s[sp-6] = par2
3413// s[sp-5] = acc - first cell
3414// s[sp-4] = acc - last cell
3415// s[sp-3] = rest;
3416// s[sp-2] = layer
3417// s[sp-1] = length or original list
3418//
3419// ctx->r merged sublist
3420static void cont_merge_layer(eval_context_t *ctx) {
3421 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3422 lbm_int layer = lbm_dec_i(sptr[7]);
3423 lbm_int len = lbm_dec_i(sptr[8]);
3424
3425 lbm_value r_curr = ctx->r;
3426 while (lbm_is_cons(r_curr)) {
3427 lbm_value next = lbm_cdr(r_curr);
3428 if (next == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3429 break;
3430 }
3431 r_curr = next;
3432 }
3433
3434 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3435 sptr[4] = ctx->r;
3436 sptr[5] = r_curr;
3437 } else {
3438 lbm_set_cdr(sptr[5], ctx->r); // accumulate merged sublists.
3439 sptr[5] = r_curr;
3440 }
3441
3442 lbm_value layer_rest = sptr[6];
3443 // switch layer or done ?
3444 if (layer_rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3445 if (layer * 2 >= len) {
3446 ctx->r = sptr[4];
3447 ctx->app_cont = true1;
3448 lbm_stack_drop(&ctx->K, 9);
3449 return;
3450 } else {
3451 // Setup for merges of the next layer
3452 layer = layer * 2;
3453 sptr[7] = lbm_enc_i(layer);
3454 layer_rest = sptr[4]; // continue on the accumulation of all sublists.
3455 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3456 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3457 }
3458 }
3459 // merge another sublist based on current layer.
3460 lbm_value a_list = layer_rest;
3461 // build sublist a
3462 lbm_value curr = layer_rest;
3463 for (int i = 0; i < layer-1; i ++) {
3464 if (lbm_is_cons(curr)) {
3465 curr = lbm_cdr(curr);
3466 } else {
3467 break;
3468 }
3469 }
3470 layer_rest = lbm_cdr(curr);
3471 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3472
3473 lbm_value b_list = layer_rest;
3474 // build sublist b
3475 curr = layer_rest;
3476 for (int i = 0; i < layer-1; i ++) {
3477 if (lbm_is_cons(curr)) {
3478 curr = lbm_cdr(curr);
3479 } else {
3480 break;
3481 }
3482 }
3483 layer_rest = lbm_cdr(curr);
3484 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3485
3486 sptr[6] = layer_rest;
3487
3488 if (b_list == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3489 stack_reserve(ctx,1)[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3490 ctx->r = a_list;
3491 ctx->app_cont = true1;
3492 return;
3493 }
3494 // Set up for a merge of sublists.
3495
3496 lbm_value a_rest = lbm_cdr(a_list);
3497 lbm_value b_rest = lbm_cdr(b_list);
3498 lbm_value a = a_list;
3499 lbm_value b = b_list;
3500 lbm_set_cdr(a, b);
3501 // Terminating the b list would be incorrect here
3502 // if there was any chance that the environment update below
3503 // performs GC.
3504 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3505
3506 lbm_value cmp_body = sptr[0];
3507 lbm_value cmp_env = sptr[1];
3508 lbm_value par1 = sptr[2];
3509 lbm_value par2 = sptr[3];
3510 // Environment should be preallocated already at this point
3511 // and the operations below should never need GC.
3512 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3513 lbm_value new_env = lbm_env_set(cmp_env, par2, lbm_car(b));
3514 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3515 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3516 }
3517 cmp_env = new_env;
3518
3519 lbm_uint *merge_cont = stack_reserve(ctx, 11);
3520 merge_cont[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3521 merge_cont[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3522 merge_cont[2] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3523 merge_cont[3] = a;
3524 merge_cont[4] = a_rest;
3525 merge_cont[5] = b_rest;
3526 merge_cont[6] = cmp_body;
3527 merge_cont[7] = cmp_env;
3528 merge_cont[8] = par1;
3529 merge_cont[9] = par2;
3530 merge_cont[10] = MERGE_REST(((43) << 2) | 0xF8000001u);
3531 ctx->curr_exp = cmp_body;
3532 ctx->curr_env = cmp_env;
3533 return;
3534}
3535
3536/****************************************************/
3537/* READER */
3538
3539static void read_finish(lbm_char_channel_t *str, eval_context_t *ctx) {
3540
3541 /* Tokenizer reached "end of file"
3542 The parser could be in a state where it needs
3543 more tokens to correctly finish an expression.
3544
3545 Three cases
3546 1. The program / expression is malformed and the context should die.
3547 2. We are finished reading a program and should close off the
3548 internal representation with a closing parenthesis. Then
3549 apply continuation.
3550 3. We are finished reading an expression and should
3551 apply the continuation.
3552
3553 In case 3, we should find the READ_DONE at sp - 1.
3554 In case 2, we should find the READ_DONE at sp - 5.
3555
3556 */
3557
3558 if (lbm_is_symbol(ctx->r)) {
3559 lbm_uint sym_val = lbm_dec_sym(ctx->r);
3560 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
3561 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
3562 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3563 }
3564 }
3565
3566 if (ctx->K.data[ctx->K.sp-1] == READ_DONE(((20) << 2) | 0xF8000001u) &&
3567 lbm_dec_u(ctx->K.data[ctx->K.sp-3]) == 0) {
3568 /* successfully finished reading an expression (CASE 3) */
3569 ctx->app_cont = true1;
3570 } else if (ctx->K.sp > 4 && ctx->K.data[ctx->K.sp - 4] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3571 lbm_value env;
3572 lbm_value s;
3573 lbm_value sym;
3574 lbm_pop_3(&ctx->K, &sym, &env, &s);
3575 ctx->curr_env = env;
3576 ctx->app_cont = true1; // Program evaluated and result is in ctx->r.
3577 } else if (ctx->K.sp > 5 && ctx->K.data[ctx->K.sp - 5] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3578 /* successfully finished reading a program (CASE 2) */
3579 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3580 ctx->app_cont = true1;
3581 } else {
3582 /* Parsing failed */
3583 if (lbm_channel_row(str) == 1 &&
3584 lbm_channel_column(str) == 1 ){
3585 // eof at empty stream.
3586 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3587 ctx->app_cont = true1;
3588 } else {
3589 lbm_set_error_reason((char*)lbm_error_str_parse_eof);
3590 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3591 }
3592 lbm_channel_reader_close(str);
3593 }
3594}
3595
3596/* cont_read_next_token
3597 sp-2 : Stream
3598 sp-1 : Grab row
3599*/
3600static void cont_read_next_token(eval_context_t *ctx) {
3601 lbm_value *sptr = get_stack_ptr(ctx, 2);
3602 lbm_value stream = sptr[0];
3603 lbm_value grab_row0 = sptr[1];
3604
3605 lbm_char_channel_t *chan = lbm_dec_channel(stream);
3606 if (chan == NULL((void*)0) || chan->state == NULL((void*)0)) {
3607 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3608 }
3609
3610 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3611 lbm_stack_drop(&ctx->K, 2);
3612 read_finish(chan, ctx);
3613 return;
3614 }
3615 /* Eat whitespace and comments */
3616 if (!tok_clean_whitespace(chan)) {
3617 sptr[0] = stream;
3618 sptr[1] = lbm_enc_u(0);
3619 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3620 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3621 return;
3622 }
3623 /* After eating whitespace we may be at end of file/stream */
3624 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3625 lbm_stack_drop(&ctx->K, 2);
3626 read_finish(chan, ctx);
3627 return;
3628 }
3629
3630 if (lbm_dec_u(grab_row0)) {
3631 ctx->row0 = (int32_t)lbm_channel_row(chan);
3632 }
3633
3634 /* Attempt to extract tokens from the character stream */
3635 int n = 0;
3636 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3637 unsigned int string_len = 0;
3638
3639 /*
3640 * SYNTAX
3641 */
3642 uint32_t match;
3643 n = tok_syntax(chan, &match);
3644 if (n > 0) {
3645 if (!lbm_channel_drop(chan, (unsigned int)n)) {
3646 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3647 }
3648 ctx->app_cont = true1;
3649 lbm_uint do_next = 0;
3650 switch(match) {
3651 case TOKOPENPAR1u: {
3652 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3653 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3654 lbm_value *rptr = stack_reserve(ctx,5);
3655 rptr[0] = stream;
3656 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3657 rptr[2] = stream;
3658 rptr[3] = lbm_enc_u(0);
3659 rptr[4] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3660 ctx->r = ENC_SYM_OPENPAR(((0x70) << 4) | 0x00000000u);
3661 } return;
3662 case TOKCLOSEPAR2u: {
3663 lbm_stack_drop(&ctx->K, 2);
3664 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3665 } return;
3666 case TOKOPENBRACK3u: {
3667 sptr[0] = stream;
3668 sptr[1] = READ_START_ARRAY(((24) << 2) | 0xF8000001u);
3669 lbm_value *rptr = stack_reserve(ctx, 3);
3670 rptr[0] = stream;
3671 rptr[1] = lbm_enc_u(0);
3672 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3673 ctx->r = ENC_SYM_OPENBRACK(((0x80) << 4) | 0x00000000u);
3674 } return;
3675 case TOKCLOSEBRACK4u:
3676 lbm_stack_drop(&ctx->K, 2);
3677 ctx->r = ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u);
3678 return;
3679 case TOKDOT5u:
3680 lbm_stack_drop(&ctx->K, 2);
3681 ctx->r = ENC_SYM_DOT(((0x76) << 4) | 0x00000000u);
3682 return;
3683 case TOKDONTCARE6u:
3684 lbm_stack_drop(&ctx->K, 2);
3685 ctx->r = ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u);
3686 return;
3687 case TOKQUOTE7u:
3688 do_next = READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u);
3689 break;
3690 case TOKBACKQUOTE8u: {
3691 sptr[0] = QQ_EXPAND_START(((35) << 2) | 0xF8000001u);
3692 sptr[1] = stream;
3693 lbm_value *rptr = stack_reserve(ctx, 2);
3694 rptr[0] = lbm_enc_u(0);
3695 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3696 ctx->app_cont = true1;
3697 } return;
3698 case TOKCOMMAAT9u:
3699 do_next = READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u);
3700 break;
3701 case TOKCOMMA10u:
3702 do_next = READ_COMMA_RESULT(((23) << 2) | 0xF8000001u);
3703 break;
3704 case TOKMATCHANY11u:
3705 lbm_stack_drop(&ctx->K, 2);
3706 ctx->r = ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u);
3707 return;
3708 case TOKOPENCURL12u: {
3709 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3710 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3711 lbm_value *rptr = stack_reserve(ctx,2);
3712 rptr[0] = stream;
3713 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3714 ctx->r = ENC_SYM_PROGN(((0x102) << 4) | 0x00000000u);
3715 } return;
3716 case TOKCLOSECURL13u:
3717 lbm_stack_drop(&ctx->K, 2);
3718 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3719 return;
3720 case TOKCONSTSTART14u: /* fall through */
3721 case TOKCONSTEND15u:
3722 case TOKCONSTSYMSTR16u: {
3723 if (match == TOKCONSTSTART14u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3724 if (match == TOKCONSTEND15u) ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3725 if (match == TOKCONSTSYMSTR16u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04;
3726 sptr[0] = stream;
3727 sptr[1] = lbm_enc_u(0);
3728 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3729 ctx->app_cont = true1;
3730 } return;
3731 default:
3732 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3733 }
3734 sptr[0] = do_next;
3735 sptr[1] = stream;
3736 lbm_value *rptr = stack_reserve(ctx, 2);
3737 rptr[0] = lbm_enc_u(0);
3738 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3739 ctx->app_cont = true1;
3740 return;
3741 } else if (n < 0) goto retry_token;
3742
3743 /*
3744 * STRING
3745 */
3746 n = tok_string(chan, &string_len);
3747 if (n >= 2) {
3748 lbm_channel_drop(chan, (unsigned int)n);
3749 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3750 gc();
3751 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3752 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3753 return; // dead return but static analysis does not know that.
3754 }
3755 }
3756 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(res);
3757 char *data = (char*)arr->data;
3758 memset(data,0, string_len + 1);
3759 memcpy(data, tokpar_sym_str, string_len);
3760 lbm_stack_drop(&ctx->K, 2);
3761 ctx->r = res;
3762 ctx->app_cont = true1;
3763 return;
3764 } else if (n < 0) goto retry_token;
3765
3766 /*
3767 * FLOAT
3768 */
3769 token_float f_val;
3770 n = tok_double(chan, &f_val);
3771 if (n > 0) {
3772 lbm_channel_drop(chan, (unsigned int) n);
3773 switch(f_val.type) {
3774 case TOKTYPEF32107u:
3775 WITH_GC(res, lbm_enc_float((float)f_val.value))(res) = (lbm_enc_float((float)f_val.value)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (lbm_enc_float((float)f_val.value));
if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
3776 break;
3777 case TOKTYPEF64108u:
3778 res = lbm_enc_double(f_val.value);
3779 break;
3780 default:
3781 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3782 }
3783 lbm_stack_drop(&ctx->K, 2);
3784 ctx->r = res;
3785 ctx->app_cont = true1;
3786 return;
3787 } else if (n < 0) goto retry_token;
3788
3789 /*
3790 * INTEGER
3791 */
3792 token_int int_result;
3793 n = tok_integer(chan, &int_result);
3794 if (n > 0) {
3795 lbm_channel_drop(chan, (unsigned int)n);
3796 switch(int_result.type) {
3797 case TOKTYPEBYTE100u:
3798 res = lbm_enc_char((uint8_t)(int_result.negative ? -int_result.value : int_result.value));
3799 break;
3800 case TOKTYPEI101u:
3801 res = lbm_enc_i((lbm_int)(int_result.negative ? -int_result.value : int_result.value));
3802 break;
3803 case TOKTYPEU102u:
3804 res = lbm_enc_u((lbm_uint)(int_result.negative ? -int_result.value : int_result.value));
3805 break;
3806 case TOKTYPEI32103u:
3807 WITH_GC(res, lbm_enc_i32((int32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i32((int32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i32((int32_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3808 break;
3809 case TOKTYPEU32104u:
3810 WITH_GC(res,lbm_enc_u32((uint32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u32((uint32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u32((uint32_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3811 break;
3812 case TOKTYPEI64105u:
3813 WITH_GC(res,lbm_enc_i64((int64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i64((int64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i64((int64_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3814 break;
3815 case TOKTYPEU64106u:
3816 WITH_GC(res,lbm_enc_u64((uint64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u64((uint64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u64((uint64_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3817 break;
3818 default:
3819 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3820 }
3821 lbm_stack_drop(&ctx->K, 2);
3822 ctx->r = res;
3823 ctx->app_cont = true1;
3824 return;
3825 } else if (n < 0) goto retry_token;
3826
3827 /*
3828 * SYMBOL
3829 */
3830 n = tok_symbol(chan);
3831 if (n > 0) {
3832 lbm_channel_drop(chan, (unsigned int) n);
3833 lbm_uint symbol_id;
3834 if (lbm_get_symbol_by_name(tokpar_sym_str, &symbol_id)) {
3835 res = lbm_enc_sym(symbol_id);
3836 } else {
3837 int r = 0;
3838 if (n > 4 &&
3839 tokpar_sym_str[0] == 'e' &&
3840 tokpar_sym_str[1] == 'x' &&
3841 tokpar_sym_str[2] == 't' &&
3842 tokpar_sym_str[3] == '-') {
3843 lbm_uint ext_id;
3844 lbm_uint ext_name_len = (lbm_uint)n + 1;
3845 char *ext_name = lbm_malloc(ext_name_len);
3846 if (!ext_name) {
3847 gc();
3848 ext_name = lbm_malloc(ext_name_len);
3849 }
3850 if (ext_name) {
3851 memcpy(ext_name, tokpar_sym_str, ext_name_len);
3852 r = lbm_add_extension(ext_name, lbm_extensions_default);
3853 if (!lbm_lookup_extension_id(ext_name, &ext_id)) {
3854 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3855 }
3856 symbol_id = ext_id;
3857 } else {
3858 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3859 }
3860 } else {
3861 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04 &&
3862 ctx->flags & EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08) {
3863 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id, true1); //flash
3864 if (!r) {
3865 lbm_set_error_reason((char*)lbm_error_str_flash_error);
3866 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3867 }
3868 } else {
3869 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3870 if (!r) {
3871 gc();
3872 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3873 }
3874 }
3875 }
3876 if (r) {
3877 res = lbm_enc_sym(symbol_id);
3878 } else {
3879 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3880 }
3881 }
3882 lbm_stack_drop(&ctx->K, 2);
3883 ctx->r = res;
3884 ctx->app_cont = true1;
3885 return;
3886 } else if (n == TOKENIZER_NEED_MORE-1) {
3887 goto retry_token;
3888 } else if (n <= TOKENIZER_STRING_ERROR-2) {
3889 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3890 }
3891
3892 /*
3893 * CHAR
3894 */
3895 char c_val;
3896 n = tok_char(chan, &c_val);
3897 if(n > 0) {
3898 lbm_channel_drop(chan,(unsigned int) n);
3899 lbm_stack_drop(&ctx->K, 2);
3900 ctx->r = lbm_enc_char((uint8_t)c_val);
3901 ctx->app_cont = true1;
3902 return;
3903 }else if (n < 0) goto retry_token;
3904
3905 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3906
3907 retry_token:
3908 if (n == TOKENIZER_NEED_MORE-1) {
3909 sptr[0] = stream;
3910 sptr[1] = lbm_enc_u(0);
3911 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3912 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3913 return;
3914 }
3915 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3916}
3917
3918static void cont_read_start_array(eval_context_t *ctx) {
3919 lbm_value *sptr = get_stack_ptr(ctx, 1);
3920 lbm_value stream = sptr[0];
3921
3922 lbm_char_channel_t *str = lbm_dec_channel(stream);
3923 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
3924 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3925 }
3926
3927 lbm_uint num_free = lbm_memory_longest_free();
3928 lbm_uint initial_size = (lbm_uint)((float)num_free * 0.9);
3929 if (initial_size == 0) {
3930 gc();
3931 num_free = lbm_memory_longest_free();
3932 initial_size = (lbm_uint)((float)num_free * 0.9);
3933 if (initial_size == 0) {
3934 lbm_channel_reader_close(str);
3935 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3936 }
3937 }
3938
3939 if (lbm_is_number(ctx->r)) {
3940 lbm_value array;
3941 initial_size = sizeof(lbm_uint) * initial_size;
3942
3943 if (!lbm_heap_allocate_array(&array, initial_size)) {
3944 lbm_set_error_reason("Out of memory while reading.");
3945 lbm_channel_reader_close(str);
3946 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3947 // NOTE: If array is not created evaluation ends here.
3948 // Static analysis seems unaware.
3949 }
3950
3951 sptr[0] = array;
3952 lbm_value *rptr = stack_reserve(ctx, 4);
3953 rptr[0] = lbm_enc_u(initial_size);
3954 rptr[1] = lbm_enc_u(0);
3955 rptr[2] = stream;
3956 rptr[3] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3957 ctx->app_cont = true1;
3958 } else {
3959 lbm_channel_reader_close(str);
3960 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3961 }
3962}
3963
3964static void cont_read_append_array(eval_context_t *ctx) {
3965 lbm_uint *sptr = get_stack_ptr(ctx, 4);
3966
3967 lbm_value array = sptr[0];
3968 lbm_value size = lbm_dec_as_u32(sptr[1]);
3969 lbm_value ix = lbm_dec_as_u32(sptr[2]);
3970 lbm_value stream = sptr[3];
3971
3972 if (ix >= (size - 1)) {
3973 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3974 }
3975
3976 // get_car can return nil. Whose value is 0!
3977 // So static Analysis is right about this being a potential NULL pointer.
3978 // However, if the array was created correcly to begin with, it should be fine.
3979 lbm_value arr_car = get_car(array);
3980 lbm_array_header_t *arr = (lbm_array_header_t*)arr_car;
3981
3982 if (lbm_is_number(ctx->r)) {
3983 ((uint8_t*)arr->data)[ix] = (uint8_t)lbm_dec_as_u32(ctx->r);
3984
3985 sptr[2] = lbm_enc_u(ix + 1);
3986 lbm_value *rptr = stack_reserve(ctx, 4);
3987 rptr[0] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3988 rptr[1] = stream;
3989 rptr[2] = lbm_enc_u(0);
3990 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3991 ctx->app_cont = true1;
3992 } else if (lbm_is_symbol(ctx->r) && ctx->r == ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u)) {
3993 lbm_uint array_size = ix / sizeof(lbm_uint);
3994
3995 if (ix % sizeof(lbm_uint) != 0) {
3996 array_size = array_size + 1;
3997 }
3998 lbm_memory_shrink((lbm_uint*)arr->data, array_size);
3999 arr->size = ix;
4000 lbm_stack_drop(&ctx->K, 4);
4001 ctx->r = array;
4002 ctx->app_cont = true1;
4003 } else {
4004 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
4005 }
4006}
4007
4008static void cont_read_append_continue(eval_context_t *ctx) {
4009 lbm_value *sptr = get_stack_ptr(ctx, 3);
4010
4011 lbm_value first_cell = sptr[0];
4012 lbm_value last_cell = sptr[1];
4013 lbm_value stream = sptr[2];
4014
4015 lbm_char_channel_t *str = lbm_dec_channel(stream);
4016 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4017 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4018 }
4019
4020 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4021
4022 switch(ctx->r) {
4023 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4024 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4025 lbm_set_cdr(last_cell, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate the list
4026 ctx->r = first_cell;
4027 } else {
4028 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4029 }
4030 lbm_stack_drop(&ctx->K, 3);
4031 /* Skip reading another token and apply the continuation */
4032 ctx->app_cont = true1;
4033 return;
4034 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4035 lbm_value *rptr = stack_reserve(ctx, 4);
4036 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4037 rptr[1] = stream;
4038 rptr[2] = lbm_enc_u(0);
4039 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4040 ctx->app_cont = true1;
4041 } return;
4042 }
4043 }
4044 lbm_value new_cell = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4045 if (lbm_is_symbol_merror(new_cell)) {
4046 lbm_channel_reader_close(str);
4047 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4048 return;
4049 }
4050 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4051 lbm_set_cdr(last_cell, new_cell);
4052 last_cell = new_cell;
4053 } else {
4054 first_cell = last_cell = new_cell;
4055 }
4056 sptr[0] = first_cell;
4057 sptr[1] = last_cell;
4058 sptr[2] = stream; // unchanged.
4059 lbm_value *rptr = stack_reserve(ctx, 4);
4060 rptr[0] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
4061 rptr[1] = stream;
4062 rptr[2] = lbm_enc_u(0);
4063 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4064 ctx->app_cont = true1;
4065}
4066
4067static void cont_read_eval_continue(eval_context_t *ctx) {
4068 lbm_value env;
4069 lbm_value stream;
4070 lbm_pop_2(&ctx->K, &env, &stream);
4071
4072 lbm_char_channel_t *str = lbm_dec_channel(stream);
4073 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4074 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4075 }
4076
4077 ctx->row1 = (lbm_int)str->row(str);
4078
4079 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4080
4081 switch(ctx->r) {
4082 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4083 ctx->app_cont = true1;
4084 return;
4085 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4086 // This case is a bit mysterious.
4087 // A dot, may in reality be an error in this location.
4088 lbm_value *rptr = stack_reserve(ctx, 4);
4089 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4090 rptr[1] = stream;
4091 rptr[2] = lbm_enc_u(0);
4092 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4093 ctx->app_cont = true1;
4094 } return;
4095 }
4096 }
4097
4098 lbm_value *rptr = stack_reserve(ctx, 6);
4099 rptr[0] = stream;
4100 rptr[1] = env;
4101 rptr[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
4102 rptr[3] = stream;
4103 rptr[4] = lbm_enc_u(1);
4104 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4105 rptr[6] = lbm_enc_u(ctx->flags);
4106 rptr[7] = POP_READER_FLAGS(((47) << 2) | 0xF8000001u);
4107 ctx->curr_env = env;
4108 ctx->curr_exp = ctx->r;
4109}
4110
4111static void cont_read_expect_closepar(eval_context_t *ctx) {
4112 lbm_value res;
4113 lbm_value stream;
4114
4115 lbm_pop_2(&ctx->K, &res, &stream);
4116
4117 lbm_char_channel_t *str = lbm_dec_channel(stream);
4118 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4119 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4120 }
4121
4122 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4123 ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u)) {
4124 ctx->r = res;
4125 ctx->app_cont = true1;
4126 } else {
4127 lbm_channel_reader_close(str);
4128 lbm_set_error_reason((char*)lbm_error_str_parse_close);
4129 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4130 }
4131}
4132
4133static void cont_read_dot_terminate(eval_context_t *ctx) {
4134 lbm_value *sptr = get_stack_ptr(ctx, 3);
4135
4136 lbm_value first_cell = sptr[0];
4137 lbm_value last_cell = sptr[1];
4138 lbm_value stream = sptr[2];
4139
4140 lbm_char_channel_t *str = lbm_dec_channel(stream);
4141 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4142 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4143 }
4144
4145 lbm_stack_drop(&ctx->K ,3);
4146
4147 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4148 (ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u) ||
4149 ctx->r == ENC_SYM_DOT(((0x76) << 4) | 0x00000000u))) {
4150 lbm_channel_reader_close(str);
4151 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4152 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4153 } else {
4154 if (lbm_is_cons(last_cell)) {
4155 lbm_set_cdr(last_cell, ctx->r);
4156 ctx->r = first_cell;
4157 lbm_value *rptr = stack_reserve(ctx, 6);
4158 rptr[0] = stream;
4159 rptr[1] = ctx->r;
4160 rptr[2] = READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u);
4161 rptr[3] = stream;
4162 rptr[4] = lbm_enc_u(0);
4163 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4164 ctx->app_cont = true1;
4165 } else {
4166 lbm_channel_reader_close(str);
4167 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4168 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4169 }
4170 }
4171}
4172
4173static void cont_read_done(eval_context_t *ctx) {
4174 lbm_value stream;
4175 lbm_value f_val;
4176 lbm_pop_2(&ctx->K, &stream ,&f_val);
4177
4178 uint32_t flags = lbm_dec_as_u32(f_val);
4179 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4180 ctx->flags |= (flags & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4181
4182 lbm_char_channel_t *str = lbm_dec_channel(stream);
4183 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4184 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4185 }
4186
4187 lbm_channel_reader_close(str);
4188 if (lbm_is_symbol(ctx->r)) {
4189 lbm_uint sym_val = lbm_dec_sym(ctx->r);
4190 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
4191 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
4192 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4193 }
4194 }
4195
4196 ctx->row0 = -1;
4197 ctx->row1 = -1;
4198 ctx->app_cont = true1;
4199}
4200
4201static void cont_read_quote_result(eval_context_t *ctx) {
4202 lbm_value cell;
4203 WITH_GC(cell, lbm_heap_allocate_list_init(2,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4204 ENC_SYM_QUOTE,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4205 ctx->r))(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
};
4206 ctx->r = cell;
4207 ctx->app_cont = true1;
4208}
4209
4210static void cont_read_commaat_result(eval_context_t *ctx) {
4211 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4212 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4213 ctx->r = cell1;
4214 ctx->app_cont = true1;
4215}
4216
4217static void cont_read_comma_result(eval_context_t *ctx) {
4218 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u),ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4219 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4220 ctx->r = cell1;
4221 ctx->app_cont = true1;
4222}
4223
4224static void cont_application_start(eval_context_t *ctx) {
4225
4226 /* sptr[0] = env
4227 * sptr[1] = args
4228 * ctx->r = function
4229 */
4230
4231 if (lbm_is_symbol(ctx->r)) {
4232 stack_reserve(ctx,1)[0] = lbm_enc_u(0);
4233 cont_application_args(ctx);
4234 } else if (lbm_is_cons(ctx->r)) {
4235 lbm_uint *sptr = get_stack_ptr(ctx, 2);
4236 lbm_value args = (lbm_value)sptr[1];
4237 switch (get_car(ctx->r)) {
4238 case ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u): {
4239 lbm_value cl[3];
4240 extract_n(get_cdr(ctx->r), cl, 3);
4241 lbm_value arg_env = (lbm_value)sptr[0];
4242 lbm_value arg0, arg_rest;
4243 get_car_and_cdr(args, &arg0, &arg_rest);
4244 sptr[1] = cl[CLO_BODY1];
4245 bool_Bool a_nil = lbm_is_symbol_nil(args);
4246 bool_Bool p_nil = lbm_is_symbol_nil(cl[CLO_PARAMS0]);
4247 lbm_value *reserved = stack_reserve(ctx, 4);
4248
4249 if (!a_nil && !p_nil) {
4250 reserved[0] = cl[CLO_ENV2];
4251 reserved[1] = cl[CLO_PARAMS0];
4252 reserved[2] = arg_rest;
4253 reserved[3] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
4254 ctx->curr_exp = arg0;
4255 ctx->curr_env = arg_env;
4256 } else if (a_nil && p_nil) {
4257 // No params, No args
4258 lbm_stack_drop(&ctx->K, 6);
4259 ctx->curr_exp = cl[CLO_BODY1];
4260 ctx->curr_env = cl[CLO_ENV2];
4261 } else if (p_nil) {
4262 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), cl[CLO_ENV2]);
4263 reserved[0] = rest_binder;
4264 reserved[1] = get_cdr(args);
4265 reserved[2] = get_car(rest_binder);
4266 reserved[3] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
4267 ctx->curr_exp = get_car(args);
4268 ctx->curr_env = arg_env;
4269 } else {
4270 lbm_set_error_reason((char*)lbm_error_str_num_args);
4271 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->r);
4272 }
4273 } break;
4274 case ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u):{
4275 /* Continuation created using call-cc.
4276 * ((SYM_CONT . cont-array) arg0 )
4277 */
4278 lbm_value c = get_cdr(ctx->r); /* should be the continuation array*/
4279
4280 if (!lbm_is_lisp_array_r(c)) {
4281 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4282 }
4283
4284 lbm_uint arg_count = lbm_list_length(args);
4285 lbm_value arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4286 switch (arg_count) {
4287 case 0:
4288 arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4289 break;
4290 case 1:
4291 arg = get_car(args);
4292 break;
4293 default:
4294 lbm_set_error_reason((char*)lbm_error_str_num_args);
4295 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4296 }
4297 lbm_stack_clear(&ctx->K);
4298
4299 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(c);
4300
4301 ctx->K.sp = arr->size / sizeof(lbm_uint);
4302 memcpy(ctx->K.data, arr->data, arr->size);
4303
4304 ctx->curr_exp = arg;
4305 break;
4306 }
4307 case ENC_SYM_MACRO(((0x10D) << 4) | 0x00000000u):{
4308 /*
4309 * Perform macro expansion.
4310 * Macro expansion is really just evaluation in an
4311 * environment augmented with the unevaluated expressions passed
4312 * as arguments.
4313 */
4314 lbm_value env = (lbm_value)sptr[0];
4315
4316 lbm_value curr_param = get_cadr(ctx->r);
4317 lbm_value curr_arg = args;
4318 lbm_value expand_env = env;
4319 while (lbm_is_cons(curr_param) &&
4320 lbm_is_cons(curr_arg)) {
4321 lbm_value car_curr_param, cdr_curr_param;
4322 lbm_value car_curr_arg, cdr_curr_arg;
4323 get_car_and_cdr(curr_param, &car_curr_param, &cdr_curr_param);
4324 get_car_and_cdr(curr_arg, &car_curr_arg, &cdr_curr_arg);
4325
4326 lbm_value entry = cons_with_gc(car_curr_param, car_curr_arg, expand_env);
4327 lbm_value aug_env = cons_with_gc(entry, expand_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4328 expand_env = aug_env;
4329
4330 curr_param = cdr_curr_param;
4331 curr_arg = cdr_curr_arg;
4332 }
4333 /* Two rounds of evaluation is performed.
4334 * First to instantiate the arguments into the macro body.
4335 * Second to evaluate the resulting program.
4336 */
4337 sptr[1] = EVAL_R(((11) << 2) | 0xF8000001u);
4338 lbm_value exp = get_cadr(get_cdr(ctx->r));
4339 ctx->curr_exp = exp;
4340 ctx->curr_env = expand_env;
4341 } break;
4342 default:
4343 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4344 }
4345 } else {
4346 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4347 }
4348}
4349
4350static void cont_eval_r(eval_context_t* ctx) {
4351 lbm_value env;
4352 lbm_pop(&ctx->K, &env);
4353 ctx->curr_exp = ctx->r;
4354 ctx->curr_env = env;
4355}
4356
4357static void cont_progn_var(eval_context_t* ctx) {
4358
4359 lbm_value key;
4360 lbm_value env;
4361
4362 lbm_pop_2(&ctx->K, &key, &env);
4363
4364 if (fill_binding_location(key, ctx->r, env) < 0) {
4365 lbm_set_error_reason("Incorrect type of name/key in let-binding");
4366 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
4367 }
4368
4369 ctx->app_cont = true1;
4370}
4371
4372static void cont_setq(eval_context_t *ctx) {
4373 lbm_value sym;
4374 lbm_value env;
4375 lbm_pop_2(&ctx->K, &sym, &env);
4376 lbm_value res;
4377 WITH_GC(res, perform_setvar(sym, ctx->r, env))(res) = (perform_setvar(sym, ctx->r, env)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (perform_setvar(sym, ctx->r, env)
); if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
4378 ctx->r = res;
4379 ctx->app_cont = true1;
4380}
4381
4382lbm_flash_status request_flash_storage_cell(lbm_value val, lbm_value *res) {
4383
4384 lbm_value flash_cell;
4385 lbm_flash_status s = lbm_allocate_const_cell(&flash_cell);
4386 if (s != LBM_FLASH_WRITE_OK)
4387 return s;
4388 lbm_value new_val = val;
4389 new_val &= ~LBM_PTR_VAL_MASK0x03FFFFFCu; // clear the value part of the ptr
4390 new_val |= (flash_cell & LBM_PTR_VAL_MASK0x03FFFFFCu);
4391 new_val |= LBM_PTR_TO_CONSTANT_BIT0x04000000u;
4392 *res = new_val;
4393 return s;
4394}
4395
4396static void cont_move_to_flash(eval_context_t *ctx) {
4397
4398 lbm_value args;
4399 lbm_pop(&ctx->K, &args);
4400
4401 if (lbm_is_symbol_nil(args)) {
4402 // Done looping over arguments. return true.
4403 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
4404 ctx->app_cont = true1;
4405 return;
4406 }
4407
4408 lbm_value first_arg, rest;
4409 get_car_and_cdr(args, &first_arg, &rest);
4410
4411 lbm_value val;
4412 if (lbm_is_symbol(first_arg) && lbm_global_env_lookup(&val, first_arg)) {
4413 // Prepare to copy the rest of the arguments when done with first.
4414 lbm_value *rptr = stack_reserve(ctx, 2);
4415 rptr[0] = rest;
4416 rptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
4417 if (lbm_is_ptr(val) &&
4418 (!(val & LBM_PTR_TO_CONSTANT_BIT0x04000000u))) {
4419 lbm_value * rptr1 = stack_reserve(ctx, 3);
4420 rptr1[0] = first_arg;
4421 rptr1[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
4422 rptr1[2] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4423 ctx->r = val;
4424 }
4425 ctx->app_cont = true1;
4426 return;
4427 }
4428 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4429}
4430
4431static void cont_move_val_to_flash_dispatch(eval_context_t *ctx) {
4432
4433 lbm_value val = ctx->r;
4434
4435 if (lbm_is_cons(val)) {
4436 lbm_value *rptr = stack_reserve(ctx, 5);
4437 rptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // fst cell of list
4438 rptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last cell of list
4439 rptr[2] = get_cdr(val);
4440 rptr[3] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4441 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4442 ctx->r = get_car(val);
4443 ctx->app_cont = true1;
4444 return;
4445 }
4446
4447 if (lbm_is_ptr(val) && (val & LBM_PTR_TO_CONSTANT_BIT0x04000000u)) {
4448 ctx->r = val;
4449 ctx->app_cont = true1;
4450 return;
4451 }
4452
4453 if (lbm_is_ptr(val)) {
4454 lbm_cons_t *ref = lbm_ref_cell(val);
4455 if (lbm_type_of(ref->cdr) == LBM_TYPE_SYMBOL0x00000000u) {
4456 switch (ref->cdr) {
4457 case ENC_SYM_RAW_I_TYPE(((0x31) << 4) | 0x00000000u): /* fall through */
4458 case ENC_SYM_RAW_U_TYPE(((0x32) << 4) | 0x00000000u):
4459 case ENC_SYM_RAW_F_TYPE(((0x33) << 4) | 0x00000000u): {
4460 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4461 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4462 handle_flash_status(write_const_car(flash_cell, ref->car));
4463 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4464 ctx->r = flash_cell;
4465 } break;
4466 case ENC_SYM_IND_I_TYPE(((0x34) << 4) | 0x00000000u): /* fall through */
4467 case ENC_SYM_IND_U_TYPE(((0x35) << 4) | 0x00000000u):
4468 case ENC_SYM_IND_F_TYPE(((0x36) << 4) | 0x00000000u): {
4469#ifndef LBM64
4470 /* 64 bit values are in lbm mem on 32bit platforms. */
4471 lbm_uint *lbm_mem_ptr = (lbm_uint*)ref->car;
4472 lbm_uint flash_ptr;
4473
4474 handle_flash_status(lbm_write_const_raw(lbm_mem_ptr, 2, &flash_ptr));
4475 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4476 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4477 handle_flash_status(write_const_car(flash_cell, flash_ptr));
4478 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4479 ctx->r = flash_cell;
4480#else
4481 // There are no indirect types in LBM64
4482 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4483#endif
4484 } break;
4485 case ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u): {
4486 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4487 lbm_uint size = arr->size / sizeof(lbm_uint);
4488 lbm_uint flash_addr;
4489 lbm_value *arrdata = (lbm_value *)arr->data;
4490 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4491 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4492 handle_flash_status(lbm_allocate_const_raw(size, &flash_addr));
4493 lift_array_flash(flash_cell,
4494 false0,
4495 (char *)flash_addr,
4496 arr->size);
4497 // Move array contents to flash recursively
4498 lbm_value *rptr = stack_reserve(ctx, 5);
4499 rptr[0] = flash_cell;
4500 rptr[1] = lbm_enc_u(0);
4501 rptr[2] = val;
4502 rptr[3] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4503 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4504 ctx->r = arrdata[0];
4505 ctx->app_cont = true1;
4506 return;
4507 }
4508 case ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u): {
4509 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4510 // arbitrary address: flash_arr.
4511 lbm_uint flash_arr;
4512 handle_flash_status(lbm_write_const_array_padded((uint8_t*)arr->data, arr->size, &flash_arr));
4513 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4514 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4515 lift_array_flash(flash_cell,
4516 true1,
4517 (char *)flash_arr,
4518 arr->size);
4519 ctx->r = flash_cell;
4520 } break;
4521 case ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u): /* fall through */
4522 case ENC_SYM_CUSTOM_TYPE(((0x38) << 4) | 0x00000000u):
4523 lbm_set_error_reason((char *)lbm_error_str_flash_not_possible);
4524 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4525 }
4526 } else {
4527 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4528 }
4529 ctx->app_cont = true1;
4530 return;
4531 }
4532 ctx->r = val;
4533 ctx->app_cont = true1;
4534}
4535
4536static void cont_move_list_to_flash(eval_context_t *ctx) {
4537
4538 // ctx->r holds the value that should go in car
4539
4540 lbm_value *sptr = get_stack_ptr(ctx, 3);
4541
4542 lbm_value fst = sptr[0];
4543 lbm_value lst = sptr[1];
4544 lbm_value val = sptr[2];
4545
4546
4547 lbm_value new_lst = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4548 // Allocate element ptr storage after storing the element to flash.
4549 handle_flash_status(request_flash_storage_cell(lbm_enc_cons_ptr(LBM_PTR_NULL(0x03FFFFFCu >> 2)), &new_lst));
4550
4551 if (lbm_is_symbol_nil(fst)) {
4552 lst = new_lst;
4553 fst = new_lst;
4554 handle_flash_status(write_const_car(lst, ctx->r));
4555 } else {
4556 handle_flash_status(write_const_cdr(lst, new_lst)); // low before high
4557 handle_flash_status(write_const_car(new_lst, ctx->r));
4558 lst = new_lst;
4559 }
4560
4561 if (lbm_is_cons(val)) {
4562 sptr[0] = fst;
4563 sptr[1] = lst;//rest_cell;
4564 sptr[2] = get_cdr(val);
4565 lbm_value *rptr = stack_reserve(ctx, 2);
4566 rptr[0] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4567 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4568 ctx->r = get_car(val);
4569 } else {
4570 sptr[0] = fst;
4571 sptr[1] = lst;
4572 sptr[2] = CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u);
4573 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4574 ctx->r = val;
4575 }
4576 ctx->app_cont = true1;
4577}
4578
4579static void cont_close_list_in_flash(eval_context_t *ctx) {
4580 lbm_value fst;
4581 lbm_value lst;
4582 lbm_pop_2(&ctx->K, &lst, &fst);
4583 lbm_value val = ctx->r;
4584 handle_flash_status(write_const_cdr(lst, val));
4585 ctx->r = fst;
4586 ctx->app_cont = true1;
4587}
4588
4589static void cont_move_array_elts_to_flash(eval_context_t *ctx) {
4590 lbm_value *sptr = get_stack_ptr(ctx, 3);
4591 // sptr[2] = source array in RAM
4592 // sptr[1] = current index
4593 // sptr[0] = target array in flash
4594 lbm_array_header_t *src_arr = (lbm_array_header_t*)get_car(sptr[2]);
4595 lbm_uint size = src_arr->size / sizeof(lbm_uint);
4596 lbm_value *srcdata = (lbm_value *)src_arr->data;
4597
4598 lbm_array_header_t *tgt_arr = (lbm_array_header_t*)get_car(sptr[0]);
1
Calling 'get_car'
→
10
←
Returning from 'get_car'
→
11
←
'tgt_arr' initialized to a null pointer value
→
4599 lbm_uint *tgtdata = (lbm_value *)tgt_arr->data;
12
←
Access to field 'data' results in a dereference of a null pointer (loaded from variable 'tgt_arr')
4600 lbm_uint ix = lbm_dec_as_u32(sptr[1]);
4601 handle_flash_status(lbm_const_write(&tgtdata[ix], ctx->r));
4602 if (ix >= size-1) {
4603 ctx->r = sptr[0];
4604 lbm_stack_drop(&ctx->K, 3);
4605 ctx->app_cont = true1;
4606 return;
4607 }
4608 sptr[1] = lbm_enc_u(ix + 1);
4609 lbm_value *rptr = stack_reserve(ctx, 2);
4610 rptr[0] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4611 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4612 ctx->r = srcdata[ix+1];
4613 ctx->app_cont = true1;
4614 return;
4615}
4616
4617static void cont_qq_expand_start(eval_context_t *ctx) {
4618 lbm_value *rptr = stack_reserve(ctx, 2);
4619 rptr[0] = ctx->r;
4620 rptr[1] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4621 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4622 ctx->app_cont = true1;
4623}
4624
4625lbm_value quote_it(lbm_value qquoted) {
4626 if (lbm_is_symbol(qquoted) &&
4627 lbm_is_special(qquoted)) return qquoted;
4628
4629 lbm_value val = cons_with_gc(qquoted, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4630 return cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4631}
4632
4633bool_Bool is_append(lbm_value a) {
4634 return (lbm_is_cons(a) &&
4635 lbm_is_symbol(get_car(a)) &&
4636 (get_car(a) == ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u)));
4637}
4638
4639lbm_value append(lbm_value front, lbm_value back) {
4640 if (lbm_is_symbol_nil(front)) return back;
4641 if (lbm_is_symbol_nil(back)) return front;
4642
4643 if (lbm_is_quoted_list(front) &&
4644 lbm_is_quoted_list(back)) {
4645 lbm_value f = get_cadr(front);
4646 lbm_value b = get_cadr(back);
4647 return quote_it(lbm_list_append(f, b));
4648 }
4649
4650 if (is_append(back) &&
4651 lbm_is_quoted_list(get_cadr(back)) &&
4652 lbm_is_quoted_list(front)) {
4653 lbm_value ql = get_cadr(back);
4654 lbm_value f = get_cadr(front);
4655 lbm_value b = get_cadr(ql);
4656
4657 lbm_value v = lbm_list_append(f, b);
4658 lbm_set_car(get_cdr(ql), v);
4659 return back;
4660 }
4661
4662 if (is_append(back)) {
4663 back = get_cdr(back);
4664 lbm_value new = cons_with_gc(front, back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4665 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), new, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4666 }
4667
4668 lbm_value t0, t1;
4669
4670 t0 = cons_with_gc(back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), front);
4671 t1 = cons_with_gc(front, t0, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4672 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), t1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4673}
4674
4675/* Bawden's qq-expand implementation
4676(define (qq-expand x)
4677 (cond ((tag-comma? x)
4678 (tag-data x))
4679 ((tag-comma-atsign? x)
4680 (error "Illegal"))
4681 ((tag-backquote? x)
4682 (qq-expand
4683 (qq-expand (tag-data x))))
4684 ((pair? x)
4685 `(append
4686 ,(qq-expand-list (car x))
4687 ,(qq-expand (cdr x))))
4688 (else `',x)))
4689 */
4690static void cont_qq_expand(eval_context_t *ctx) {
4691 lbm_value qquoted;
4692 lbm_pop(&ctx->K, &qquoted);
4693
4694 switch(lbm_type_of(qquoted)) {
4695 case LBM_TYPE_CONS0x10000000u: {
4696 lbm_value car_val = get_car(qquoted);
4697 lbm_value cdr_val = get_cdr(qquoted);
4698 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4699 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4700 ctx->r = append(ctx->r, get_car(cdr_val));
4701 ctx->app_cont = true1;
4702 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4703 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4704 error_ctx(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u));
4705 } else {
4706 lbm_value *rptr = stack_reserve(ctx, 6);
4707 rptr[0] = ctx->r;
4708 rptr[1] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4709 rptr[2] = cdr_val;
4710 rptr[3] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4711 rptr[4] = car_val;
4712 rptr[5] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4713 ctx->app_cont = true1;
4714 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4715 }
4716
4717 } break;
4718 default: {
4719 lbm_value res = quote_it(qquoted);
4720 ctx->r = append(ctx->r, res);
4721 ctx->app_cont = true1;
4722 }
4723 }
4724}
4725
4726static void cont_qq_append(eval_context_t *ctx) {
4727 lbm_value head;
4728 lbm_pop(&ctx->K, &head);
4729 ctx->r = append(head, ctx->r);
4730 ctx->app_cont = true1;
4731}
4732
4733/* Bawden's qq-expand-list implementation
4734(define (qq-expand-list x)
4735 (cond ((tag-comma? x)
4736 `(list ,(tag-data x)))
4737 ((tag-comma-atsign? x)
4738 (tag-data x))
4739 ((tag-backquote? x)
4740 (qq-expand-list
4741 (qq-expand (tag-data x))))
4742 ((pair? x)
4743 `(list
4744 (append
4745 ,(qq-expand-list (car x))
4746 ,(qq-expand (cdr x)))))
4747 (else `'(,x))))
4748*/
4749
4750static void cont_qq_expand_list(eval_context_t* ctx) {
4751 lbm_value l;
4752 lbm_pop(&ctx->K, &l);
4753
4754 ctx->app_cont = true1;
4755 switch(lbm_type_of(l)) {
4756 case LBM_TYPE_CONS0x10000000u: {
4757 lbm_value car_val = get_car(l);
4758 lbm_value cdr_val = get_cdr(l);
4759 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4760 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4761 lbm_value tl = cons_with_gc(get_car(cdr_val), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4762 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4763 ctx->r = append(ctx->r, tmp);
4764 return;
4765 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4766 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4767 ctx->r = get_car(cdr_val);
4768 return;
4769 } else {
4770 lbm_value *rptr = stack_reserve(ctx, 7);
4771 rptr[0] = QQ_LIST(((39) << 2) | 0xF8000001u);
4772 rptr[1] = ctx->r;
4773 rptr[2] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4774 rptr[3] = cdr_val;
4775 rptr[4] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4776 rptr[5] = car_val;
4777 rptr[6] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4778 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4779 }
4780
4781 } break;
4782 default: {
4783 lbm_value a_list = cons_with_gc(l, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4784 lbm_value tl = cons_with_gc(a_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4785 lbm_value tmp = cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4786 ctx->r = append(ctx->r, tmp);
4787 }
4788 }
4789}
4790
4791static void cont_qq_list(eval_context_t *ctx) {
4792 lbm_value val = ctx->r;
4793 lbm_value apnd_app = cons_with_gc(val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4794 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), apnd_app, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4795 ctx->r = tmp;
4796 ctx->app_cont = true1;
4797}
4798
4799static void cont_kill(eval_context_t *ctx) {
4800 (void) ctx;
4801 finish_ctx();
4802}
4803
4804static void cont_pop_reader_flags(eval_context_t *ctx) {
4805 lbm_value flags;
4806 lbm_pop(&ctx->K, &flags);
4807 ctx->flags = ctx->flags & ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4808 ctx->flags |= (lbm_dec_as_u32(flags) & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4809 // r is unchanged.
4810 ctx->app_cont = true1;
4811}
4812
4813static void cont_exception_handler(eval_context_t *ctx) {
4814 lbm_value *sptr = pop_stack_ptr(ctx, 2);
4815 lbm_value retval = sptr[0];
4816 lbm_value flags = sptr[1];
4817 lbm_set_car(get_cdr(retval), ctx->r);
4818 ctx->flags = flags;
4819 ctx->r = retval;
4820 ctx->app_cont = true1;
4821}
4822
4823/*********************************************************/
4824/* Continuations table */
4825typedef void (*cont_fun)(eval_context_t *);
4826
4827static const cont_fun continuations[NUM_CONTINUATIONS49] =
4828 { advance_ctx, // CONT_DONE
4829 cont_set_global_env,
4830 cont_bind_to_key_rest,
4831 cont_if,
4832 cont_progn_rest,
4833 cont_application_args,
4834 cont_and,
4835 cont_or,
4836 cont_wait,
4837 cont_match,
4838 cont_application_start,
4839 cont_eval_r,
4840 cont_resume,
4841 cont_closure_application_args,
4842 cont_exit_atomic,
4843 cont_read_next_token,
4844 cont_read_append_continue,
4845 cont_read_eval_continue,
4846 cont_read_expect_closepar,
4847 cont_read_dot_terminate,
4848 cont_read_done,
4849 cont_read_quote_result,
4850 cont_read_commaat_result,
4851 cont_read_comma_result,
4852 cont_read_start_array,
4853 cont_read_append_array,
4854 cont_map,
4855 cont_match_guard,
4856 cont_terminate,
4857 cont_progn_var,
4858 cont_setq,
4859 cont_move_to_flash,
4860 cont_move_val_to_flash_dispatch,
4861 cont_move_list_to_flash,
4862 cont_close_list_in_flash,
4863 cont_qq_expand_start,
4864 cont_qq_expand,
4865 cont_qq_append,
4866 cont_qq_expand_list,
4867 cont_qq_list,
4868 cont_kill,
4869 cont_loop,
4870 cont_loop_condition,
4871 cont_merge_rest,
4872 cont_merge_layer,
4873 cont_closure_args_rest,
4874 cont_move_array_elts_to_flash,
4875 cont_pop_reader_flags,
4876 cont_exception_handler
4877 };
4878
4879/*********************************************************/
4880/* Evaluators lookup table (special forms) */
4881typedef void (*evaluator_fun)(eval_context_t *);
4882
4883static const evaluator_fun evaluators[] =
4884 {
4885 eval_quote,
4886 eval_define,
4887 eval_progn,
4888 eval_lambda,
4889 eval_if,
4890 eval_let,
4891 eval_and,
4892 eval_or,
4893 eval_match,
4894 eval_receive,
4895 eval_receive_timeout,
4896 eval_callcc,
4897 eval_atomic,
4898 eval_selfevaluating, // macro
4899 eval_selfevaluating, // cont
4900 eval_selfevaluating, // closure
4901 eval_cond,
4902 eval_app_cont,
4903 eval_var,
4904 eval_setq,
4905 eval_move_to_flash,
4906 eval_loop,
4907 eval_trap
4908 };
4909
4910
4911/*********************************************************/
4912/* Evaluator step function */
4913
4914static void evaluation_step(void){
4915 eval_context_t *ctx = ctx_running;
4916#ifdef VISUALIZE_HEAP
4917 heap_vis_gen_image();
4918#endif
4919
4920 if (ctx->app_cont) {
4921 lbm_value k;
4922 lbm_pop(&ctx->K, &k);
4923 ctx->app_cont = false0;
4924
4925 lbm_uint decoded_k = DEC_CONTINUATION(k)(((k) & ~0xF8000001u) >> 2);
4926
4927 if (decoded_k < NUM_CONTINUATIONS49) {
4928 continuations[decoded_k](ctx);
4929 } else {
4930 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4931 }
4932 return;
4933 }
4934
4935 if (lbm_is_symbol(ctx->curr_exp)) {
4936 eval_symbol(ctx);
4937 return;
4938 }
4939 if (lbm_is_cons(ctx->curr_exp)) {
4940 lbm_cons_t *cell = lbm_ref_cell(ctx->curr_exp);
4941 lbm_value h = cell->car;
4942 if (lbm_is_symbol(h) && ((h & ENC_SPECIAL_FORMS_MASK0xFFFFF000) == ENC_SPECIAL_FORMS_BIT0x00001000)) {
4943 lbm_uint eval_index = lbm_dec_sym(h) & SPECIAL_FORMS_INDEX_MASK0x000000FF;
4944 evaluators[eval_index](ctx);
4945 return;
4946 }
4947 /*
4948 * At this point head can be anything. It should evaluate
4949 * into a form that can be applied (closure, symbol, ...) though.
4950 */
4951 lbm_value *reserved = stack_reserve(ctx, 3);
4952 reserved[0] = ctx->curr_env;
4953 reserved[1] = cell->cdr;
4954 reserved[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
4955 ctx->curr_exp = h; // evaluate the function
4956 return;
4957 }
4958
4959 eval_selfevaluating(ctx);
4960 return;
4961}
4962
4963void lbm_pause_eval(void ) {
4964 eval_cps_next_state_arg = 0;
4965 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4966 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4967}
4968
4969void lbm_pause_eval_with_gc(uint32_t num_free) {
4970 eval_cps_next_state_arg = num_free;
4971 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4972 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4973}
4974
4975void lbm_continue_eval(void) {
4976 eval_cps_next_state = EVAL_CPS_STATE_RUNNING2;
4977 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4978}
4979
4980void lbm_kill_eval(void) {
4981 eval_cps_next_state = EVAL_CPS_STATE_KILL4;
4982 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4983}
4984
4985uint32_t lbm_get_eval_state(void) {
4986 return eval_cps_run_state;
4987}
4988
4989// Will wake up thread that is sleeping as well.
4990// Not sure this is good behavior.
4991static void handle_event_unblock_ctx(lbm_cid cid, lbm_value v) {
4992 eval_context_t *found = NULL((void*)0);
4993 mutex_lock(&qmutex);
4994
4995 found = lookup_ctx_nm(&blocked, cid);
4996 if (found) {
4997 drop_ctx_nm(&blocked,found);
4998 if (lbm_is_error(v)) {
4999 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
5000 found->app_cont = true1;
5001 }
5002 found->r = v;
5003 enqueue_ctx_nm(&queue,found);
5004 }
5005 mutex_unlock(&qmutex);
5006}
5007
5008static void handle_event_define(lbm_value key, lbm_value val) {
5009 lbm_uint dec_key = lbm_dec_sym(key);
5010 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
5011 lbm_value *global_env = lbm_get_global_env();
5012 lbm_uint orig_env = global_env[ix_key];
5013 lbm_value new_env;
5014 // A key is a symbol and should not need to be remembered.
5015 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
5016
5017 global_env[ix_key] = new_env;
5018}
5019
5020static lbm_value get_event_value(lbm_event_t *e) {
5021 lbm_value v;
5022 if (e->buf_len > 0) {
5023 lbm_flat_value_t fv;
5024 fv.buf = (uint8_t*)e->buf_ptr;
5025 fv.buf_size = e->buf_len;
5026 fv.buf_pos = 0;
5027 if (!lbm_unflatten_value(&fv, &v)) {
5028 lbm_set_flags(LBM_FLAG_HANDLER_EVENT_DELIVERY_FAILED(1 << 1));
5029 v = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
5030 }
5031 // Free the flat value buffer. GC is unaware of its existence.
5032 lbm_free(fv.buf);
5033 } else {
5034 v = (lbm_value)e->buf_ptr;
5035 }
5036 return v;
5037}
5038
5039static void process_events(void) {
5040
5041 if (!lbm_events) return;
5042 lbm_event_t e;
5043
5044 while (lbm_event_pop(&e)) {
5045
5046 lbm_value event_val = get_event_value(&e);
5047 switch(e.type) {
5048 case LBM_EVENT_UNBLOCK_CTX:
5049 handle_event_unblock_ctx((lbm_cid)e.parameter, event_val);
5050 break;
5051 case LBM_EVENT_DEFINE:
5052 handle_event_define((lbm_value)e.parameter, event_val);
5053 break;
5054 case LBM_EVENT_FOR_HANDLER:
5055 if (lbm_event_handler_pid >= 0) {
5056 lbm_find_receiver_and_send(lbm_event_handler_pid, event_val);
5057 }
5058 break;
5059 }
5060 }
5061}
5062
5063/* eval_cps_run can be paused
5064 I think it would be better use a mailbox for
5065 communication between other threads and the run_eval
5066 but for now a set of variables will be used. */
5067void lbm_run_eval(void){
5068
5069 if (setjmp(critical_error_jmp_buf)_setjmp (critical_error_jmp_buf) > 0) {
5070 printf_callback("GC stack overflow!\n");
5071 critical_error_callback();
5072 // terminate evaluation thread.
5073 return;
5074 }
5075
5076 setjmp(error_jmp_buf)_setjmp (error_jmp_buf);
5077
5078 while (eval_running) {
5079 if (eval_cps_state_changed || eval_cps_run_state == EVAL_CPS_STATE_PAUSED1) {
5080 eval_cps_state_changed = false0;
5081 switch (eval_cps_next_state) {
5082 case EVAL_CPS_STATE_PAUSED1:
5083 if (eval_cps_run_state != EVAL_CPS_STATE_PAUSED1) {
5084 if (lbm_heap_num_free() < eval_cps_next_state_arg) {
5085 gc();
5086 }
5087 eval_cps_next_state_arg = 0;
5088 }
5089 eval_cps_run_state = EVAL_CPS_STATE_PAUSED1;
5090 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5091 continue; /* jump back to start of eval_running loop */
5092 case EVAL_CPS_STATE_KILL4:
5093 eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
5094 eval_running = false0;
5095 continue;
5096 default: // running state
5097 eval_cps_run_state = eval_cps_next_state;
5098 break;
5099 }
5100 }
5101 while (true1) {
5102 if (eval_steps_quota && ctx_running) {
5103 eval_steps_quota--;
5104 evaluation_step();
5105 } else {
5106 if (eval_cps_state_changed) break;
5107 eval_steps_quota = eval_steps_refill;
5108 if (is_atomic) {
5109 if (!ctx_running) {
5110 lbm_set_flags(LBM_FLAG_ATOMIC_MALFUNCTION(1 << 0));
5111 is_atomic = 0;
5112 }
5113 } else {
5114 if (gc_requested) {
5115 gc();
5116 }
5117 process_events();
5118 mutex_lock(&qmutex);
5119 if (ctx_running) {
5120 enqueue_ctx_nm(&queue, ctx_running);
5121 ctx_running = NULL((void*)0);
5122 }
5123 wake_up_ctxs_nm();
5124 ctx_running = dequeue_ctx_nm(&queue);
5125 mutex_unlock(&qmutex);
5126 if (!ctx_running) {
5127 lbm_system_sleeping = true1;
5128 //Fixed sleep interval to poll events regularly.
5129 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5130 lbm_system_sleeping = false0;
5131 }
5132 }
5133 }
5134 }
5135 }
5136}
5137
5138lbm_cid lbm_eval_program(lbm_value lisp) {
5139 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), 256, NULL((void*)0));
5140}
5141
5142lbm_cid lbm_eval_program_ext(lbm_value lisp, unsigned int stack_size) {
5143 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), stack_size, NULL((void*)0));
5144}
5145
5146int lbm_eval_init() {
5147 if (!qmutex_initialized) {
5148 mutex_init(&qmutex);
5149 qmutex_initialized = true1;
5150 }
5151 if (!lbm_events_mutex_initialized) {
5152 mutex_init(&lbm_events_mutex);
5153 lbm_events_mutex_initialized = true1;
5154 }
5155 if (!blocking_extension_mutex_initialized) {
5156 mutex_init(&blocking_extension_mutex);
5157 blocking_extension_mutex_initialized = true1;
5158 }
5159
5160 mutex_lock(&qmutex);
5161 mutex_lock(&lbm_events_mutex);
5162
5163 blocked.first = NULL((void*)0);
5164 blocked.last = NULL((void*)0);
5165 queue.first = NULL((void*)0);
5166 queue.last = NULL((void*)0);
5167 ctx_running = NULL((void*)0);
5168
5169 eval_cps_run_state = EVAL_CPS_STATE_RUNNING2;
5170
5171 mutex_unlock(&lbm_events_mutex);
5172 mutex_unlock(&qmutex);
5173
5174 if (!lbm_init_env()) return 0;
5175 eval_running = true1;
5176 return 1;
5177}
5178
5179bool_Bool lbm_eval_init_events(unsigned int num_events) {
5180
5181 mutex_lock(&lbm_events_mutex);
5182 lbm_events = (lbm_event_t*)lbm_malloc(num_events * sizeof(lbm_event_t));
5183 bool_Bool r = false0;
5184 if (lbm_events) {
5185 lbm_events_max = num_events;
5186 lbm_events_head = 0;
5187 lbm_events_tail = 0;
5188 lbm_events_full = false0;
5189 lbm_event_handler_pid = -1;
5190 r = true1;
5191 }
5192 mutex_unlock(&lbm_events_mutex);
5193 return r;
5194}
+
+
←

./include/heap.h

+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1
2/*
3 Copyright 2018, 2024 Joel Svensson svenssonjoel@yahoo.se
4
5 This program is free software: you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation, either version 3 of the License, or
8 (at your option) any later version.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
14
15 You should have received a copy of the GNU General Public License
16 along with this program. If not, see <http://www.gnu.org/licenses/>.
17*/
18/** \file heap.h */
19
20#ifndef HEAP_H_
21#define HEAP_H_
22
23#include <string.h>
24#include <stdarg.h>
25
26#include "lbm_types.h"
27#include "symrepr.h"
28#include "stack.h"
29#include "lbm_memory.h"
30#include "lbm_defines.h"
31#include "lbm_channel.h"
32
33#ifdef __cplusplus
34extern "C" {
35#endif
36
37/*
38Planning for a more space efficient heap representation.
39TODO: Need to find a good reference to read up on this.
40 - List based heap
41 - Easy to implement and somewhat efficient
42
430000 0000 Size Free bits
44003F FFFF 4MB 10
45007F FFFF 8MB 9
4600FF FFFF 16MB 8
4701FF FFFF 32MB 7
4803FF FFFF 64MB 6 * Kind of heap size I am looking for
4907FF FFFF 128MB 5
500FFF FFFF 256MB 4
511FFF FFFF 512MB 3
52
53
54--- May 9 2021 ---
55Actually now I am much more interested in way smaller memories ;)
56
570000 0000 Size Free bits
580000 0FFF 4KB 20 |
590000 1FFF 8KB 19 |
600000 3FFF 16KB 18 |
610000 7FFF 32KB 17 |
620000 FFFF 64KB 16 |
630001 FFFF 128KB 15 |
640003 FFFF 256KB 14 | - This range is very interesting.
650007 FFFF 512KB 13
66000F FFFF 1MB 12
67001F FFFF 2MB 11
68003F FFFF 4MB 10
69007F FFFF 8MB 9
7000FF FFFF 16MB 8
7101FF FFFF 32MB 7
7203FF FFFF 64MB 6
7307FF FFFF 128MB 5
740FFF FFFF 256MB 4
751FFF FFFF 512MB 3
76
77Those are the kind of platforms that are fun... so a bunch of
78wasted bits in heap pointers if we run on small MCUs.
79
80-----------------
81
82it is also the case that not all addresses will be used if all "cells" are
83of the same size, 8 bytes...
84
85value 0: 0000 0000
86value 1: 0000 0008
87value 3: 0000 0010
88value 4: 0000 0018
89
90Means bits 0,1,2 will always be empty in a valid address.
91
92Cons cells also need to be have room for 2 pointers. So each ted cell from
93memory should be 8bytes.
94
95Things that needs to be represented within these bits:
96
97 - GC MARK one per cell
98 - TYPE: type of CAR and type of cons
99
100Types I would want:
101 - Full 32bit integer. Does not leave room for identification of type
102 - Float values. Same problem
103
104
105Free bits in pointers 64MB heap:
10631 30 29 28 27 26 2 1 0
1070 0 0 0 0 0 XX XXXX XXXX XXXX XXXX XXXX X 0 0 0
108
109
110Information needed for each cell:
111 Meaning | bits total | bits per car | bits per cdr
112 GC mark | 2 | 1 | 1 - only one of them will be used (the other is wasted)
113 Type | 2x | x | x
114 Ptr/!ptr | 2 | 1 | 1
115
116
117Types (unboxed):
118 - Symbols
119 - 28bit integer ( will need signed shift right functionality )
120 - 28bit unsigned integer
121 - Character
122
123If four types is all that should be possible (unboxed). then 2 bits are needed to differentiate.
1242 + 1 + 1 = 4 => 28bits for data.
125
126bit 0: ptr/!ptr
127bit 1: gc
128bit 2-3: type (if not ptr)
129bit 3 - 24 ptr (if ptr)
130bit 4 - 31 value (if value)
131
132An unboxed value can occupy a car or cdr field in a cons cell.
133
134types (boxed) extra information in pointer to cell can contain information
135 - 32 bit integer
136 - 32 bit unsigned integer
137 - 32 bit float
138
139boxed representation:
140 [ptr| cdr]
141 |
142 [Value | Aux + GC_MARK]
143
144Kinds of pointers:
145 - Pointer to cons cell.
146 - Pointer to unboxed value (fixnums not in a list, I hope this is so rare that it can be removed )
147 - integer
148 - unsigned integer
149 - symbol
150 - float
151 - Pointer to boxed value.
152 - 32 bit integer
153 - 32 bit unsigned integer
154 - 32 bit float
155 - (Maybe something else ? Vectors/strings allocated in memory not occupied by heap?)
156 - vector of int
157 - vector of uint
158 - vector of float
159 - vector of double
160 - String
161
16213 pointer"types" -> needs 4 bits
163for 64MB heap there are 6 free bits. So with this scheme going to 128MB or 256MB heap
164is also possible
165
166 a pointer to some off heap vector/string could be represented by
167
168 [ptr | cdr]
169 |
170 [full pointer | Aux + GC_MARK]
171 |
172 [VECTOR]
173
174Aux bits could be used for storing vector size. Up to 30bits should be available there
175>> This is problematic. Now the information that something is a vector is split up
176>> between 2 cons cells. This means GC needs both of these intact to be able to make
177>> proper decision.
178>> Will try to resolve this by adding some special symbols. But these must be symbols
179>> that cannot occur normally in programs. Then an array could be:
180
181 [Full pointer | ARRAY_SYM + GC_MARK]
182 |
183 [VECTOR]
184
185>> Boxed values same treatment as above.
186>> TODO: Could this be simpler?
187
188[ VALUE | TYPE_SYM + GC_MARK]
189
190
1910000 00XX XXXX XXXX XXXX XXXX XXXX X000 : 0x03FF FFF8
1921111 AA00 0000 0000 0000 0000 0000 0000 : 0xFC00 0000 (AA bits left unused for now, future heap growth?)
193 */
194
195typedef enum {
196 LBM_FLASH_WRITE_OK,
197 LBM_FLASH_FULL,
198 LBM_FLASH_WRITE_ERROR
199} lbm_flash_status;
200
201/** Struct representing a heap cons-cell.
202 *
203 */
204typedef struct {
205 lbm_value car;
206 lbm_value cdr;
207} lbm_cons_t;
208
209/**
210 * Heap state
211 */
212typedef struct {
213 lbm_cons_t *heap;
214 lbm_value freelist; // list of free cons cells.
215 lbm_stack_t gc_stack;
216
217 lbm_uint heap_size; // In number of cells.
218 lbm_uint heap_bytes; // In bytes.
219
220 lbm_uint num_alloc; // Number of cells allocated.
221 lbm_uint num_alloc_arrays; // Number of arrays allocated.
222
223 lbm_uint gc_num; // Number of times gc has been performed.
224 lbm_uint gc_marked; // Number of cells marked by mark phase.
225 lbm_uint gc_recovered; // Number of cells recovered by sweep phase.
226 lbm_uint gc_recovered_arrays;// Number of arrays recovered by sweep.
227 lbm_uint gc_least_free; // The smallest length of the freelist.
228 lbm_uint gc_last_free; // Number of elements on the freelist
229 // after most recent GC.
230} lbm_heap_state_t;
231
232extern lbm_heap_state_t lbm_heap_state;
233
234typedef bool_Bool (*const_heap_write_fun)(lbm_uint ix, lbm_uint w);
235
236typedef struct {
237 lbm_uint *heap;
238 lbm_uint next; // next free index.
239 lbm_uint size; // in lbm_uint words. (cons-cells = words / 2)
240} lbm_const_heap_t;
241
242/**
243 * The header portion of an array stored in array and symbol memory.
244 * An array is always a byte array. use the array-extensions for
245 * storing and reading larger values from arrays.
246 */
247typedef struct {
248 lbm_uint size; /// Number of elements
249 lbm_uint *data; /// pointer to lbm_memory array or C array.
250} lbm_array_header_t;
251
252typedef struct {
253 lbm_uint size;
254 lbm_uint *data;
255 uint32_t index; // Limits arrays to max 2^32-1 elements.
256} lbm_array_header_extended_t;
257
258/** Lock GC mutex
259 * Locks a mutex during GC marking when using the pointer reversal algorithm.
260 * Does nothing when using stack based GC mark.
261 */
262void lbm_gc_lock(void);
263/* Unlock GC mutex
264 */
265void lbm_gc_unlock(void);
266
267/** Initialize heap storage.
268 * \param addr Pointer to an array of lbm_cons_t elements. This array must at least be aligned 4.
269 * \param num_cells Number of lbm_cons_t elements in the array.
270 * \param gc_stack_size Size of the gc_stack in number of words.
271 * \return 1 on success or 0 for failure.
272 */
273int lbm_heap_init(lbm_cons_t *addr, lbm_uint num_cells,
274 lbm_uint gc_stack_size);
275
276/** Add GC time statistics to heap_stats
277 *
278 * \param dur Duration as reported by the timestamp callback.
279 */
280void lbm_heap_new_gc_time(lbm_uint dur);
281/** Add a new free_list length to the heap_stats.
282 * Calculates a new freelist length and updates
283 * the GC statistics.
284 */
285void lbm_heap_new_freelist_length(void);
286/** Check how many lbm_cons_t cells are on the free-list
287 *
288 * \return Number of free lbm_cons_t cells.
289 */
290lbm_uint lbm_heap_num_free(void);
291/** Check how many lbm_cons_t cells are allocated.
292 *
293 * \return Number of lbm_cons_t cells that are currently allocated.
294 */
295lbm_uint lbm_heap_num_allocated(void);
296/** Size of the heap in number of lbm_cons_t cells.
297 *
298 * \return Size of the heap in number of lbm_cons_t cells.
299 */
300lbm_uint lbm_heap_size(void);
301/** Size of the heap in bytes.
302 *
303 * \return Size of heap in bytes.
304 */
305lbm_uint lbm_heap_size_bytes(void);
306/** Allocate an lbm_cons_t cell from the heap.
307 *
308 * \param type A type that can be encoded onto the cell (most often LBM_PTR_TYPE_CONS).
309 * \param car Value to write into car position of allocated cell.
310 * \param cdr Value to write into cdr position of allocated cell.
311 * \return An lbm_value referring to a cons_cell or enc_sym(SYM_MERROR) in case the heap is full.
312 */
313lbm_value lbm_heap_allocate_cell(lbm_type type, lbm_value car, lbm_value cdr);
314/** Allocate a list of n heap-cells.
315 * \param n The number of heap-cells to allocate.
316 * \return A list of heap-cells of Memory error if unable to allocate.
317 */
318lbm_value lbm_heap_allocate_list(lbm_uint n);
319/** Allocate a list of n heap-cells and initialize the values.
320 * \pram ls The result list is passed through this ptr.
321 * \param n The length of list to allocate.
322 * \param valist The values in a va_list to initialize the list with.
323 * \return True of False depending on success of allocation.
324 */
325lbm_value lbm_heap_allocate_list_init_va(unsigned int n, va_list valist);
326/** Allocate a list of n heap-cells and initialize the values.
327 * \param n The length of list to allocate.
328 * \param ... The values to initialize the list with.
329 * \return allocated list or error symbol.
330 */
331lbm_value lbm_heap_allocate_list_init(unsigned int n, ...);
332/** Decode an lbm_value representing a string into a C string
333 *
334 * \param val Value
335 * \return allocated list or error symbol
336 */
337char *lbm_dec_str(lbm_value val);
338/** Decode an lbm_value representing a char channel into an lbm_char_channel_t pointer.
339 *
340 * \param val Value
341 * \return A pointer to an lbm_char_channel_t or NULL if the value does not encode a channel.
342 */
343lbm_char_channel_t *lbm_dec_channel(lbm_value val);
344/** Decode an lbm_value representing a custom type into a lbm_uint value.
345 *
346 * \param val Value.
347 * \return The custom type payload.
348 */
349lbm_uint lbm_dec_custom(lbm_value val);
350/** Decode a numerical value as if it is char
351 *
352 * \param val Value to decode
353 * \return The value encoded in val casted to a char. Returns 0 if val does not encode a number.
354 */
355uint8_t lbm_dec_as_char(lbm_value a);
356/** Decode a numerical value as if it is unsigned
357 *
358 * \param val Value to decode
359 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
360 */
361uint32_t lbm_dec_as_u32(lbm_value val);
362/** Decode a numerical value as a signed integer.
363 *
364 * \param val Value to decode
365 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
366 */
367int32_t lbm_dec_as_i32(lbm_value val);
368/** Decode a numerical value as a float.
369 *
370 * \param val Value to decode.
371 * \return The value encoded in val casted to a float. Returns 0 if val does not encode a number.
372 */
373float lbm_dec_as_float(lbm_value val);
374/** Decode a numerical value as if it is a 64bit unsigned
375 *
376 * \param val Value to decode
377 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
378 */
379uint64_t lbm_dec_as_u64(lbm_value val);
380/** Decode a numerical value as a 64bit signed integer.
381 *
382 * \param val Value to decode
383 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
384 */
385int64_t lbm_dec_as_i64(lbm_value val);
386/** Decode a numerical value as a float.
387 *
388 * \param val Value to decode.
389 * \return The value encoded in val casted to a float. Returns 0 if val does not encode a number.
390 */
391double lbm_dec_as_double(lbm_value val);
392
393/** Decode a numerical value into the architecture defined unsigned integer type.
394 *
395 * \param val Value to decode
396 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
397 */
398lbm_uint lbm_dec_as_uint(lbm_value val);
399
400/** Decode a numerical value into the architecture defined signed integer type.
401 *
402 * \param val Value to decode
403 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
404 */
405lbm_int lbm_dec_as_int(lbm_value val);
406
407lbm_uint lbm_dec_raw(lbm_value v);
408/** Allocates an lbm_cons_t cell from the heap and populates it.
409 *
410 * \param car The value to put in the car field of the allocated lbm_cons_t.
411 * \param cdr The value to put in the cdr field of the allocated lbm_cons_t.
412 * \return A value referencing the lbm_cons_t or enc_sym(SYM_MERROR) if heap is full.
413 */
414lbm_value lbm_cons(lbm_value car, lbm_value cdr);
415
416/** Accesses the car field of an lbm_cons_t.
417 *
418 * \param cons Value
419 * \return The car field of the lbm_cons_t if cons is a reference to a heap cell.
420 * If cons is nil, the return value is nil. If the value
421 * is not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
422 */
423lbm_value lbm_car(lbm_value cons);
424/** Accesses the car field the car field of an lbm_cons_t.
425 *
426 * \param cons Value
427 * \return The car of car field or nil.
428 */
429lbm_value lbm_caar(lbm_value c);
430/** Accesses the car of the cdr of an cons cell
431 *
432 * \param c Value
433 * \return the cdr field or type error.
434 */
435lbm_value lbm_cadr(lbm_value c);
436/** Accesses the cdr field of an lbm_cons_t.
437 *
438 * \param cons Value
439 * \return The cdr field of the lbm_cons_t if cons is a reference to a heap cell.
440 * If cons is nil, the return value is nil. If the value
441 * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
442 */
443lbm_value lbm_cdr(lbm_value cons);
444/** Accesses the cdr of an cdr field of an lbm_cons_t.
445 *
446 * \param cons Value
447 * \return The cdr of the cdr field of the lbm_cons_t if cons is a reference to a heap cell.
448 * If cons is nil, the return value is nil. If the value
449 * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
450 */
451lbm_value lbm_cddr(lbm_value c);
452/** Update the value stored in the car field of a heap cell.
453 *
454 * \param c Value referring to a heap cell.
455 * \param v Value to replace the car field with.
456 * \return 1 on success and 0 if the c value does not refer to a heap cell.
457 */
458int lbm_set_car(lbm_value c, lbm_value v);
459/** Update the value stored in the cdr field of a heap cell.
460 *
461 * \param c Value referring to a heap cell.
462 * \param v Value to replace the cdr field with.
463 * \return 1 on success and 0 if the c value does not refer to a heap cell.
464 */
465int lbm_set_cdr(lbm_value c, lbm_value v);
466/** Update the value stored in the car and cdr fields of a heap cell.
467 *
468 * \param c Value referring to a heap cell.
469 * \param car_val Value to replace the car field with.
470 * \param cdr_val Value to replace the cdr field with.
471 * \return 1 on success and 0 if the c value does not refer to a heap cell.
472 */
473int lbm_set_car_and_cdr(lbm_value c, lbm_value car_val, lbm_value cdr_val);
474// List functions
475/** Calculate the length of a proper list
476 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
477 * may lead to the function not terminating.
478 *
479 * \param c A list
480 * \return The length of the list. Unless the value is a cyclic structure on the heap, this function will terminate.
481 */
482lbm_uint lbm_list_length(lbm_value c);
483
484/** Calculate the length of a proper list and evaluate a predicate for each element.
485 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
486 * may lead to the function not terminating.
487 *
488 * \param c A list
489 * \param pres Boolean result of predicate, false if predicate is false for any of the elements in the list, otherwise true.
490 * \param pred Predicate to evaluate for each element of the list.
491 */
492unsigned int lbm_list_length_pred(lbm_value c, bool_Bool *pres, bool_Bool (*pred)(lbm_value));
493/** Reverse a proper list
494 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
495 * may lead to the function not terminating.
496 *
497 * \param list A list
498 * \return The list reversed or enc_sym(SYM_MERROR) if heap is full.
499 */
500lbm_value lbm_list_reverse(lbm_value list);
501/** Reverse a proper list destroying the original.
502 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
503 * may lead to the function not terminating.
504 *
505 * \param list A list
506 * \return The list reversed
507 */
508lbm_value lbm_list_destructive_reverse(lbm_value list);
509/** Copy a list
510 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
511 * may lead to the function not terminating.
512 *
513 * \param m Number of elements to copy or -1 for all. If 1, m will be updated with the length of the list
514 * \param list A list.
515 * \return Reversed list or enc_sym(SYM_MERROR) if heap is full.
516 */
517lbm_value lbm_list_copy(int *m, lbm_value list);
518
519/** A destructive append of two lists
520 *
521 * \param list1 A list
522 * \param list2 A list
523 * \return list1 with list2 appended at the end.
524 */
525lbm_value lbm_list_append(lbm_value list1, lbm_value list2);
526
527/** Drop values from the head of a list.
528 * \param n Number of values to drop.
529 * \param ls List to drop values from.
530 * \return The list with the n first elements removed.
531 */
532lbm_value lbm_list_drop(unsigned int n, lbm_value ls);
533/** Index into a list.
534 * \param l List to index into.
535 * \param n Position to read out of the list.
536 * \return Value at position n of l or nil if out of bounds.
537 */
538lbm_value lbm_index_list(lbm_value l, int32_t n);
539
540// State and statistics
541/** Get a copy of the heap statistics structure.
542 *
543 * \param A pointer to an lbm_heap_state_t to populate
544 * with the current statistics.
545 */
546void lbm_get_heap_state(lbm_heap_state_t *);
547/** Get the maximum stack level of the GC stack
548 * \return maximum value the gc stack sp reached so far.
549 */
550lbm_uint lbm_get_gc_stack_max(void);
551/** Get the size of the GC stack.
552 * \return the size of the gc stack.
553 */
554lbm_uint lbm_get_gc_stack_size(void);
555// Garbage collection
556/** Increment the counter that is counting the number of times GC ran
557 *
558 */
559void lbm_gc_state_inc(void);
560/** Set the freelist to NIL. Means that no memory will be available
561 * until after a garbage collection.
562 */
563void lbm_nil_freelist(void);
564/** Mark all heap cells reachable from an environment.
565 * \param environment.
566 */
567void lbm_gc_mark_env(lbm_value);
568/** Mark heap cells reachable from the lbm_value v.
569 * \param root
570 */
571void lbm_gc_mark_phase(lbm_value root);
572/** Performs lbm_gc_mark_phase on all the values of an array.
573 * This function is similar to lbm_gc_mark_roots but performs
574 * extra checks to not traverse into non-standard values.
575 * TODO: Check if this function is really needed.
576 * \param data Array of roots to traverse from.
577 * \param n Number of elements in roots-array.
578 */
579void lbm_gc_mark_aux(lbm_uint *data, lbm_uint n);
580/** Performs lbm_gc_mark_phase on all the values in the roots array.
581 * \param roots pointer to array of roots.
582 * \param num_roots size of array of roots.
583 */
584void lbm_gc_mark_roots(lbm_uint *roots, lbm_uint num_roots);
585/** Sweep up all non marked heap cells and place them on the free list.
586 *
587 * \return 1
588 */
589int lbm_gc_sweep_phase(void);
590
591// Array functionality
592/** Allocate an bytearray in symbols and arrays memory (lispbm_memory.h)
593 * and create a heap cell that refers to this bytearray.
594 * \param res The resulting lbm_value is returned through this argument.
595 * \param size Array size in number of 32 bit words.
596 * \return 1 for success of 0 for failure.
597 */
598int lbm_heap_allocate_array(lbm_value *res, lbm_uint size);
599/** Allocate an array in symbols and arrays memory (lispbm_memory.h)
600 * and create a heap cell that refers to this array.
601 * \param res The resulting lbm_value is returned through this argument.
602 * \param size Array size in number of 32 bit words.
603 * \return 1 for success of 0 for failure.
604 */
605int lbm_heap_allocate_lisp_array(lbm_value *res, lbm_uint size);
606/** Convert a C array into an lbm array. If the C array is allocated in LBM MEMORY
607 * the lifetime of the array will be managed by GC.
608 * \param res lbm_value result pointer for storage of the result array.
609 * \param data C array.
610 * \param type The type tag to assign to the resulting LBM array.
611 * \param num_elt Number of elements in the array.
612 * \return 1 for success and 0 for failure.
613 */
614int lbm_lift_array(lbm_value *value, char *data, lbm_uint num_elt);
615/** Get the size of an array value.
616 * \param arr lbm_value array to get size of.
617 * \return -1 for failure or length of array.
618 */
619lbm_int lbm_heap_array_get_size(lbm_value arr);
620/** Get a pointer to the data of an array for read only purposes.
621 * \param arr lbm_value array to get pointer from.
622 * \return NULL or valid pointer.
623 */
624const uint8_t *lbm_heap_array_get_data_ro(lbm_value arr);
625/** Get a pointer to the data of an array for read/write purposes.
626 * \param arr lbm_value array to get pointer from.
627 * \return NULL or valid pointer.
628 */
629uint8_t *lbm_heap_array_get_data_rw(lbm_value arr);
630/** Explicitly free an array.
631 * This function needs to be used with care and knowledge.
632 * \param arr Array value.
633 */
634int lbm_heap_explicit_free_array(lbm_value arr);
635/** Query the size in bytes of an lbm_type.
636 * \param t Type
637 * \return Size in bytes of type or 0 if the type represents a composite.
638 */
639lbm_uint lbm_size_of(lbm_type t);
640
641int lbm_const_heap_init(const_heap_write_fun w_fun,
642 lbm_const_heap_t *heap,
643 lbm_uint *addr,
644 lbm_uint num_words);
645
646lbm_flash_status lbm_allocate_const_cell(lbm_value *res);
647lbm_flash_status lbm_write_const_raw(lbm_uint *data, lbm_uint n, lbm_uint *res);
648lbm_flash_status lbm_allocate_const_raw(lbm_uint nwords, lbm_uint *res);
649lbm_flash_status write_const_cdr(lbm_value cell, lbm_value val);
650lbm_flash_status write_const_car(lbm_value cell, lbm_value val);
651lbm_flash_status lbm_const_write(lbm_uint *tgt, lbm_uint val);
652lbm_uint lbm_flash_memory_usage(void);
653
654/** Query the type information of a value.
655 *
656 * \param x Value to check the type of.
657 * \return The type information.
658 */
659static inline lbm_type lbm_type_of(lbm_value x) {
660 return (x & LBM_PTR_BIT0x00000001u) ? (x & LBM_PTR_TYPE_MASK0xFC000000u) : (x & LBM_VAL_TYPE_MASK0x0000000Cu);
661}
662
663// type-of check that is safe in functional code
664static inline lbm_type lbm_type_of_functional(lbm_value x) {
665 return (x & LBM_PTR_BIT0x00000001u) ?
666 (x & (LBM_PTR_TO_CONSTANT_MASK~0x04000000u & LBM_PTR_TYPE_MASK0xFC000000u)) :
667 (x & LBM_VAL_TYPE_MASK0x0000000Cu);
668}
669
670static inline lbm_value lbm_enc_cons_ptr(lbm_uint x) {
671 return ((x << LBM_ADDRESS_SHIFT2) | LBM_TYPE_CONS0x10000000u | LBM_PTR_BIT0x00000001u);
672}
673
674static inline lbm_uint lbm_dec_ptr(lbm_value p) {
675 return ((LBM_PTR_VAL_MASK0x03FFFFFCu & p) >> LBM_ADDRESS_SHIFT2);
676}
677
678extern lbm_cons_t *lbm_heaps[2];
679
680static inline lbm_uint lbm_dec_cons_cell_ptr(lbm_value p) {
681 lbm_uint h = (p & LBM_PTR_TO_CONSTANT_BIT0x04000000u) >> LBM_PTR_TO_CONSTANT_SHIFT26;
682 return lbm_dec_ptr(p) >> h;
683}
684
685static inline lbm_cons_t *lbm_dec_heap(lbm_value p) {
686 lbm_uint h = (p & LBM_PTR_TO_CONSTANT_BIT0x04000000u) >> LBM_PTR_TO_CONSTANT_SHIFT26;
687 return lbm_heaps[h];
688}
689
690static inline lbm_value lbm_set_ptr_type(lbm_value p, lbm_type t) {
691 return ((LBM_PTR_VAL_MASK0x03FFFFFCu & p) | t | LBM_PTR_BIT0x00000001u);
692}
693
694static inline lbm_value lbm_enc_sym(lbm_uint s) {
695 return (s << LBM_VAL_SHIFT4) | LBM_TYPE_SYMBOL0x00000000u;
696}
697
698static inline lbm_value lbm_enc_i(lbm_int x) {
699 return ((lbm_uint)x << LBM_VAL_SHIFT4) | LBM_TYPE_I0x00000008u;
700}
701
702static inline lbm_value lbm_enc_u(lbm_uint x) {
703 return (x << LBM_VAL_SHIFT4) | LBM_TYPE_U0x0000000Cu;
704}
705
706/** Encode 32 bit integer into an lbm_value.
707 * \param x Value to encode.
708 * \return result encoded value.
709 */
710extern lbm_value lbm_enc_i32(int32_t x);
711
712/** Encode 32 bit unsigned integer into an lbm_value.
713 * \param x Value to encode.
714 * \return result encoded value.
715 */
716extern lbm_value lbm_enc_u32(uint32_t x);
717
718/** Encode a float into an lbm_value.
719 * \param x float value to encode.
720 * \return result encoded value.
721 */
722extern lbm_value lbm_enc_float(float x);
723
724/** Encode a 64 bit integer into an lbm_value.
725 * \param x 64 bit integer to encode.
726 * \return result encoded value.
727 */
728extern lbm_value lbm_enc_i64(int64_t x);
729
730/** Encode a 64 bit unsigned integer into an lbm_value.
731 * \param x 64 bit unsigned integer to encode.
732 * \return result encoded value.
733 */
734extern lbm_value lbm_enc_u64(uint64_t x);
735
736/** Encode a double into an lbm_value.
737 * \param x double to encode.
738 * \return result encoded value.
739 */
740extern lbm_value lbm_enc_double(double x);
741
742static inline lbm_value lbm_enc_char(uint8_t x) {
743 return ((lbm_uint)x << LBM_VAL_SHIFT4) | LBM_TYPE_CHAR0x00000004u;
744}
745
746static inline lbm_int lbm_dec_i(lbm_value x) {
747 return (lbm_int)x >> LBM_VAL_SHIFT4;
748}
749
750static inline lbm_uint lbm_dec_u(lbm_value x) {
751 return x >> LBM_VAL_SHIFT4;
752}
753
754static inline uint8_t lbm_dec_char(lbm_value x) {
755 return (uint8_t)(x >> LBM_VAL_SHIFT4);
756}
757
758static inline lbm_uint lbm_dec_sym(lbm_value x) {
759 return x >> LBM_VAL_SHIFT4;
760}
761
762/** Decode an lbm_value representing a float.
763 * \param x Value to decode.
764 * \return decoded float.
765 */
766extern float lbm_dec_float(lbm_value x);
767
768/** Decode an lbm_value representing a double.
769 * \param x Value to decode.
770 * \return decoded float.
771 */
772extern double lbm_dec_double(lbm_value x);
773
774
775static inline uint32_t lbm_dec_u32(lbm_value x) {
776#ifndef LBM64
777 return (uint32_t)lbm_car(x);
778#else
779 return (uint32_t)(x >> LBM_VAL_SHIFT4);
780#endif
781}
782
783/** Decode an lbm_value representing a 64 bit unsigned integer.
784 * \param x Value to decode.
785 * \return decoded uint64_t.
786 */
787extern uint64_t lbm_dec_u64(lbm_value x);
788
789static inline int32_t lbm_dec_i32(lbm_value x) {
790#ifndef LBM64
791 return (int32_t)lbm_car(x);
792#else
793 return (int32_t)(x >> LBM_VAL_SHIFT4);
794#endif
795}
796
797/** Decode an lbm_value representing a 64 bit integer.
798 * \param x Value to decode.
799 * \return decoded int64_t.
800 */
801extern int64_t lbm_dec_i64(lbm_value x);
802
803/**
804 * Check if a value is a heap pointer
805 * \param x Value to check
806 * \return true if x is a pointer to a heap cell, false otherwise.
807 */
808static inline bool_Bool lbm_is_ptr(lbm_value x) {
809 return (x & LBM_PTR_BIT0x00000001u);
810}
811
812/**
813 * Check if a value is a Read/Writeable cons cell
814 * \param x Value to check
815 * \return true if x is a Read/Writeable cons cell, false otherwise.
816 */
817static inline bool_Bool lbm_is_cons_rw(lbm_value x) {
818 return (lbm_type_of(x) == LBM_TYPE_CONS0x10000000u);
819}
820
821/**
822 * Check if a value is a Readable cons cell
823 * \param x Value to check
824 * \return true if x is a readable cons cell, false otherwise.
825 */
826static inline bool_Bool lbm_is_cons(lbm_value x) {
827 return lbm_is_ptr(x) && ((x & LBM_CONS_TYPE_MASK0xF0000000u) == LBM_TYPE_CONS0x10000000u);
828}
829
830/** Check if a value represents a number
831 * \param x Value to check.
832 * \return true is x represents a number and false otherwise.
833 */
834static inline bool_Bool lbm_is_number(lbm_value x) {
835 return
836 (x & LBM_PTR_BIT0x00000001u) ?
837 ((x & LBM_NUMBER_MASK0x08000000u) == LBM_NUMBER_MASK0x08000000u) :
838 (x & LBM_VAL_TYPE_MASK0x0000000Cu);
839}
840
841/** Check if value is an array that can be READ
842 * \param x Value to check.
843 * \return true if x represents a readable array and false otherwise.
844 */
845static inline bool_Bool lbm_is_array_r(lbm_value x) {
846 lbm_type t = lbm_type_of(x);
847 return ((t & LBM_PTR_TO_CONSTANT_MASK~0x04000000u) == LBM_TYPE_ARRAY0x80000000u);
848}
849
850static inline bool_Bool lbm_is_array_rw(lbm_value x) {
851 return( (lbm_type_of(x) == LBM_TYPE_ARRAY0x80000000u) && !(x & LBM_PTR_TO_CONSTANT_BIT0x04000000u));
852}
853
854static inline bool_Bool lbm_is_lisp_array_r(lbm_value x) {
855 lbm_type t = lbm_type_of(x);
856 return ((t & LBM_PTR_TO_CONSTANT_MASK~0x04000000u) == LBM_TYPE_LISPARRAY0xB0000000u);
857}
858
859static inline bool_Bool lbm_is_lisp_array_rw(lbm_value x) {
860 return( (lbm_type_of(x) == LBM_TYPE_LISPARRAY0xB0000000u) && !(x & LBM_PTR_TO_CONSTANT_BIT0x04000000u));
861}
862
863
864static inline bool_Bool lbm_is_channel(lbm_value x) {
865 return (lbm_type_of(x) == LBM_TYPE_CHANNEL0x90000000u &&
866 lbm_type_of(lbm_cdr(x)) == LBM_TYPE_SYMBOL0x00000000u &&
867 lbm_cdr(x) == ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
868}
869static inline bool_Bool lbm_is_char(lbm_value x) {
870 return (lbm_type_of(x) == LBM_TYPE_CHAR0x00000004u);
871}
872
873static inline bool_Bool lbm_is_special(lbm_value symrep) {
874 return ((lbm_type_of(symrep) == LBM_TYPE_SYMBOL0x00000000u) &&
875 (lbm_dec_sym(symrep) < SPECIAL_SYMBOLS_END0xFFFF));
876}
877
878static inline bool_Bool lbm_is_closure(lbm_value exp) {
879 return ((lbm_is_cons(exp)) &&
880 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
881 (lbm_car(exp) == ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u)));
882}
883
884static inline bool_Bool lbm_is_continuation(lbm_value exp) {
885 return ((lbm_type_of(exp) == LBM_TYPE_CONS0x10000000u) &&
886 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
887 (lbm_car(exp) == ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u)));
888}
889
890static inline bool_Bool lbm_is_macro(lbm_value exp) {
891 return ((lbm_type_of(exp) == LBM_TYPE_CONS0x10000000u) &&
892 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
893 (lbm_car(exp) == ENC_SYM_MACRO(((0x10D) << 4) | 0x00000000u)));
894}
895
896static inline bool_Bool lbm_is_match_binder(lbm_value exp) {
897 return (lbm_is_cons(exp) &&
898 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
899 (lbm_car(exp) == ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u)));
900}
901
902static inline bool_Bool lbm_is_comma_qualified_symbol(lbm_value exp) {
903 return (lbm_is_cons(exp) &&
904 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
905 (lbm_car(exp) == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) &&
906 (lbm_type_of(lbm_cadr(exp)) == LBM_TYPE_SYMBOL0x00000000u));
907}
908
909static inline bool_Bool lbm_is_symbol(lbm_value exp) {
910 return !(exp & LBM_LOW_RESERVED_BITS0x0000000Fu);
911}
912
913static inline bool_Bool lbm_is_symbol_nil(lbm_value exp) {
914 return !exp;
5
←
Assuming 'exp' is 0
→
6
←
Returning the value 1, which participates in a condition later
→
915}
916
917static inline bool_Bool lbm_is_symbol_true(lbm_value exp) {
918 return (lbm_is_symbol(exp) && exp == ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u));
919}
920
921static inline bool_Bool lbm_is_symbol_eval(lbm_value exp) {
922 return (lbm_is_symbol(exp) && exp == ENC_SYM_EVAL(((0x30008) << 4) | 0x00000000u));
923}
924
925static inline bool_Bool lbm_is_symbol_merror(lbm_value exp) {
926 return lbm_is_symbol(exp) && (exp == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
927}
928
929static inline bool_Bool lbm_is_list(lbm_value x) {
930 return (lbm_is_cons(x) || lbm_is_symbol_nil(x));
931}
932
933static inline bool_Bool lbm_is_list_rw(lbm_value x) {
934 return (lbm_is_cons_rw(x) || lbm_is_symbol_nil(x));
935}
936
937static inline bool_Bool lbm_is_quoted_list(lbm_value x) {
938 return (lbm_is_cons(x) &&
939 lbm_is_symbol(lbm_car(x)) &&
940 (lbm_car(x) == ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u)) &&
941 lbm_is_cons(lbm_cdr(x)) &&
942 lbm_is_cons(lbm_cadr(x)));
943}
944
945#ifndef LBM64
946#define ERROR_SYMBOL_MASK0xFFFFFFF0 0xFFFFFFF0
947#else
948#define ERROR_SYMBOL_MASK0xFFFFFFF0 0xFFFFFFFFFFFFFFF0
949#endif
950
951/* all error signaling symbols are in the range 0x20 - 0x2F */
952static inline bool_Bool lbm_is_error(lbm_value v){
953 return (lbm_is_symbol(v) &&
954 ((lbm_dec_sym(v) & ERROR_SYMBOL_MASK0xFFFFFFF0) == 0x20));
955}
956
957// ref_cell: returns a reference to the cell addressed by bits 3 - 26
958// Assumes user has checked that is_ptr was set
959static inline lbm_cons_t* lbm_ref_cell(lbm_value addr) {
960 return &lbm_dec_heap(addr)[lbm_dec_cons_cell_ptr(addr)];
961 //return &lbm_heap_state.heap[lbm_dec_ptr(addr)];
962}
963
964
965// lbm_uint a = lbm_heaps[0];
966// lbm_uint b = lbm_heaps[1];
967// lbm_uint i = (addr & LBM_PTR_TO_CONSTANT_BIT) >> LBM_PTR_TO_CONSTANT_SHIFT) - 1;
968// lbm_uint h = (a & i) | (b & ~i);
969
970#ifdef __cplusplus
971}
972#endif
973#endif
diff --git a/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-f53f44.html b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-f53f44.html new file mode 100644 index 00000000..686d76a1 --- /dev/null +++ b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-f53f44.html @@ -0,0 +1,6556 @@ + + + +src/eval_cps.c + + + + + + + + + + + + + + + + + + + + + + + + + + +

Bug Summary

+ + + + +
File:eval_cps.c
Warning:line 4254, column 23
Assigned value is garbage or undefined
+ +

Annotated Source Code

+

Press '?' + to see keyboard shortcuts

+ + +
clang -cc1 -triple i386-pc-linux-gnu -analyze -disable-free -disable-llvm-verifier -discard-value-names -main-file-name eval_cps.c -analyzer-store=region -analyzer-opt-analyze-nested-blocks -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -mrelocation-model static -mthread-model posix -mframe-pointer=none -fmath-errno -fno-rounding-math -masm-verbose -mconstructor-aliases -target-cpu i686 -dwarf-column-info -fno-split-dwarf-inlining -debugger-tuning=gdb -resource-dir /usr/lib/llvm-10/lib/clang/10.0.0 -I ./include -I ./include/extensions -I platform/linux/include -D _PRELUDE -internal-isystem /usr/local/include -internal-isystem /usr/lib/llvm-10/lib/clang/10.0.0/include -internal-externc-isystem /usr/include/i386-linux-gnu -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -std=c99 -fdebug-compilation-dir /home/joels/Current/lispbm -ferror-limit 19 -fmessage-length 0 -fgnuc-version=4.2.1 -fobjc-runtime=gcc -fdiagnostics-show-option -vectorize-loops -vectorize-slp -analyzer-output=html -faddrsig -o /home/joels/Current/lispbm/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1 -x c src/eval_cps.c +
+ + + +
+ + +
+ + + + +
+

src/eval_cps.c

+
→
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1/*
2 Copyright 2018, 2020 - 2024 Joel Svensson svenssonjoel@yahoo.se
3
4 This program is free software: you can redistribute it and/or modify
5 it under the terms of the GNU General Public License as published by
6 the Free Software Foundation, either version 3 of the License, or
7 (at your option) any later version.
8
9 This program is distributed in the hope that it will be useful,
10 but WITHOUT ANY WARRANTY; without even the implied warranty of
11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 GNU General Public License for more details.
13
14 You should have received a copy of the GNU General Public License
15 along with this program. If not, see <http://www.gnu.org/licenses/>.
16*/
17
18#include <lbm_memory.h>
19#include <lbm_types.h>
20#include "symrepr.h"
21#include "heap.h"
22#include "env.h"
23#include "eval_cps.h"
24#include "stack.h"
25#include "fundamental.h"
26#include "extensions.h"
27#include "tokpar.h"
28#include "lbm_channel.h"
29#include "print.h"
30#include "platform_mutex.h"
31#include "lbm_flat_value.h"
32#include "lbm_flags.h"
33
34#ifdef VISUALIZE_HEAP
35#include "heap_vis.h"
36#endif
37
38#include <setjmp.h>
39#include <stdarg.h>
40
41static jmp_buf error_jmp_buf;
42static jmp_buf critical_error_jmp_buf;
43
44#define S_TO_US(X)(lbm_uint)((X) * 1000000) (lbm_uint)((X) * 1000000)
45
46#define DEC_CONTINUATION(x)(((x) & ~0xF8000001u) >> 2) (((x) & ~LBM_CONTINUATION_INTERNAL0xF8000001u) >> LBM_ADDRESS_SHIFT2)
47#define IS_CONTINUATION(x)(((x) & 0xF8000001u) == 0xF8000001u) (((x) & LBM_CONTINUATION_INTERNAL0xF8000001u) == LBM_CONTINUATION_INTERNAL0xF8000001u)
48#define CONTINUATION(x)(((x) << 2) | 0xF8000001u) (((x) << LBM_ADDRESS_SHIFT2) | LBM_CONTINUATION_INTERNAL0xF8000001u)
49
50#define DONE(((0) << 2) | 0xF8000001u) CONTINUATION(0)(((0) << 2) | 0xF8000001u)
51#define SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u) CONTINUATION(1)(((1) << 2) | 0xF8000001u)
52#define BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u) CONTINUATION(2)(((2) << 2) | 0xF8000001u)
53#define IF(((3) << 2) | 0xF8000001u) CONTINUATION(3)(((3) << 2) | 0xF8000001u)
54#define PROGN_REST(((4) << 2) | 0xF8000001u) CONTINUATION(4)(((4) << 2) | 0xF8000001u)
55#define APPLICATION_ARGS(((5) << 2) | 0xF8000001u) CONTINUATION(5)(((5) << 2) | 0xF8000001u)
56#define AND(((6) << 2) | 0xF8000001u) CONTINUATION(6)(((6) << 2) | 0xF8000001u)
57#define OR(((7) << 2) | 0xF8000001u) CONTINUATION(7)(((7) << 2) | 0xF8000001u)
58#define WAIT(((8) << 2) | 0xF8000001u) CONTINUATION(8)(((8) << 2) | 0xF8000001u)
59#define MATCH(((9) << 2) | 0xF8000001u) CONTINUATION(9)(((9) << 2) | 0xF8000001u)
60#define APPLICATION_START(((10) << 2) | 0xF8000001u) CONTINUATION(10)(((10) << 2) | 0xF8000001u)
61#define EVAL_R(((11) << 2) | 0xF8000001u) CONTINUATION(11)(((11) << 2) | 0xF8000001u)
62#define RESUME(((12) << 2) | 0xF8000001u) CONTINUATION(12)(((12) << 2) | 0xF8000001u)
63#define CLOSURE_ARGS(((13) << 2) | 0xF8000001u) CONTINUATION(13)(((13) << 2) | 0xF8000001u)
64#define EXIT_ATOMIC(((14) << 2) | 0xF8000001u) CONTINUATION(14)(((14) << 2) | 0xF8000001u)
65#define READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u) CONTINUATION(15)(((15) << 2) | 0xF8000001u)
66#define READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u) CONTINUATION(16)(((16) << 2) | 0xF8000001u)
67#define READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u) CONTINUATION(17)(((17) << 2) | 0xF8000001u)
68#define READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u) CONTINUATION(18)(((18) << 2) | 0xF8000001u)
69#define READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u) CONTINUATION(19)(((19) << 2) | 0xF8000001u)
70#define READ_DONE(((20) << 2) | 0xF8000001u) CONTINUATION(20)(((20) << 2) | 0xF8000001u)
71#define READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u) CONTINUATION(21)(((21) << 2) | 0xF8000001u)
72#define READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u) CONTINUATION(22)(((22) << 2) | 0xF8000001u)
73#define READ_COMMA_RESULT(((23) << 2) | 0xF8000001u) CONTINUATION(23)(((23) << 2) | 0xF8000001u)
74#define READ_START_ARRAY(((24) << 2) | 0xF8000001u) CONTINUATION(24)(((24) << 2) | 0xF8000001u)
75#define READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u) CONTINUATION(25)(((25) << 2) | 0xF8000001u)
76#define MAP(((26) << 2) | 0xF8000001u) CONTINUATION(26)(((26) << 2) | 0xF8000001u)
77#define MATCH_GUARD(((27) << 2) | 0xF8000001u) CONTINUATION(27)(((27) << 2) | 0xF8000001u)
78#define TERMINATE(((28) << 2) | 0xF8000001u) CONTINUATION(28)(((28) << 2) | 0xF8000001u)
79#define PROGN_VAR(((29) << 2) | 0xF8000001u) CONTINUATION(29)(((29) << 2) | 0xF8000001u)
80#define SETQ(((30) << 2) | 0xF8000001u) CONTINUATION(30)(((30) << 2) | 0xF8000001u)
81#define MOVE_TO_FLASH(((31) << 2) | 0xF8000001u) CONTINUATION(31)(((31) << 2) | 0xF8000001u)
82#define MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u) CONTINUATION(32)(((32) << 2) | 0xF8000001u)
83#define MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u) CONTINUATION(33)(((33) << 2) | 0xF8000001u)
84#define CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u) CONTINUATION(34)(((34) << 2) | 0xF8000001u)
85#define QQ_EXPAND_START(((35) << 2) | 0xF8000001u) CONTINUATION(35)(((35) << 2) | 0xF8000001u)
86#define QQ_EXPAND(((36) << 2) | 0xF8000001u) CONTINUATION(36)(((36) << 2) | 0xF8000001u)
87#define QQ_APPEND(((37) << 2) | 0xF8000001u) CONTINUATION(37)(((37) << 2) | 0xF8000001u)
88#define QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u) CONTINUATION(38)(((38) << 2) | 0xF8000001u)
89#define QQ_LIST(((39) << 2) | 0xF8000001u) CONTINUATION(39)(((39) << 2) | 0xF8000001u)
90#define KILL(((40) << 2) | 0xF8000001u) CONTINUATION(40)(((40) << 2) | 0xF8000001u)
91#define LOOP(((41) << 2) | 0xF8000001u) CONTINUATION(41)(((41) << 2) | 0xF8000001u)
92#define LOOP_CONDITION(((42) << 2) | 0xF8000001u) CONTINUATION(42)(((42) << 2) | 0xF8000001u)
93#define MERGE_REST(((43) << 2) | 0xF8000001u) CONTINUATION(43)(((43) << 2) | 0xF8000001u)
94#define MERGE_LAYER(((44) << 2) | 0xF8000001u) CONTINUATION(44)(((44) << 2) | 0xF8000001u)
95#define CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u) CONTINUATION(45)(((45) << 2) | 0xF8000001u)
96#define MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u) CONTINUATION(46)(((46) << 2) | 0xF8000001u)
97#define POP_READER_FLAGS(((47) << 2) | 0xF8000001u) CONTINUATION(47)(((47) << 2) | 0xF8000001u)
98#define EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u) CONTINUATION(48)(((48) << 2) | 0xF8000001u)
99#define NUM_CONTINUATIONS49 49
100
101#define FM_NEED_GC-1 -1
102#define FM_NO_MATCH-2 -2
103#define FM_PATTERN_ERROR-3 -3
104
105typedef enum {
106 BL_OK = 0,
107 BL_NO_MEMORY,
108 BL_INCORRECT_KEY
109} binding_location_status;
110
111#define FB_OK0 0
112#define FB_TYPE_ERROR-1 -1
113
114const char* lbm_error_str_parse_eof = "End of parse stream.";
115const char* lbm_error_str_parse_dot = "Incorrect usage of '.'.";
116const char* lbm_error_str_parse_close = "Expected closing parenthesis.";
117const char* lbm_error_str_num_args = "Incorrect number of arguments.";
118const char* lbm_error_str_forbidden_in_atomic = "Operation is forbidden in an atomic block.";
119const char* lbm_error_str_no_number = "Argument(s) must be a number.";
120const char* lbm_error_str_not_a_boolean = "Argument must be t or nil (true or false).";
121const char* lbm_error_str_incorrect_arg = "Incorrect argument.";
122const char* lbm_error_str_var_outside_progn = "Usage of var outside of progn.";
123const char* lbm_error_str_flash_not_possible = "Value cannot be written to flash.";
124const char* lbm_error_str_flash_error = "Error writing to flash.";
125const char* lbm_error_str_flash_full = "Flash memory is full.";
126const char* lbm_error_str_variable_not_bound = "Variable not bound.";
127
128static lbm_value lbm_error_suspect;
129static bool_Bool lbm_error_has_suspect = false0;
130#ifdef LBM_ALWAYS_GC
131
132#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
133 gc(); \
134 (y) = (x); \
135 if (lbm_is_symbol_merror((y))) { \
136 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
137 }
138
139#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
140 lbm_gc_mark_phase(r); \
141 gc(); \
142 (y) = (x); \
143 if (lbm_is_symbol_merror((y))) { \
144 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
145 }
146
147#else
148
149#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
150 (y) = (x); \
151 if (lbm_is_symbol_merror((y))) { \
152 gc(); \
153 (y) = (x); \
154 if (lbm_is_symbol_merror((y))) { \
155 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
156 } \
157 /* continue executing statements below */ \
158 }
159#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
160 (y) = (x); \
161 if (lbm_is_symbol_merror((y))) { \
162 lbm_gc_mark_phase(r); \
163 gc(); \
164 (y) = (x); \
165 if (lbm_is_symbol_merror((y))) { \
166 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
167 } \
168 /* continue executing statements below */ \
169 }
170
171#endif
172
173typedef struct {
174 eval_context_t *first;
175 eval_context_t *last;
176} eval_context_queue_t;
177
178#ifdef CLEAN_UP_CLOSURES
179static lbm_value clean_cl_env_symbol = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
180#endif
181
182static int gc(void);
183static void error_ctx(lbm_value);
184static void error_at_ctx(lbm_value err_val, lbm_value at);
185static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx);
186static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail);
187
188// The currently executing context.
189eval_context_t *ctx_running = NULL((void*)0);
190volatile bool_Bool lbm_system_sleeping = false0;
191
192static volatile bool_Bool gc_requested = false0;
193void lbm_request_gc(void) {
194 gc_requested = true1;
195}
196
197/*
198 On ChibiOs the CH_CFG_ST_FREQUENCY setting in chconf.h sets the
199 resolution of the timer used for sleep operations. If this is set
200 to 10KHz the resolution is 100us.
201
202 The CH_CFG_ST_TIMEDELTA specifies the minimum number of ticks that
203 can be safely specified in a timeout directive (wonder if that
204 means sleep-period). The timedelta is set to 2.
205
206 If I have understood these correctly it means that the minimum
207 sleep duration possible is 2 * 100us = 200us.
208*/
209
210#define EVAL_CPS_DEFAULT_STACK_SIZE256 256
211#define EVAL_CPS_MIN_SLEEP200 200
212#define EVAL_STEPS_QUOTA10 10
213
214static volatile uint32_t eval_steps_refill = EVAL_STEPS_QUOTA10;
215static uint32_t eval_steps_quota = EVAL_STEPS_QUOTA10;
216
217void lbm_set_eval_step_quota(uint32_t quota) {
218 eval_steps_refill = quota;
219}
220
221static uint32_t eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
222static volatile uint32_t eval_cps_next_state = EVAL_CPS_STATE_NONE0;
223static volatile uint32_t eval_cps_next_state_arg = 0;
224static volatile bool_Bool eval_cps_state_changed = false0;
225
226static void usleep_nonsense(uint32_t us) {
227 (void) us;
228}
229
230static bool_Bool dynamic_load_nonsense(const char *sym, const char **code) {
231 (void) sym;
232 (void) code;
233 return false0;
234}
235
236static uint32_t timestamp_nonsense(void) {
237 return 0;
238}
239
240static int printf_nonsense(const char *fmt, ...) {
241 (void) fmt;
242 return 0;
243}
244
245static void ctx_done_nonsense(eval_context_t *ctx) {
246 (void) ctx;
247}
248
249static void critical_nonsense(void) {
250 return;
251}
252
253static void (*critical_error_callback)(void) = critical_nonsense;
254static void (*usleep_callback)(uint32_t) = usleep_nonsense;
255static uint32_t (*timestamp_us_callback)(void) = timestamp_nonsense;
256static void (*ctx_done_callback)(eval_context_t *) = ctx_done_nonsense;
257static int (*printf_callback)(const char *, ...) = printf_nonsense;
258static bool_Bool (*dynamic_load_callback)(const char *, const char **) = dynamic_load_nonsense;
259
260void lbm_set_critical_error_callback(void (*fptr)(void)) {
261 if (fptr == NULL((void*)0)) critical_error_callback = critical_nonsense;
262 else critical_error_callback = fptr;
263}
264
265void lbm_set_usleep_callback(void (*fptr)(uint32_t)) {
266 if (fptr == NULL((void*)0)) usleep_callback = usleep_nonsense;
267 else usleep_callback = fptr;
268}
269
270void lbm_set_timestamp_us_callback(uint32_t (*fptr)(void)) {
271 if (fptr == NULL((void*)0)) timestamp_us_callback = timestamp_nonsense;
272 else timestamp_us_callback = fptr;
273}
274
275void lbm_set_ctx_done_callback(void (*fptr)(eval_context_t *)) {
276 if (fptr == NULL((void*)0)) ctx_done_callback = ctx_done_nonsense;
277 else ctx_done_callback = fptr;
278}
279
280void lbm_set_printf_callback(int (*fptr)(const char*, ...)){
281 if (fptr == NULL((void*)0)) printf_callback = printf_nonsense;
282 else printf_callback = fptr;
283}
284
285void lbm_set_dynamic_load_callback(bool_Bool (*fptr)(const char *, const char **)) {
286 if (fptr == NULL((void*)0)) dynamic_load_callback = dynamic_load_nonsense;
287 else dynamic_load_callback = fptr;
288}
289
290static volatile lbm_event_t *lbm_events = NULL((void*)0);
291static unsigned int lbm_events_head = 0;
292static unsigned int lbm_events_tail = 0;
293static unsigned int lbm_events_max = 0;
294static bool_Bool lbm_events_full = false0;
295static mutex_t lbm_events_mutex;
296static bool_Bool lbm_events_mutex_initialized = false0;
297static volatile lbm_cid lbm_event_handler_pid = -1;
298
299lbm_cid lbm_get_event_handler_pid(void) {
300 return lbm_event_handler_pid;
301}
302
303void lbm_set_event_handler_pid(lbm_cid pid) {
304 lbm_event_handler_pid = pid;
305}
306
307bool_Bool lbm_event_handler_exists(void) {
308 return(lbm_event_handler_pid > 0);
309}
310
311
312static bool_Bool event_internal(lbm_event_type_t event_type, lbm_uint parameter, lbm_uint buf_ptr, lbm_uint buf_len) {
313 bool_Bool r = false0;
314 if (lbm_events) {
315 mutex_lock(&lbm_events_mutex);
316 if (!lbm_events_full) {
317 lbm_event_t event;
318 event.type = event_type;
319 event.parameter = parameter;
320 event.buf_ptr = buf_ptr;
321 event.buf_len = buf_len;
322 lbm_events[lbm_events_head] = event;
323 lbm_events_head = (lbm_events_head + 1) % lbm_events_max;
324 lbm_events_full = lbm_events_head == lbm_events_tail;
325 r = true1;
326 }
327 mutex_unlock(&lbm_events_mutex);
328 }
329 return r;
330}
331
332bool_Bool lbm_event_define(lbm_value key, lbm_flat_value_t *fv) {
333 return event_internal(LBM_EVENT_DEFINE, key, (lbm_uint)fv->buf, fv->buf_size);
334}
335
336bool_Bool lbm_event_unboxed(lbm_value unboxed) {
337 lbm_uint t = lbm_type_of(unboxed);
338 if (t == LBM_TYPE_SYMBOL0x00000000u ||
339 t == LBM_TYPE_I0x00000008u ||
340 t == LBM_TYPE_U0x0000000Cu ||
341 t == LBM_TYPE_CHAR0x00000004u) {
342 if (lbm_event_handler_pid > 0) {
343 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)unboxed, 0);
344 }
345 }
346 return false0;
347}
348
349bool_Bool lbm_event(lbm_flat_value_t *fv) {
350 if (lbm_event_handler_pid > 0) {
351 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)fv->buf, fv->buf_size);
352 }
353 return false0;
354}
355
356static bool_Bool lbm_event_pop(lbm_event_t *event) {
357 mutex_lock(&lbm_events_mutex);
358 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
359 mutex_unlock(&lbm_events_mutex);
360 return false0;
361 }
362 *event = lbm_events[lbm_events_tail];
363 lbm_events_tail = (lbm_events_tail + 1) % lbm_events_max;
364 lbm_events_full = false0;
365 mutex_unlock(&lbm_events_mutex);
366 return true1;
367}
368
369bool_Bool lbm_event_queue_is_empty(void) {
370 mutex_lock(&lbm_events_mutex);
371 bool_Bool empty = false0;
372 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
373 empty = true1;
374 }
375 mutex_unlock(&lbm_events_mutex);
376 return empty;
377}
378
379static bool_Bool eval_running = false0;
380static volatile bool_Bool blocking_extension = false0;
381static mutex_t blocking_extension_mutex;
382static bool_Bool blocking_extension_mutex_initialized = false0;
383static lbm_uint blocking_extension_timeout_us = 0;
384static bool_Bool blocking_extension_timeout = false0;
385
386static uint32_t is_atomic = 0;
387
388/* Process queues */
389static eval_context_queue_t blocked = {NULL((void*)0), NULL((void*)0)};
390static eval_context_queue_t queue = {NULL((void*)0), NULL((void*)0)};
391
392/* one mutex for all queue operations */
393mutex_t qmutex;
394bool_Bool qmutex_initialized = false0;
395
396
397// MODES
398static volatile bool_Bool lbm_verbose = false0;
399
400void lbm_toggle_verbose(void) {
401 lbm_verbose = !lbm_verbose;
402}
403
404void lbm_set_verbose(bool_Bool verbose) {
405 lbm_verbose = verbose;
406}
407
408lbm_cid lbm_get_current_cid(void) {
409 if (ctx_running)
410 return ctx_running->id;
411 else
412 return -1;
413}
414
415eval_context_t *lbm_get_current_context(void) {
416 return ctx_running;
417}
418
419/****************************************************/
420/* Utilities used locally in this file */
421
422static lbm_value cons_with_gc(lbm_value head, lbm_value tail, lbm_value remember) {
423#ifdef LBM_ALWAYS_GC
424 lbm_value roots[3] = {head, tail, remember};
425 lbm_gc_mark_roots(roots, 3);
426 gc();
427 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
428 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
429 if (lbm_is_symbol_merror(res)) {
430 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
431 }
432 return res;
433#else
434 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
435 if (lbm_is_symbol_merror(res)) {
436 lbm_value roots[3] = {head, tail, remember};
437 lbm_gc_mark_roots(roots,3);
438 gc();
439 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
440 if (lbm_is_symbol_merror(res)) {
441 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
442 }
443 }
444 return res;
445#endif
446}
447
448static lbm_uint *get_stack_ptr(eval_context_t *ctx, unsigned int n) {
449 if (n <= ctx->K.sp) {
450 lbm_uint index = ctx->K.sp - n;
451 return &ctx->K.data[index];
452 }
453 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
454 return 0; // dead code cannot be reached, but C compiler doesn't realise.
455}
456
457// pop_stack_ptr is safe when no GC is performed and
458// the values of the stack will be dropped.
459static lbm_uint *pop_stack_ptr(eval_context_t *ctx, unsigned int n) {
460 if (n <= ctx->K.sp) {
461 ctx->K.sp -= n;
462 return &ctx->K.data[ctx->K.sp];
463 }
464 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
465 return 0; // dead code cannot be reached, but C compiler doesn't realise.
466}
467
468static inline lbm_uint *stack_reserve(eval_context_t *ctx, unsigned int n) {
469 if (ctx->K.sp + n < ctx->K.size) {
470 lbm_uint *ptr = &ctx->K.data[ctx->K.sp];
471 ctx->K.sp += n;
472 return ptr;
473 }
474 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
475 return 0; // dead code cannot be reached, but C compiler doesn't realise.
476}
477
478static void handle_flash_status(lbm_flash_status s) {
479 if ( s == LBM_FLASH_FULL) {
480 lbm_set_error_reason((char*)lbm_error_str_flash_full);
481 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
482 }
483 if (s == LBM_FLASH_WRITE_ERROR) {
484 lbm_set_error_reason((char*)lbm_error_str_flash_error);
485 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
486 }
487}
488
489static void lift_array_flash(lbm_value flash_cell, bool_Bool bytearray, char *data, lbm_uint num_elt) {
490
491 lbm_array_header_t flash_array_header;
492 flash_array_header.size = num_elt;
493 flash_array_header.data = (lbm_uint*)data;
494 lbm_uint flash_array_header_ptr;
495 handle_flash_status(lbm_write_const_raw((lbm_uint*)&flash_array_header,
496 sizeof(lbm_array_header_t) / sizeof(lbm_uint),
497 &flash_array_header_ptr));
498 handle_flash_status(write_const_car(flash_cell, flash_array_header_ptr));
499 lbm_uint t = bytearray ? ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u) : ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u);
500 handle_flash_status(write_const_cdr(flash_cell, t));
501}
502
503static void get_car_and_cdr(lbm_value a, lbm_value *a_car, lbm_value *a_cdr) {
504 if (lbm_is_ptr(a)) {
19
←
Assuming the condition is false
→
20
←
Taking false branch
→
505 lbm_cons_t *cell = lbm_ref_cell(a);
506 *a_car = cell->car;
507 *a_cdr = cell->cdr;
508 } else if (lbm_is_symbol_nil(a)) {
21
←
Calling 'lbm_is_symbol_nil'
→
23
←
Returning from 'lbm_is_symbol_nil'
→
24
←
Taking false branch
→
509 *a_car = *a_cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
510 } else {
511 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
512 }
513}
25
←
Returning without writing to '*a_car'
→
514
515/* car cdr caar cadr replacements that are evaluator safe. */
516static lbm_value get_car(lbm_value a) {
517 if (lbm_is_ptr(a)) {
13
←
Taking true branch
→
518 lbm_cons_t *cell = lbm_ref_cell(a);
519 return cell->car;
14
←
Returning value, which participates in a condition later
→
520 } else if (lbm_is_symbol_nil(a)) {
521 return a;
522 }
523 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
524 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
525}
526
527static lbm_value get_cdr(lbm_value a) {
528 if (lbm_is_ptr(a)) {
529 lbm_cons_t *cell = lbm_ref_cell(a);
530 return cell->cdr;
531 } else if (lbm_is_symbol_nil(a)) {
532 return a;
533 }
534 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
535 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
536}
537
538static lbm_value get_cadr(lbm_value a) {
539 if (lbm_is_ptr(a)) {
540 lbm_cons_t *cell = lbm_ref_cell(a);
541 lbm_value tmp = cell->cdr;
542 if (lbm_is_ptr(tmp)) {
543 return lbm_ref_cell(tmp)->car;
544 } else if (lbm_is_symbol_nil(tmp)) {
545 return tmp;
546 }
547 } else if (lbm_is_symbol_nil(a)) {
548 return a;
549 }
550 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
551 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
552}
553
554static lbm_value allocate_closure(lbm_value params, lbm_value body, lbm_value env) {
555
556#ifdef LBM_ALWAYS_GC
557 gc();
558 if (lbm_heap_num_free() < 4) {
559 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
560 }
561#else
562 if (lbm_heap_num_free() < 4) {
563 gc();
564 if (lbm_heap_num_free() < 4) {
565 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
566 }
567 }
568#endif
569 // The freelist will always contain just plain heap-cells.
570 // So dec_ptr is sufficient.
571 lbm_value res = lbm_heap_state.freelist;
572 if (lbm_type_of(res) == LBM_TYPE_CONS0x10000000u) {
573 lbm_cons_t *heap = lbm_heap_state.heap;
574 lbm_uint ix = lbm_dec_ptr(res);
575 heap[ix].car = ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u);
576 ix = lbm_dec_ptr(heap[ix].cdr);
577 heap[ix].car = params;
578 ix = lbm_dec_ptr(heap[ix].cdr);
579 heap[ix].car = body;
580 ix = lbm_dec_ptr(heap[ix].cdr);
581 heap[ix].car = env;
582 lbm_heap_state.freelist = heap[ix].cdr;
583 heap[ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
584 lbm_heap_state.num_alloc+=4;
585 } else {
586 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
587 }
588 return res;
589}
590
591// Allocate a binding and attach it to a list (if so desired)
592static lbm_value allocate_binding(lbm_value key, lbm_value val, lbm_value the_cdr) {
593 if (lbm_heap_num_free() < 2) {
594 gc();
595 if (lbm_heap_num_free() < 2) {
596 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
597 }
598 }
599 lbm_cons_t* heap = lbm_heap_state.heap;
600 lbm_value binding_cell = lbm_heap_state.freelist;
601 lbm_uint binding_cell_ix = lbm_dec_ptr(binding_cell);
602 lbm_value list_cell = heap[binding_cell_ix].cdr;
603 lbm_uint list_cell_ix = lbm_dec_ptr(list_cell);
604 lbm_heap_state.freelist = heap[list_cell_ix].cdr;
605 lbm_heap_state.num_alloc += 2;
606 heap[binding_cell_ix].car = key;
607 heap[binding_cell_ix].cdr = val;
608 heap[list_cell_ix].car = binding_cell;
609 heap[list_cell_ix].cdr = the_cdr;
610 return list_cell;
611}
612
613#define CLO_PARAMS0 0
614#define CLO_BODY1 1
615#define CLO_ENV2 2
616#define LOOP_BINDS0 0
617#define LOOP_COND1 1
618#define LOOP_BODY2 2
619
620// (a b c) -> [a b c]
621static lbm_value extract_n(lbm_value curr, lbm_value *res, unsigned int n) {
622 for (unsigned int i = 0; i < n; i ++) {
623 if (lbm_is_ptr(curr)) {
624 lbm_cons_t *cell = lbm_ref_cell(curr);
625 res[i] = cell->car;
626 curr = cell->cdr;
627 } else {
628 res[i] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
629 }
630 }
631 return curr; // Rest of list is returned here.
632}
633
634static void call_fundamental(lbm_uint fundamental, lbm_value *args, lbm_uint arg_count, eval_context_t *ctx) {
635 lbm_value res;
636 res = fundamental_table[fundamental](args, arg_count, ctx);
637 if (lbm_is_error(res)) {
638 if (lbm_is_symbol_merror(res)) {
639 gc();
640 res = fundamental_table[fundamental](args, arg_count, ctx);
641 }
642 if (lbm_is_error(res)) {
643 error_at_ctx(res, lbm_enc_sym(FUNDAMENTAL_SYMBOLS_START0x20000 | fundamental));
644 }
645 }
646 lbm_stack_drop(&ctx->K, arg_count+1);
647 ctx->app_cont = true1;
648 ctx->r = res;
649}
650
651// block_current_ctx blocks a context until it is
652// woken up externally or a timeout period of time passes.
653static void block_current_ctx(uint32_t state, lbm_uint sleep_us, bool_Bool do_cont) {
654 ctx_running->timestamp = timestamp_us_callback();
655 ctx_running->sleep_us = sleep_us;
656 ctx_running->state = state;
657 ctx_running->app_cont = do_cont;
658 enqueue_ctx(&blocked, ctx_running);
659 ctx_running = NULL((void*)0);
660}
661
662lbm_flash_status lbm_write_const_array_padded(uint8_t *data, lbm_uint n, lbm_uint *res) {
663 lbm_uint full_words = n / sizeof(lbm_uint);
664 lbm_uint n_mod = n % sizeof(lbm_uint);
665
666 if (n_mod == 0) { // perfect fit.
667 return lbm_write_const_raw((lbm_uint*)data, full_words, res);
668 } else {
669 lbm_uint last_word = 0;
670 memcpy(&last_word, &data[full_words * sizeof(lbm_uint)], n_mod);
671 if (full_words >= 1) {
672 lbm_flash_status s = lbm_write_const_raw((lbm_uint*)data, full_words, res);
673 if ( s == LBM_FLASH_WRITE_OK) {
674 lbm_uint dummy;
675 s = lbm_write_const_raw(&last_word, 1, &dummy);
676 }
677 return s;
678 } else {
679 return lbm_write_const_raw(&last_word, 1, res);
680 }
681 }
682}
683
684/****************************************************/
685/* Error message creation */
686
687#define ERROR_MESSAGE_BUFFER_SIZE_BYTES256 256
688
689void print_environments(char *buf, unsigned int size) {
690
691 lbm_value curr_l = ctx_running->curr_env;
692 printf_callback("\tCurrent local environment:\n");
693 while (lbm_type_of(curr_l) == LBM_TYPE_CONS0x10000000u) {
694 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_l));
695 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_l)));
696 printf_callback("\t%s = %s\n", buf, buf+(size/2));
697 curr_l = lbm_cdr(curr_l);
698 }
699 printf_callback("\n\n");
700 printf_callback("\tCurrent global environment:\n");
701 lbm_value *glob_env = lbm_get_global_env();
702
703 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
704 lbm_value curr_g = glob_env[i];;
705 while (lbm_type_of(curr_g) == LBM_TYPE_CONS0x10000000u) {
706
707 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_g));
708 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_g)));
709 printf_callback("\t%s = %s\n", buf, buf+(size/2));
710 curr_g = lbm_cdr(curr_g);
711 }
712 }
713}
714
715void print_error_message(lbm_value error, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int col, lbm_int row0, lbm_int row1) {
716 if (!printf_callback) return;
717
718 /* try to allocate a lbm_print_value buffer on the lbm_memory */
719 char *buf = lbm_malloc_reserve(ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
720 if (!buf) {
721 printf_callback("Error: Not enough free memory to create a human readable error message\n");
722 return;
723 }
724
725 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, error);
726 printf_callback( "*** Error: %s\n", buf);
727 if (has_at) {
728 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, at);
729 printf_callback("*** In: %s\n",buf);
730 if (lbm_error_has_suspect) {
731 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, lbm_error_suspect);
732 lbm_error_has_suspect = false0;
733 printf_callback("*** At: %s\n", buf);
734 } else {
735 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
736 printf_callback("*** After: %s\n",buf);
737 }
738 } else {
739 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
740 printf_callback("*** Near: %s\n",buf);
741 }
742
743 printf_callback("\n");
744
745 if (lbm_is_symbol(error) &&
746 error == ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u)) {
747 printf_callback("*** Line: %u\n", row);
748 printf_callback("*** Column: %u\n", col);
749 } else if (row0 != -1 || row1 != -1 ) {
750 printf_callback("*** Between rows: (-1 unknown) \n");
751 printf_callback("*** Start: %d\n", (int32_t)row0);
752 printf_callback("*** End: %d\n", (int32_t)row1);
753 }
754
755 printf_callback("\n");
756
757 if (ctx_running->error_reason) {
758 printf_callback("Reason:\n %s\n\n", ctx_running->error_reason);
759 }
760 if (lbm_verbose) {
761 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
762 printf_callback(" In context: %d\n", ctx_running->id);
763 printf_callback(" Current intermediate result: %s\n\n", buf);
764
765 print_environments(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
766 printf_callback("\n\n");
767
768 printf_callback(" Stack:\n");
769 for (unsigned int i = 0; i < ctx_running->K.sp; i ++) {
770 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->K.data[i]);
771 printf_callback(" %s\n", buf);
772 }
773 }
774 lbm_free(buf);
775}
776
777/****************************************************/
778/* Tokenizing and parsing */
779
780bool_Bool create_string_channel(char *str, lbm_value *res) {
781
782 lbm_char_channel_t *chan = NULL((void*)0);
783 lbm_string_channel_state_t *st = NULL((void*)0);
784
785 st = (lbm_string_channel_state_t*)lbm_memory_allocate(sizeof(lbm_string_channel_state_t) / sizeof(lbm_uint) +1);
786 if (st == NULL((void*)0)) {
787 return false0;
788 }
789 chan = (lbm_char_channel_t*)lbm_memory_allocate(sizeof(lbm_char_channel_t) / sizeof(lbm_uint) + 1);
790 if (chan == NULL((void*)0)) {
791 lbm_memory_free((lbm_uint*)st);
792 return false0;
793 }
794
795 lbm_create_string_char_channel(st, chan, str);
796 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
797 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
798 lbm_memory_free((lbm_uint*)st);
799 lbm_memory_free((lbm_uint*)chan);
800 return false0;
801 }
802
803 *res = cell;
804 return true1;
805}
806
807bool_Bool lift_char_channel(lbm_char_channel_t *chan , lbm_value *res) {
808 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
809 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
810 return false0;
811 }
812 *res = cell;
813 return true1;
814}
815
816
817/****************************************************/
818/* Queue functions */
819
820static void queue_iterator_nm(eval_context_queue_t *q, ctx_fun f, void *arg1, void *arg2) {
821 eval_context_t *curr;
822 curr = q->first;
823
824 while (curr != NULL((void*)0)) {
825 f(curr, arg1, arg2);
826 curr = curr->next;
827 }
828}
829
830void lbm_running_iterator(ctx_fun f, void *arg1, void *arg2){
831 mutex_lock(&qmutex);
832 queue_iterator_nm(&queue, f, arg1, arg2);
833 mutex_unlock(&qmutex);
834}
835
836void lbm_blocked_iterator(ctx_fun f, void *arg1, void *arg2){
837 mutex_lock(&qmutex);
838 queue_iterator_nm(&blocked, f, arg1, arg2);
839 mutex_unlock(&qmutex);
840}
841
842static void enqueue_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
843 if (q->last == NULL((void*)0)) {
844 ctx->prev = NULL((void*)0);
845 ctx->next = NULL((void*)0);
846 q->first = ctx;
847 q->last = ctx;
848 } else {
849 ctx->prev = q->last;
850 ctx->next = NULL((void*)0);
851 q->last->next = ctx;
852 q->last = ctx;
853 }
854}
855
856static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx) {
857 mutex_lock(&qmutex);
858 enqueue_ctx_nm(q,ctx);
859 mutex_unlock(&qmutex);
860}
861
862static eval_context_t *lookup_ctx_nm(eval_context_queue_t *q, lbm_cid cid) {
863 eval_context_t *curr;
864 curr = q->first;
865 while (curr != NULL((void*)0)) {
866 if (curr->id == cid) {
867 return curr;
868 }
869 curr = curr->next;
870 }
871 return NULL((void*)0);
872}
873
874static bool_Bool drop_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
875
876 bool_Bool res = false0;
877 if (q->first == NULL((void*)0) || q->last == NULL((void*)0)) {
878 if (!(q->last == NULL((void*)0) && q->first == NULL((void*)0))) {
879 /* error state that should not happen */
880 return res;
881 }
882 /* Queue is empty */
883 return res;
884 }
885
886 eval_context_t *curr = q->first;
887 while (curr) {
888 if (curr->id == ctx->id) {
889 res = true1;
890 eval_context_t *tmp = curr->next;
891 if (curr->prev == NULL((void*)0)) {
892 if (curr->next == NULL((void*)0)) {
893 q->last = NULL((void*)0);
894 q->first = NULL((void*)0);
895 } else {
896 q->first = tmp;
897 tmp->prev = NULL((void*)0);
898 }
899 } else { /* curr->prev != NULL */
900 if (curr->next == NULL((void*)0)) {
901 q->last = curr->prev;
902 q->last->next = NULL((void*)0);
903 } else {
904 curr->prev->next = tmp;
905 tmp->prev = curr->prev;
906 }
907 }
908 break;
909 }
910 curr = curr->next;
911 }
912 return res;
913}
914
915/* End execution of the running context. */
916static void finish_ctx(void) {
917
918 if (!ctx_running) {
919 return;
920 }
921 /* Drop the continuation stack immediately to free up lbm_memory */
922 lbm_stack_free(&ctx_running->K);
923 ctx_done_callback(ctx_running);
924 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->name)) {
925 lbm_free(ctx_running->name);
926 }
927 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->error_reason)) {
928 lbm_memory_free((lbm_uint*)ctx_running->error_reason);
929 }
930 lbm_memory_free((lbm_uint*)ctx_running->mailbox);
931 lbm_memory_free((lbm_uint*)ctx_running);
932 ctx_running = NULL((void*)0);
933}
934
935static void context_exists(eval_context_t *ctx, void *cid, void *b) {
936 if (ctx->id == *(lbm_cid*)cid) {
937 *(bool_Bool*)b = true1;
938 }
939}
940
941bool_Bool lbm_wait_ctx(lbm_cid cid, lbm_uint timeout_ms) {
942
943 bool_Bool exists;
944 uint32_t i = 0;
945
946 do {
947 exists = false0;
948 lbm_blocked_iterator(context_exists, &cid, &exists);
949 lbm_running_iterator(context_exists, &cid, &exists);
950
951 if (ctx_running &&
952 ctx_running->id == cid) {
953 exists = true1;
954 }
955
956 if (exists) {
957 if (usleep_callback) {
958 usleep_callback(1000);
959 }
960 if (timeout_ms > 0) i ++;
961 }
962 } while (exists && i < timeout_ms);
963
964 if (exists) return false0;
965 return true1;
966}
967
968void lbm_set_error_suspect(lbm_value suspect) {
969 lbm_error_suspect = suspect;
970 lbm_error_has_suspect = true1;
971}
972
973void lbm_set_error_reason(char *error_str) {
974 if (ctx_running != NULL((void*)0)) {
975 ctx_running->error_reason = error_str;
976 }
977}
978
979// Not possible to CONS_WITH_GC in error_ctx_base (potential loop)
980static void error_ctx_base(lbm_value err_val, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int column) {
981
982 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
983 if (lbm_heap_num_free() < 3) {
984 gc();
985 }
986
987 if (lbm_heap_num_free() >= 3) {
988 lbm_value msg = lbm_cons(err_val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
989 msg = lbm_cons(lbm_enc_i(ctx_running->id), msg);
990 msg = lbm_cons(ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u), msg);
991 if (!lbm_is_symbol_merror(msg)) {
992 lbm_find_receiver_and_send(ctx_running->parent, msg);
993 goto error_ctx_base_done;
994 }
995 }
996 }
997 if ((ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10) &&
998 (err_val != ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u))) {
999 lbm_uint v;
1000 while (ctx_running->K.sp > 0) {
1001 lbm_pop(&ctx_running->K, &v);
1002 if (v == EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u)) {
1003 lbm_value *sptr = get_stack_ptr(ctx_running, 2);
1004 lbm_set_car(sptr[0], ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
1005 stack_reserve(ctx_running, 1)[0] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1006 ctx_running->app_cont = true1;
1007 ctx_running->r = err_val;
1008 longjmp(error_jmp_buf, 1);
1009 }
1010 }
1011 err_val = ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u);
1012 }
1013 print_error_message(err_val,
1014 has_at,
1015 at,
1016 row,
1017 column,
1018 ctx_running->row0,
1019 ctx_running->row1);
1020 error_ctx_base_done:
1021 ctx_running->r = err_val;
1022 finish_ctx();
1023 longjmp(error_jmp_buf, 1);
1024}
1025
1026static void error_at_ctx(lbm_value err_val, lbm_value at) {
1027 error_ctx_base(err_val, true1, at, 0, 0);
1028}
1029
1030static void error_ctx(lbm_value err_val) {
1031 error_ctx_base(err_val, false0, 0, 0, 0);
1032}
1033
1034static void read_error_ctx(unsigned int row, unsigned int column) {
1035 error_ctx_base(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u), false0, 0, row, column);
1036}
1037
1038void lbm_critical_error(void) {
1039 longjmp(critical_error_jmp_buf, 1);
1040}
1041
1042// successfully finish a context
1043static void ok_ctx(void) {
1044 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
1045 lbm_value msg;
1046 WITH_GC(msg, lbm_heap_allocate_list_init(3,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1047 ENC_SYM_EXIT_OK,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1048 lbm_enc_i(ctx_running->id),(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1049 ctx_running->r))(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
1050 lbm_find_receiver_and_send(ctx_running->parent, msg);
1051 }
1052 finish_ctx();
1053}
1054
1055static eval_context_t *dequeue_ctx_nm(eval_context_queue_t *q) {
1056 if (q->last == NULL((void*)0)) {
1057 return NULL((void*)0);
1058 }
1059 // q->first should only be NULL if q->last is.
1060 eval_context_t *res = q->first;
1061
1062 if (q->first == q->last) { // One thing in queue
1063 q->first = NULL((void*)0);
1064 q->last = NULL((void*)0);
1065 } else {
1066 q->first = q->first->next;
1067 q->first->prev = NULL((void*)0);
1068 }
1069 res->prev = NULL((void*)0);
1070 res->next = NULL((void*)0);
1071 return res;
1072}
1073
1074static void wake_up_ctxs_nm(void) {
1075 lbm_uint t_now;
1076
1077 if (timestamp_us_callback) {
1078 t_now = timestamp_us_callback();
1079 } else {
1080 t_now = 0;
1081 }
1082
1083 eval_context_queue_t *q = &blocked;
1084 eval_context_t *curr = q->first;
1085
1086 while (curr != NULL((void*)0)) {
1087 lbm_uint t_diff;
1088 eval_context_t *next = curr->next;
1089 if (curr->state != LBM_THREAD_STATE_BLOCKED(uint32_t)1) {
1090 if ( curr->timestamp > t_now) {
1091 /* There was an overflow on the counter */
1092#ifndef LBM64
1093 t_diff = (0xFFFFFFFF - curr->timestamp) + t_now;
1094#else
1095 t_diff = (0xFFFFFFFFFFFFFFFF - curr->timestamp) + t_now;
1096#endif
1097 } else {
1098 t_diff = t_now - curr->timestamp;
1099 }
1100
1101 if (t_diff >= curr->sleep_us) {
1102 eval_context_t *wake_ctx = curr;
1103 if (curr == q->last) {
1104 if (curr->prev) {
1105 q->last = curr->prev;
1106 q->last->next = NULL((void*)0);
1107 } else {
1108 q->first = NULL((void*)0);
1109 q->last = NULL((void*)0);
1110 }
1111 } else if (curr->prev == NULL((void*)0)) {
1112 q->first = curr->next;
1113 q->first->prev = NULL((void*)0);
1114 } else {
1115 curr->prev->next = curr->next;
1116 if (curr->next) {
1117 curr->next->prev = curr->prev;
1118 }
1119 }
1120 wake_ctx->next = NULL((void*)0);
1121 wake_ctx->prev = NULL((void*)0);
1122 if (curr->state == LBM_THREAD_STATE_TIMEOUT(uint32_t)2) {
1123 mailbox_add_mail(wake_ctx, ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u));
1124 wake_ctx->r = ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u);
1125 }
1126 wake_ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1127 enqueue_ctx_nm(&queue, wake_ctx);
1128 }
1129 }
1130 curr = next;
1131 }
1132}
1133
1134static void yield_ctx(lbm_uint sleep_us) {
1135 if (timestamp_us_callback) {
1136 ctx_running->timestamp = timestamp_us_callback();
1137 ctx_running->sleep_us = sleep_us;
1138 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1139 } else {
1140 ctx_running->timestamp = 0;
1141 ctx_running->sleep_us = 0;
1142 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1143 }
1144 ctx_running->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1145 ctx_running->app_cont = true1;
1146 enqueue_ctx(&blocked,ctx_running);
1147 ctx_running = NULL((void*)0);
1148}
1149
1150static lbm_cid lbm_create_ctx_parent(lbm_value program, lbm_value env, lbm_uint stack_size, lbm_cid parent, uint32_t context_flags, char *name) {
1151
1152 if (!lbm_is_cons(program)) return -1;
1153
1154 eval_context_t *ctx = NULL((void*)0);
1155
1156 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1157 if (ctx == NULL((void*)0)) {
1158 lbm_uint roots[2] = {program, env};
1159 lbm_gc_mark_roots(roots, 2);
1160 gc();
1161 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1162 }
1163 if (ctx == NULL((void*)0)) return -1;
1164
1165 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1166 lbm_uint roots[2] = {program, env};
1167 lbm_gc_mark_roots(roots, 2);
1168 gc();
1169 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1170 lbm_memory_free((lbm_uint*)ctx);
1171 return -1;
1172 }
1173 }
1174
1175 lbm_value *mailbox = NULL((void*)0);
1176 mailbox = (lbm_value*)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1177 if (mailbox == NULL((void*)0)) {
1178 lbm_value roots[2] = {program, env};
1179 lbm_gc_mark_roots(roots,2);
1180 gc();
1181 mailbox = (lbm_value *)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1182 }
1183 if (mailbox == NULL((void*)0)) {
1184 lbm_stack_free(&ctx->K);
1185 lbm_memory_free((lbm_uint*)ctx);
1186 return -1;
1187 }
1188
1189 // TODO: Limit names to 19 chars + 1 char for 0? (or something similar).
1190 if (name) {
1191 lbm_uint name_len = strlen(name) + 1;
1192 ctx->name = lbm_malloc(strlen(name) + 1);
1193 if (ctx->name == NULL((void*)0)) {
1194 lbm_value roots[2] = {program, env};
1195 lbm_gc_mark_roots(roots, 2);
1196 gc();
1197 ctx->name = lbm_malloc(strlen(name) + 1);
1198 }
1199 if (ctx->name == NULL((void*)0)) {
1200 lbm_stack_free(&ctx->K);
1201 lbm_memory_free((lbm_uint*)mailbox);
1202 lbm_memory_free((lbm_uint*)ctx);
1203 return -1;
1204 }
1205 memcpy(ctx->name, name, name_len+1);
1206 } else {
1207 ctx->name = NULL((void*)0);
1208 }
1209
1210 lbm_int cid = lbm_memory_address_to_ix((lbm_uint*)ctx);
1211
1212 ctx->program = lbm_cdr(program);
1213 ctx->curr_exp = lbm_car(program);
1214 ctx->curr_env = env;
1215 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1216 ctx->error_reason = NULL((void*)0);
1217 ctx->mailbox = mailbox;
1218 ctx->mailbox_size = EVAL_CPS_DEFAULT_MAILBOX_SIZE10;
1219 ctx->flags = context_flags;
1220 ctx->num_mail = 0;
1221 ctx->app_cont = false0;
1222 ctx->timestamp = 0;
1223 ctx->sleep_us = 0;
1224 ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1225 ctx->prev = NULL((void*)0);
1226 ctx->next = NULL((void*)0);
1227
1228 ctx->row0 = -1;
1229 ctx->row1 = -1;
1230
1231 ctx->id = cid;
1232 ctx->parent = parent;
1233
1234 if (!lbm_push(&ctx->K, DONE(((0) << 2) | 0xF8000001u))) {
1235 lbm_memory_free((lbm_uint*)ctx->mailbox);
1236 lbm_stack_free(&ctx->K);
1237 lbm_memory_free((lbm_uint*)ctx);
1238 return -1;
1239 }
1240
1241 enqueue_ctx(&queue,ctx);
1242
1243 return ctx->id;
1244}
1245
1246lbm_cid lbm_create_ctx(lbm_value program, lbm_value env, lbm_uint stack_size, char *name) {
1247 // Creates a parentless context.
1248 return lbm_create_ctx_parent(program,
1249 env,
1250 stack_size,
1251 -1,
1252 EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00,
1253 name);
1254}
1255
1256bool_Bool lbm_mailbox_change_size(eval_context_t *ctx, lbm_uint new_size) {
1257
1258 lbm_value *mailbox = NULL((void*)0);
1259 mailbox = (lbm_value*)lbm_memory_allocate(new_size);
1260 if (mailbox == NULL((void*)0)) {
1261 gc();
1262 mailbox = (lbm_value *)lbm_memory_allocate(new_size);
1263 }
1264 if (mailbox == NULL((void*)0)) {
1265 return false0;
1266 }
1267
1268 for (lbm_uint i = 0; i < ctx->num_mail; i ++ ) {
1269 mailbox[i] = ctx->mailbox[i];
1270 }
1271 lbm_memory_free(ctx->mailbox);
1272 ctx->mailbox = mailbox;
1273 ctx->mailbox_size = (uint32_t)new_size;
1274 return true1;
1275}
1276
1277static void mailbox_remove_mail(eval_context_t *ctx, lbm_uint ix) {
1278
1279 for (lbm_uint i = ix; i < ctx->num_mail-1; i ++) {
1280 ctx->mailbox[i] = ctx->mailbox[i+1];
1281 }
1282 ctx->num_mail --;
1283}
1284
1285static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail) {
1286
1287 if (ctx->num_mail >= ctx->mailbox_size) {
1288 mailbox_remove_mail(ctx, 0);
1289 }
1290
1291 ctx->mailbox[ctx->num_mail] = mail;
1292 ctx->num_mail ++;
1293 return true1;
1294}
1295
1296/* Advance execution to the next expression in the program */
1297static void advance_ctx(eval_context_t *ctx) {
1298 if (lbm_is_cons(ctx->program)) {
1299 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);;
1300 get_car_and_cdr(ctx->program, &ctx->curr_exp, &ctx->program);
1301 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1302 } else {
1303 if (ctx_running == ctx) { // This should always be the case because of odd historical reasons.
1304 ok_ctx();
1305 }
1306 }
1307}
1308
1309bool_Bool lbm_unblock_ctx(lbm_cid cid, lbm_flat_value_t *fv) {
1310 return event_internal(LBM_EVENT_UNBLOCK_CTX, (lbm_uint)cid, (lbm_uint)fv->buf, fv->buf_size);
1311}
1312
1313bool_Bool lbm_unblock_ctx_r(lbm_cid cid) {
1314 mutex_lock(&blocking_extension_mutex);
1315 bool_Bool r = false0;
1316 eval_context_t *found = NULL((void*)0);
1317 mutex_lock(&qmutex);
1318 found = lookup_ctx_nm(&blocked, cid);
1319 if (found) {
1320 drop_ctx_nm(&blocked,found);
1321 enqueue_ctx_nm(&queue,found);
1322 r = true1;
1323 }
1324 mutex_unlock(&qmutex);
1325 mutex_unlock(&blocking_extension_mutex);
1326 return r;
1327}
1328
1329// unblock unboxed is also safe for rmbr:ed things.
1330bool_Bool lbm_unblock_ctx_unboxed(lbm_cid cid, lbm_value unboxed) {
1331 mutex_lock(&blocking_extension_mutex);
1332 bool_Bool r = false0;
1333 eval_context_t *found = NULL((void*)0);
1334 mutex_lock(&qmutex);
1335 found = lookup_ctx_nm(&blocked, cid);
1336 if (found) {
1337 drop_ctx_nm(&blocked,found);
1338 found->r = unboxed;
1339 if (lbm_is_error(unboxed)) {
1340 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
1341 found->app_cont = true1;
1342 }
1343 enqueue_ctx_nm(&queue,found);
1344 r = true1;
1345 }
1346 mutex_unlock(&qmutex);
1347 mutex_unlock(&blocking_extension_mutex);
1348 return r;
1349}
1350
1351static bool_Bool lbm_block_ctx_base(bool_Bool timeout, float t_s) {
1352 mutex_lock(&blocking_extension_mutex);
1353 blocking_extension = true1;
1354 if (timeout) {
1355 blocking_extension_timeout_us = S_TO_US(t_s)(lbm_uint)((t_s) * 1000000);
1356 blocking_extension_timeout = true1;
1357 } else {
1358 blocking_extension_timeout = false0;
1359 }
1360 return true1;
1361}
1362
1363void lbm_block_ctx_from_extension_timeout(float s) {
1364 lbm_block_ctx_base(true1, s);
1365}
1366
1367void lbm_block_ctx_from_extension(void) {
1368 lbm_block_ctx_base(false0, 0);
1369}
1370
1371// todo: May need to pop rmbrs from stack, if present.
1372// Suspect that the letting the discard cont run is really not a problem.
1373// Either way will be quite confusing what happens to allocated things when undoing block.
1374void lbm_undo_block_ctx_from_extension(void) {
1375 blocking_extension = false0;
1376 blocking_extension_timeout_us = 0;
1377 blocking_extension_timeout = false0;
1378 mutex_unlock(&blocking_extension_mutex);
1379}
1380
1381lbm_value lbm_find_receiver_and_send(lbm_cid cid, lbm_value msg) {
1382 mutex_lock(&qmutex);
1383 eval_context_t *found = NULL((void*)0);
1384 bool_Bool found_blocked = false0;
1385
1386 found = lookup_ctx_nm(&blocked, cid);
1387 if (found) found_blocked = true1;
1388
1389 if (found == NULL((void*)0)) {
1390 found = lookup_ctx_nm(&queue, cid);
1391 }
1392
1393 if (found) {
1394 if (!mailbox_add_mail(found, msg)) {
1395 mutex_unlock(&qmutex);
1396 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1397 }
1398
1399 if (found_blocked){
1400 drop_ctx_nm(&blocked,found);
1401 enqueue_ctx_nm(&queue,found);
1402 }
1403 mutex_unlock(&qmutex);
1404 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1405 }
1406
1407 /* check the current context */
1408 if (ctx_running && ctx_running->id == cid) {
1409 if (!mailbox_add_mail(ctx_running, msg)) {
1410 mutex_unlock(&qmutex);
1411 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1412 }
1413 mutex_unlock(&qmutex);
1414 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1415 }
1416 mutex_unlock(&qmutex);
1417 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1418}
1419
1420/* Pattern matching is currently implemented as a recursive
1421 function and make use of stack relative to the size of
1422 expressions that are being matched. */
1423static bool_Bool match(lbm_value p, lbm_value e, lbm_value *env, bool_Bool *gc) {
1424
1425 lbm_value binding;
1426
1427 if (lbm_is_match_binder(p)) {
1428 lbm_value var = get_cadr(p);
1429 lbm_value bindertype = get_car(p);
1430
1431 if (!lbm_is_symbol(var)) return false0;
1432
1433 switch (bindertype) {
1434 case ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u):
1435 if ( var == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) {
1436 return true1;
1437 }
1438 break;
1439 default: /* this should be an error case */
1440 return false0;
1441 }
1442 binding = lbm_cons(var, e);
1443 if ( lbm_type_of(binding) == LBM_TYPE_SYMBOL0x00000000u ) {
1444 *gc = true1;
1445 return false0;
1446 }
1447 *env = lbm_cons(binding, *env);
1448 if ( lbm_type_of(*env) == LBM_TYPE_SYMBOL0x00000000u ) {
1449 *gc = true1;
1450 return false0;
1451 }
1452 return true1;
1453 }
1454
1455 if (lbm_is_symbol(p)) {
1456 if (p == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return true1;
1457 return (p == e);
1458 }
1459 if (lbm_is_cons(p) &&
1460 lbm_is_cons(e) ) {
1461
1462 lbm_value headp, tailp;
1463 lbm_value heade, taile;
1464 get_car_and_cdr(p, &headp, &tailp);
1465 get_car_and_cdr(e, &heade, &taile); // Static analysis warns, but execution does not
1466 // past this point unless head and tail get initialized.
1467 if (!match(headp, heade, env, gc)) {
1468 return false0;
1469 }
1470 return match (tailp, taile, env, gc);
1471 }
1472 return struct_eq(p, e);
1473}
1474
1475// Find match is not very picky about syntax.
1476// A completely malformed recv form is most likely to
1477// just return no_match.
1478static int find_match(lbm_value plist, lbm_value *earr, lbm_uint num, lbm_value *e, lbm_value *env) {
1479
1480 // A pattern list is a list of pattern, expression lists.
1481 // ( (p1 e1) (p2 e2) ... (pn en))
1482 lbm_value curr_p = plist;
1483 int n = 0;
1484 bool_Bool gc = false0;
1485 for (int i = 0; i < (int)num; i ++ ) {
1486 lbm_value curr_e = earr[i];
1487 while (!lbm_is_symbol_nil(curr_p)) {
1488 lbm_value me = get_car(curr_p);
1489 if (match(get_car(me), curr_e, env, &gc)) {
1490 if (gc) return FM_NEED_GC-1;
1491 *e = get_cadr(me);
1492
1493 if (!lbm_is_symbol_nil(get_cadr(get_cdr(me)))) {
1494 return FM_PATTERN_ERROR-3;
1495 }
1496 return n;
1497 }
1498 curr_p = get_cdr(curr_p);
1499 }
1500 curr_p = plist; /* search all patterns against next exp */
1501 n ++;
1502 }
1503
1504 return FM_NO_MATCH-2;
1505}
1506
1507/****************************************************/
1508/* Garbage collection */
1509
1510static void mark_context(eval_context_t *ctx, void *arg1, void *arg2) {
1511 (void) arg1;
1512 (void) arg2;
1513 lbm_value roots[3] = {ctx->curr_exp, ctx->program, ctx->r };
1514 lbm_gc_mark_env(ctx->curr_env);
1515 lbm_gc_mark_roots(roots, 3);
1516 lbm_gc_mark_roots(ctx->mailbox, ctx->num_mail);
1517 lbm_gc_mark_aux(ctx->K.data, ctx->K.sp);
1518}
1519
1520static int gc(void) {
1521 if (ctx_running) {
1522 ctx_running->state = ctx_running->state | LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1523 }
1524
1525 gc_requested = false0;
1526 lbm_gc_state_inc();
1527
1528 // The freelist should generally be NIL when GC runs.
1529 lbm_nil_freelist();
1530 lbm_value *env = lbm_get_global_env();
1531 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
1532 lbm_gc_mark_env(env[i]);
1533 }
1534
1535 mutex_lock(&qmutex); // Lock the queues.
1536 // Any concurrent messing with the queues
1537 // while doing GC cannot possibly be good.
1538 queue_iterator_nm(&queue, mark_context, NULL((void*)0), NULL((void*)0));
1539 queue_iterator_nm(&blocked, mark_context, NULL((void*)0), NULL((void*)0));
1540
1541 if (ctx_running) {
1542 mark_context(ctx_running, NULL((void*)0), NULL((void*)0));
1543 }
1544 mutex_unlock(&qmutex);
1545
1546#ifdef VISUALIZE_HEAP
1547 heap_vis_gen_image();
1548#endif
1549
1550 int r = lbm_gc_sweep_phase();
1551 lbm_heap_new_freelist_length();
1552
1553 if (ctx_running) {
1554 ctx_running->state = ctx_running->state & ~LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1555 }
1556 return r;
1557}
1558
1559int lbm_perform_gc(void) {
1560 return gc();
1561}
1562
1563/****************************************************/
1564/* Evaluation functions */
1565
1566
1567static void eval_symbol(eval_context_t *ctx) {
1568 lbm_uint s = lbm_dec_sym(ctx->curr_exp);
1569 if (s >= RUNTIME_SYMBOLS_START0x40000) {
1570 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1571 if (lbm_env_lookup_b(&res, ctx->curr_exp, ctx->curr_env) ||
1572 lbm_global_env_lookup(&res, ctx->curr_exp)) {
1573 ctx->r = res;
1574 ctx->app_cont = true1;
1575 return;
1576 }
1577 // Dynamic load attempt
1578 // Only symbols of kind RUNTIME can be dynamically loaded.
1579 const char *sym_str = lbm_get_name_by_symbol(s);
1580 const char *code_str = NULL((void*)0);
1581 if (!dynamic_load_callback(sym_str, &code_str)) {
1582 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), ctx->curr_exp);
1583 }
1584 lbm_value *sptr = stack_reserve(ctx, 3);
1585 sptr[0] = ctx->curr_exp;
1586 sptr[1] = ctx->curr_env;
1587 sptr[2] = RESUME(((12) << 2) | 0xF8000001u);
1588
1589 lbm_value chan;
1590 if (!create_string_channel((char *)code_str, &chan)) {
1591 gc();
1592 if (!create_string_channel((char *)code_str, &chan)) {
1593 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1594 }
1595 }
1596
1597 lbm_value loader;
1598 WITH_GC_RMBR_1(loader, lbm_heap_allocate_list_init(2,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1599 ENC_SYM_READ,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1600 chan), chan)(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} };
1601 lbm_value evaluator;
1602 WITH_GC_RMBR_1(evaluator, lbm_heap_allocate_list_init(2,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1603 ENC_SYM_EVAL,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1604 loader), loader)(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } };
1605 ctx->curr_exp = evaluator;
1606 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // dynamics should be evaluable in empty local env
1607 } else {
1608 //special symbols and extensions can be handled the same way.
1609 ctx->r = ctx->curr_exp;
1610 ctx->app_cont = true1;
1611 }
1612}
1613
1614static void eval_quote(eval_context_t *ctx) {
1615 ctx->r = get_cadr(ctx->curr_exp);
1616 ctx->app_cont = true1;
1617}
1618
1619static void eval_selfevaluating(eval_context_t *ctx) {
1620 ctx->r = ctx->curr_exp;
1621 ctx->app_cont = true1;
1622}
1623
1624static void eval_progn(eval_context_t *ctx) {
1625 lbm_value exps = get_cdr(ctx->curr_exp);
1626
1627 if (lbm_is_cons(exps)) {
1628 lbm_uint *sptr = stack_reserve(ctx, 4);
1629 sptr[0] = ctx->curr_env; // env to restore between expressions in progn
1630 sptr[1] = lbm_enc_u(0); // Has env been copied (needed for progn local bindings)
1631 sptr[3] = PROGN_REST(((4) << 2) | 0xF8000001u);
1632 get_car_and_cdr(exps, &ctx->curr_exp, &sptr[2]);
1633 if (lbm_is_symbol(sptr[2])) /* The only symbol it can be is nil */
1634 lbm_stack_drop(&ctx->K, 4);
1635 } else if (lbm_is_symbol_nil(exps)) {
1636 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1637 ctx->app_cont = true1;
1638 } else {
1639 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1640 }
1641}
1642
1643static void eval_atomic(eval_context_t *ctx) {
1644 if (is_atomic) {
1645 lbm_set_error_reason("Atomic blocks cannot be nested!");
1646 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1647 }
1648 stack_reserve(ctx, 1)[0] = EXIT_ATOMIC(((14) << 2) | 0xF8000001u);
1649 is_atomic ++;
1650 eval_progn(ctx);
1651}
1652
1653/* (call-cc (lambda (k) .... )) */
1654static void eval_callcc(eval_context_t *ctx) {
1655 lbm_value cont_array;
1656 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1657 gc();
1658 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1659 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1660 return; // dead return but static analysis doesn't know :)
1661 }
1662 }
1663 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(cont_array);
1664 memcpy(arr->data, ctx->K.data, ctx->K.sp * sizeof(lbm_uint));
1665
1666 lbm_value acont = cons_with_gc(ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u), cont_array, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1667 lbm_value arg_list = cons_with_gc(acont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1668 // Go directly into application evaluation without passing go
1669 lbm_uint *sptr = stack_reserve(ctx, 3);
1670 sptr[0] = ctx->curr_env;
1671 sptr[1] = arg_list;
1672 sptr[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
1673 ctx->curr_exp = get_cadr(ctx->curr_exp);
1674}
1675
1676// (define sym exp)
1677#define KEY1 1
1678#define VAL2 2
1679static void eval_define(eval_context_t *ctx) {
1680 lbm_value parts[3];
1681 lbm_value rest = extract_n(ctx->curr_exp, parts, 3);
1682 lbm_uint *sptr = stack_reserve(ctx, 2);
1683 if (lbm_is_symbol(parts[KEY1]) && lbm_is_symbol_nil(rest)) {
1684 lbm_uint sym_val = lbm_dec_sym(parts[KEY1]);
1685 sptr[0] = parts[KEY1];
1686 if (sym_val >= RUNTIME_SYMBOLS_START0x40000) {
1687 sptr[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
1688 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02) {
1689 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
1690 }
1691 ctx->curr_exp = parts[VAL2];
1692 return;
1693 }
1694 }
1695 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
1696}
1697
1698
1699/* Eval lambda is cheating, a lot! It does this
1700 for performance reasons. The cheats are that
1701 1. When closure is created, a reference to the local env
1702 in which the lambda was evaluated is added to the closure.
1703 Ideally it should have created a list of free variables in the function
1704 and then looked up the values of these creating a new environment.
1705 2. The global env is considered global constant. As there is no copying
1706 of environment bindings into the closure, undefine may break closures.
1707
1708 Correct closure creation is a lot more expensive than what happens here.
1709 However, one can try to write programs in such a way that closures are created
1710 seldomly. If one does that the space-usage benefits of "correct" closures
1711 may outweigh the performance gain of "incorrect" ones.
1712
1713 some obscure programs such as test_setq_local_closure.lisp does not
1714 work properly due to this cheating.
1715 */
1716// (lambda param-list body-exp) -> (closure param-list body-exp env)
1717static void eval_lambda(eval_context_t *ctx) {
1718 lbm_value vals[3];
1719 extract_n(ctx->curr_exp, vals, 3);
1720 ctx->r = allocate_closure(vals[1],vals[2], ctx->curr_env);
1721#ifdef CLEAN_UP_CLOSURES
1722 lbm_uint sym_id = 0;
1723 if (clean_cl_env_symbol) {
1724 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1725 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1726 ctx->curr_exp = app;
1727 } else if (lbm_get_symbol_by_name("clean-cl-env", &sym_id)) {
1728 clean_cl_env_symbol = lbm_enc_sym(sym_id);
1729 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1730 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1731 ctx->curr_exp = app;
1732 } else {
1733 ctx->app_cont = true1;
1734 }
1735#else
1736 ctx->app_cont = true1;
1737#endif
1738}
1739
1740// (if cond-expr then-expr else-expr)
1741static void eval_if(eval_context_t *ctx) {
1742 lbm_value cdr = get_cdr(ctx->curr_exp);
1743 lbm_value *sptr = stack_reserve(ctx, 3);
1744 sptr[0] = get_cdr(cdr);
1745 sptr[1] = ctx->curr_env;
1746 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1747 ctx->curr_exp = get_car(cdr);
1748}
1749
1750// (cond (cond-expr-1 expr-1)
1751// ...
1752// (cond-expr-N expr-N))
1753static void eval_cond(eval_context_t *ctx) {
1754 lbm_value cond1[2];
1755 lbm_value rest_conds = extract_n(ctx->curr_exp, cond1, 2);
1756
1757 // end recursion at (cond )
1758 if (lbm_is_symbol_nil(cond1[1])) {
1759 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1760 ctx->app_cont = true1;
1761 } else {
1762 // Cond is one of the few places where a bit of syntax checking takes place at runtime..
1763 // Maybe dont bother?
1764 lbm_uint len = lbm_list_length(cond1[1]);
1765 if (len != 2) {
1766 lbm_set_error_reason("Incorrect syntax in cond");
1767 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1768 }
1769 lbm_value cond_expr[2];
1770 extract_n(cond1[1], cond_expr, 2);
1771 lbm_value rest;
1772 WITH_GC(rest, lbm_heap_allocate_list_init(2,(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1773 cond_expr[1], // Then branch(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1774 cons_with_gc(ENC_SYM_COND, rest_conds , ENC_SYM_NIL)))(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
1775 lbm_value *sptr = stack_reserve(ctx, 3);
1776 sptr[0] = rest;
1777 sptr[1] = ctx->curr_env;
1778 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1779 ctx->curr_exp = cond_expr[0]; //condition;
1780 }
1781}
1782
1783static void eval_app_cont(eval_context_t *ctx) {
1784 lbm_stack_drop(&ctx->K, 1);
1785 ctx->app_cont = true1;
1786}
1787
1788// Create a named location in an environment to later receive a value.
1789static binding_location_status create_binding_location_internal(lbm_value key, lbm_value *env) {
1790
1791 if (lbm_is_symbol(key) &&
1792 (key == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u) ||
1793 key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)))
1794 return BL_OK;
1795
1796 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) { // default case
1797 lbm_value binding;
1798 lbm_value new_env_tmp;
1799 binding = lbm_cons(key, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1800 new_env_tmp = lbm_cons(binding, *env);
1801 if (lbm_is_symbol(binding) || lbm_is_symbol(new_env_tmp)) {
1802 return BL_NO_MEMORY;
1803 }
1804 *env = new_env_tmp;
1805 } else if (lbm_is_cons(key)) { // deconstruct case
1806 int r = create_binding_location_internal(get_car(key), env);
1807 if (r == BL_OK) {
1808 r = create_binding_location_internal(get_cdr(key), env);
1809 }
1810 return r;
1811 }
1812 return BL_OK;
1813}
1814
1815static void create_binding_location(lbm_value key, lbm_value *env) {
1816
1817 lbm_value env_tmp = *env;
1818 binding_location_status r = create_binding_location_internal(key, &env_tmp);
1819 if (r != BL_OK) {
1820 if (r == BL_NO_MEMORY) {
1821 env_tmp = *env;
1822 lbm_gc_mark_phase(env_tmp);
1823 gc();
1824 r = create_binding_location_internal(key, &env_tmp);
1825 }
1826 switch(r) {
1827 case BL_OK:
1828 break;
1829 case BL_NO_MEMORY:
1830 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1831 break;
1832 case BL_INCORRECT_KEY:
1833 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
1834 break;
1835 }
1836 }
1837 *env = env_tmp;
1838}
1839
1840static void let_bind_values_eval(lbm_value binds, lbm_value exp, lbm_value env, eval_context_t *ctx) {
1841
1842 if (!lbm_is_cons(binds)) {
1843 // binds better be nil or there is a programmer error.
1844 ctx->curr_exp = exp;
1845 return;
1846 }
1847
1848 // Preallocate binding locations.
1849 lbm_value curr = binds;
1850 while (lbm_is_cons(curr)) {
1851 lbm_value new_env_tmp = env;
1852 lbm_value car_curr, cdr_curr;
1853 get_car_and_cdr(curr, &car_curr, &cdr_curr);
1854 lbm_value key = get_car(car_curr);
1855 create_binding_location(key, &new_env_tmp);
1856 env = new_env_tmp;
1857 curr = cdr_curr;
1858 }
1859
1860 lbm_value car_binds;
1861 lbm_value cdr_binds;
1862 get_car_and_cdr(binds, &car_binds, &cdr_binds);
1863 lbm_value key_val[2];
1864 extract_n(car_binds, key_val, 2);
1865
1866 lbm_uint *sptr = stack_reserve(ctx, 5);
1867 sptr[0] = exp;
1868 sptr[1] = cdr_binds;
1869 sptr[2] = env;
1870 sptr[3] = key_val[0];
1871 sptr[4] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
1872 ctx->curr_exp = key_val[1];
1873 ctx->curr_env = env;
1874}
1875
1876// (var x (...)) - local binding inside of an progn
1877// var has to take, place root-level nesting within progn.
1878// (progn ... (var a 10) ...) OK!
1879// (progn ... (something (var a 10)) ... ) NOT OK!
1880/* progn stack
1881 sp-4 : env
1882 sp-3 : 0
1883 sp-2 : rest
1884 sp-1 : PROGN_REST
1885*/
1886static void eval_var(eval_context_t *ctx) {
1887
1888 if (ctx->K.sp >= 4) { // Possibly in progn
1889 lbm_value sv = ctx->K.data[ctx->K.sp - 1];
1890 if (IS_CONTINUATION(sv)(((sv) & 0xF8000001u) == 0xF8000001u) && (sv == PROGN_REST(((4) << 2) | 0xF8000001u))) {
1891 lbm_uint sp = ctx->K.sp;
1892 uint32_t is_copied = lbm_dec_as_u32(ctx->K.data[sp-3]);
1893 if (is_copied == 0) {
1894 lbm_value env;
1895 WITH_GC(env, lbm_env_copy_spine(ctx->K.data[sp-4]))(env) = (lbm_env_copy_spine(ctx->K.data[sp-4])); if (lbm_is_symbol_merror
((env))) { gc(); (env) = (lbm_env_copy_spine(ctx->K.data[sp
-4])); if (lbm_is_symbol_merror((env))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1896 ctx->K.data[sp-3] = lbm_enc_u(1);
1897 ctx->K.data[sp-4] = env;
1898 }
1899 lbm_value new_env = ctx->K.data[sp-4];
1900 lbm_value args = get_cdr(ctx->curr_exp);
1901 lbm_value key = get_car(args);
1902 create_binding_location(key, &new_env);
1903 ctx->K.data[sp-4] = new_env;
1904
1905 lbm_value v_exp = get_cadr(args);
1906 lbm_value *sptr = stack_reserve(ctx, 3);
1907 sptr[0] = new_env;
1908 sptr[1] = key;
1909 sptr[2] = PROGN_VAR(((29) << 2) | 0xF8000001u);
1910 // Activating the new environment before the evaluation of the value to be bound,
1911 // means that other variables with same name will be shadowed already in the value
1912 // body.
1913 // The way closures work, the var-variable needs to be in scope during val evaluation
1914 // for a recursive closure to be possible.
1915 ctx->curr_env = new_env;
1916 ctx->curr_exp = v_exp;
1917 return;
1918 }
1919 }
1920 lbm_set_error_reason((char*)lbm_error_str_var_outside_progn);
1921 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1922}
1923
1924// (setq x (...)) - same as (set 'x (...)) or (setvar 'x (...))
1925static void eval_setq(eval_context_t *ctx) {
1926 lbm_value parts[3];
1927 extract_n(ctx->curr_exp, parts, 3);
1928 lbm_value *sptr = stack_reserve(ctx, 3);
1929 sptr[0] = ctx->curr_env;
1930 sptr[1] = parts[1];
1931 sptr[2] = SETQ(((30) << 2) | 0xF8000001u);
1932 ctx->curr_exp = parts[2];
1933}
1934
1935static void eval_move_to_flash(eval_context_t *ctx) {
1936 lbm_value args = get_cdr(ctx->curr_exp);
1937 lbm_value *sptr = stack_reserve(ctx,2);
1938 sptr[0] = args;
1939 sptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
1940 ctx->app_cont = true1;
1941}
1942
1943// (loop list-of-local-bindings
1944// condition-exp
1945// body-exp)
1946static void eval_loop(eval_context_t *ctx) {
1947 lbm_value env = ctx->curr_env;
1948 lbm_value parts[3];
1949 extract_n(get_cdr(ctx->curr_exp), parts, 3);
1950 lbm_value *sptr = stack_reserve(ctx, 3);
1951 sptr[0] = parts[LOOP_BODY2];
1952 sptr[1] = parts[LOOP_COND1];
1953 sptr[2] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
1954 let_bind_values_eval(parts[LOOP_BINDS0], parts[LOOP_COND1], env, ctx);
1955}
1956
1957/* (trap expression)
1958 *
1959 * suggested use:
1960 * (match (trap expression)
1961 * ((exit-error (? err)) (error-handler err))
1962 * ((exit-ok (? v)) (value-handler v)))
1963 */
1964static void eval_trap(eval_context_t *ctx) {
1965
1966 lbm_value expr = get_cadr(ctx->curr_exp);
1967 lbm_value retval;
1968 WITH_GC(retval, lbm_heap_allocate_list(2))(retval) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((retval))) { gc(); (retval) = (lbm_heap_allocate_list(2)); if
(lbm_is_symbol_merror((retval))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1969 lbm_set_car(retval, ENC_SYM_EXIT_OK(((0x3000B) << 4) | 0x00000000u)); // Assume things will go well.
1970 lbm_uint *sptr = stack_reserve(ctx,3);
1971 sptr[0] = retval;
1972 sptr[1] = ctx->flags;
1973 sptr[2] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1974 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10;
1975 ctx->curr_exp = expr;
1976}
1977
1978// (let list-of-binding s
1979// body-exp)
1980static void eval_let(eval_context_t *ctx) {
1981 lbm_value env = ctx->curr_env;
1982 lbm_value parts[3];
1983 extract_n(ctx->curr_exp, parts, 3);
1984 let_bind_values_eval(parts[1], parts[2], env, ctx);
1985}
1986
1987// (and exp0 ... expN)
1988static void eval_and(eval_context_t *ctx) {
1989 lbm_value rest = get_cdr(ctx->curr_exp);
1990 if (lbm_is_symbol_nil(rest)) {
1991 ctx->app_cont = true1;
1992 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1993 } else {
1994 lbm_value *sptr = stack_reserve(ctx, 3);
1995 sptr[0] = ctx->curr_env;
1996 sptr[1] = get_cdr(rest);
1997 sptr[2] = AND(((6) << 2) | 0xF8000001u);
1998 ctx->curr_exp = get_car(rest);
1999 }
2000}
2001
2002// (or exp0 ... expN)
2003static void eval_or(eval_context_t *ctx) {
2004 lbm_value rest = get_cdr(ctx->curr_exp);
2005 if (lbm_is_symbol_nil(rest)) {
2006 ctx->app_cont = true1;
2007 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2008 } else {
2009 lbm_value *sptr = stack_reserve(ctx, 3);
2010 sptr[0] = ctx->curr_env;
2011 sptr[1] = get_cdr(rest);
2012 sptr[2] = OR(((7) << 2) | 0xF8000001u);
2013 ctx->curr_exp = get_car(rest);
2014 }
2015}
2016
2017// Pattern matching
2018// format:
2019// (match e (pattern body)
2020// (pattern body)
2021// ... )
2022//
2023// There can be an optional pattern guard:
2024// (match e (pattern guard body)
2025// ... )
2026// a guard is a boolean expression.
2027// Guards make match, pattern matching more complicated
2028// than the recv pattern matching and requires staged execution
2029// via the continuation system rather than a while loop over a list.
2030static void eval_match(eval_context_t *ctx) {
2031
2032 lbm_value rest = get_cdr(ctx->curr_exp);
2033 if (lbm_type_of(rest) == LBM_TYPE_SYMBOL0x00000000u &&
2034 rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
2035 // Someone wrote the program (match)
2036 ctx->app_cont = true1;
2037 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2038 } else {
2039 lbm_value cdr_rest;
2040 get_car_and_cdr(rest, &ctx->curr_exp, &cdr_rest);
2041 lbm_value *sptr = stack_reserve(ctx, 3);
2042 sptr[0] = cdr_rest;
2043 sptr[1] = ctx->curr_env;
2044 sptr[2] = MATCH(((9) << 2) | 0xF8000001u);
2045 }
2046}
2047
2048static void receive_base(eval_context_t *ctx, lbm_value pats, float timeout_time, bool_Bool timeout) {
2049 if (ctx->num_mail == 0) {
2050 if (timeout) {
2051 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000), false0);
2052 } else {
2053 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1,0,false0);
2054 }
2055 } else {
2056 lbm_value *msgs = ctx->mailbox;
2057 lbm_uint num = ctx->num_mail;
2058
2059 if (lbm_is_symbol_nil(pats)) {
2060 /* A receive statement without any patterns */
2061 ctx->app_cont = true1;
2062 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2063 } else {
2064 /* The common case */
2065 lbm_value e;
2066 lbm_value new_env = ctx->curr_env;
2067 int n = find_match(pats, msgs, num, &e, &new_env);
2068 if (n == FM_NEED_GC-1) {
2069 gc();
2070 new_env = ctx->curr_env;
2071 n = find_match(pats, msgs, num, &e, &new_env);
2072 if (n == FM_NEED_GC-1) {
2073 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2074 }
2075 }
2076 if (n == FM_PATTERN_ERROR-3) {
2077 lbm_set_error_reason("Incorrect pattern format for recv");
2078 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),pats);
2079 } else if (n >= 0 ) { /* Match */
2080 mailbox_remove_mail(ctx, (lbm_uint)n);
2081 ctx->curr_env = new_env;
2082 ctx->curr_exp = e;
2083 } else { /* No match go back to sleep */
2084 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
2085 if (timeout) {
2086 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2,S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000),false0);
2087 } else {
2088 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,false0);
2089 }
2090 }
2091 }
2092 }
2093 return;
2094}
2095
2096static void eval_receive_timeout(eval_context_t *ctx) {
2097 if (is_atomic) {
2098 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2099 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2100 }
2101 lbm_value timeout_val = get_cadr(ctx->curr_exp);
2102 if (!lbm_is_number(timeout_val)) {
2103 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2104 }
2105 float timeout_time = lbm_dec_as_float(timeout_val);
2106 lbm_value pats = get_cdr(get_cdr(ctx->curr_exp));
2107 receive_base(ctx, pats, timeout_time, true1);
2108}
2109
2110// Receive
2111// (recv (pattern expr)
2112// (pattern expr))
2113static void eval_receive(eval_context_t *ctx) {
2114
2115 if (is_atomic) {
2116 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2117 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
2118 }
2119 lbm_value pats = get_cdr(ctx->curr_exp);
2120 receive_base(ctx, pats, 0, false0);
2121}
2122
2123/*********************************************************/
2124/* Continuation functions */
2125
2126/* cont_set_global_env
2127 sp-1 : Key-symbol
2128 */
2129static void cont_set_global_env(eval_context_t *ctx){
2130
2131 lbm_value key;
2132 lbm_value val = ctx->r;
2133
2134 lbm_pop(&ctx->K, &key);
2135 lbm_uint dec_key = lbm_dec_sym(key);
2136 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
2137 lbm_value *global_env = lbm_get_global_env();
2138 lbm_uint orig_env = global_env[ix_key];
2139 lbm_value new_env;
2140 // A key is a symbol and should not need to be remembered.
2141 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2142
2143 global_env[ix_key] = new_env;
2144 ctx->r = val;
2145
2146 ctx->app_cont = true1;
2147
2148 return;
2149}
2150
2151static void cont_resume(eval_context_t *ctx) {
2152 lbm_pop_2(&ctx->K, &ctx->curr_env, &ctx->curr_exp);
2153}
2154
2155static void cont_progn_rest(eval_context_t *ctx) {
2156 lbm_value *sptr = get_stack_ptr(ctx, 3);
2157
2158 lbm_value rest = sptr[2];
2159 lbm_value env = sptr[0];
2160
2161 lbm_value rest_car, rest_cdr;
2162 get_car_and_cdr(rest, &rest_car, &rest_cdr);
2163 ctx->curr_exp = rest_car;
2164 ctx->curr_env = env;
2165 if (lbm_is_symbol_nil(rest_cdr)) {
2166 // allow for tail recursion
2167 lbm_stack_drop(&ctx->K, 3);
2168 } else {
2169 sptr[2] = rest_cdr;
2170 stack_reserve(ctx, 1)[0] = PROGN_REST(((4) << 2) | 0xF8000001u);
2171 }
2172}
2173
2174static void cont_wait(eval_context_t *ctx) {
2175
2176 lbm_value cid_val;
2177 lbm_pop(&ctx->K, &cid_val);
2178 lbm_cid cid = (lbm_cid)lbm_dec_i(cid_val);
2179
2180 bool_Bool exists = false0;
2181
2182 lbm_blocked_iterator(context_exists, &cid, &exists);
2183 lbm_running_iterator(context_exists, &cid, &exists);
2184
2185 if (ctx_running->id == cid) {
2186 exists = true1;
2187 }
2188
2189 if (exists) {
2190 lbm_value *sptr = stack_reserve(ctx, 2);
2191 sptr[0] = lbm_enc_i(cid);
2192 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2193 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2194 ctx->app_cont = true1;
2195 yield_ctx(50000);
2196 } else {
2197 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2198 ctx->app_cont = true1;
2199 }
2200}
2201
2202static lbm_value perform_setvar(lbm_value key, lbm_value val, lbm_value env) {
2203
2204 lbm_uint s = lbm_dec_sym(key);
2205 if (s >= RUNTIME_SYMBOLS_START0x40000) {
2206 lbm_value new_env = lbm_env_modify_binding(env, key, val);
2207 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2208 lbm_uint ix_key = lbm_dec_sym(key) & GLOBAL_ENV_MASK0x1F;
2209 lbm_value *glob_env = lbm_get_global_env();
2210 new_env = lbm_env_modify_binding(glob_env[ix_key], key, val);
2211 glob_env[ix_key] = new_env;
2212 }
2213 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2214 lbm_set_error_reason((char*)lbm_error_str_variable_not_bound);
2215 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), key);
2216 }
2217 return val;
2218 }
2219 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2220 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // unreachable
2221}
2222
2223static void apply_setvar(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2224 if (nargs == 2 && lbm_is_symbol(args[0])) {
2225 lbm_value res;
2226 WITH_GC(res, perform_setvar(args[0], args[1], ctx->curr_env))(res) = (perform_setvar(args[0], args[1], ctx->curr_env));
if (lbm_is_symbol_merror((res))) { gc(); (res) = (perform_setvar
(args[0], args[1], ctx->curr_env)); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2227 ctx->r = args[1];
2228 lbm_stack_drop(&ctx->K, nargs+1);
2229 ctx->app_cont = true1;
2230 } else {
2231 if (nargs == 2) lbm_set_error_reason((char*)lbm_error_str_incorrect_arg);
2232 else lbm_set_error_reason((char*)lbm_error_str_num_args);
2233 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2234 }
2235}
2236
2237static void apply_read_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, bool_Bool program, bool_Bool incremental) {
2238 if (nargs == 1) {
2239 lbm_value chan = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2240 if (lbm_type_of_functional(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2241 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2242 gc();
2243 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2244 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2245 }
2246 }
2247 } else if (lbm_type_of(args[0]) == LBM_TYPE_CHANNEL0x90000000u) {
2248 chan = args[0];
2249 } else {
2250 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2251 }
2252 lbm_value *sptr = get_stack_ptr(ctx, 2);
2253
2254 // If we are inside a reader, its settings are stored.
2255 sptr[0] = lbm_enc_u(ctx->flags); // flags stored.
2256 sptr[1] = chan;
2257 lbm_value *rptr = stack_reserve(ctx,1);
2258 rptr[0] = READ_DONE(((20) << 2) | 0xF8000001u);
2259
2260 // Each reader starts in a fresh situation
2261 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
2262
2263 if (program) {
2264 if (incremental) {
2265 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2266 lbm_value *rptr1 = stack_reserve(ctx,3);
2267 rptr1[0] = chan;
2268 rptr1[1] = ctx->curr_env;
2269 rptr1[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
2270 } else {
2271 ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2272 lbm_value *rptr1 = stack_reserve(ctx,4);
2273 rptr1[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2274 rptr1[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2275 rptr1[2] = chan;
2276 rptr1[3] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
2277 }
2278 }
2279 rptr = stack_reserve(ctx,3); // reuse of variable rptr
2280 rptr[0] = chan;
2281 rptr[1] = lbm_enc_u(1);
2282 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
2283 ctx->app_cont = true1;
2284 } else {
2285 lbm_set_error_reason((char*)lbm_error_str_num_args);
2286 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2287 }
2288}
2289
2290static void apply_read_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2291 apply_read_base(args,nargs,ctx,true1,false0);
2292}
2293
2294static void apply_read_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2295 apply_read_base(args,nargs,ctx,true1,true1);
2296}
2297
2298static void apply_read(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2299 apply_read_base(args,nargs,ctx,false0,false0);
2300}
2301
2302static void apply_spawn_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, uint32_t context_flags) {
2303
2304 lbm_uint stack_size = EVAL_CPS_DEFAULT_STACK_SIZE256;
2305 lbm_uint closure_pos = 0;
2306 char *name = NULL((void*)0);
2307
2308 if (nargs >= 1 &&
2309 lbm_is_closure(args[0])) {
2310 closure_pos = 0;
2311 } else if (nargs >= 2 &&
2312 lbm_is_number(args[0]) &&
2313 lbm_is_closure(args[1])) {
2314 stack_size = lbm_dec_as_u32(args[0]);
2315 closure_pos = 1;
2316 } else if (nargs >= 2 &&
2317 lbm_is_array_r(args[0]) &&
2318 lbm_is_closure(args[1])) {
2319 name = lbm_dec_str(args[0]);
2320 closure_pos = 1;
2321 }else if (nargs >= 3 &&
2322 lbm_is_array_r(args[0]) &&
2323 lbm_is_number(args[1]) &&
2324 lbm_is_closure(args[2])) {
2325 stack_size = lbm_dec_as_u32(args[1]);
2326 closure_pos = 2;
2327 name = lbm_dec_str(args[0]);
2328 } else {
2329 if (context_flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01)
2330 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN_TRAP(((0x30005) << 4) | 0x00000000u));
2331 else
2332 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN(((0x30004) << 4) | 0x00000000u));
2333 }
2334
2335 lbm_value cl[3];
2336 extract_n(get_cdr(args[closure_pos]), cl, 3);
2337 lbm_value curr_param = cl[CLO_PARAMS0];
2338 lbm_value clo_env = cl[CLO_ENV2];
2339 lbm_uint i = closure_pos + 1;
2340 while (lbm_is_cons(curr_param) && i <= nargs) {
2341 lbm_value entry = cons_with_gc(get_car(curr_param), args[i], clo_env);
2342 lbm_value aug_env = cons_with_gc(entry, clo_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2343 clo_env = aug_env;
2344 curr_param = get_cdr(curr_param);
2345 i ++;
2346 }
2347
2348 lbm_stack_drop(&ctx->K, nargs+1);
2349
2350 lbm_value program = cons_with_gc(cl[CLO_BODY1], ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), clo_env);
2351
2352 lbm_cid cid = lbm_create_ctx_parent(program,
2353 clo_env,
2354 stack_size,
2355 lbm_get_current_cid(),
2356 context_flags,
2357 name);
2358 ctx->r = lbm_enc_i(cid);
2359 ctx->app_cont = true1;
2360}
2361
2362static void apply_spawn(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2363 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00);
2364}
2365
2366static void apply_spawn_trap(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2367 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01);
2368}
2369
2370static void apply_yield(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2371 if (is_atomic) {
2372 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2373 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2374 }
2375 if (nargs == 1 && lbm_is_number(args[0])) {
2376 lbm_uint ts = lbm_dec_as_u32(args[0]);
2377 lbm_stack_drop(&ctx->K, nargs+1);
2378 yield_ctx(ts);
2379 } else {
2380 lbm_set_error_reason((char*)lbm_error_str_no_number);
2381 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2382 }
2383}
2384
2385static void apply_sleep(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2386 if (is_atomic) {
2387 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2388 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2389 }
2390 if (nargs == 1 && lbm_is_number(args[0])) {
2391 lbm_uint ts = (lbm_uint)(1000000.0f * lbm_dec_as_float(args[0]));
2392 lbm_stack_drop(&ctx->K, nargs+1);
2393 yield_ctx(ts);
2394 } else {
2395 lbm_set_error_reason((char*)lbm_error_str_no_number);
2396 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2397 }
2398}
2399
2400static void apply_wait(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2401 if (nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2402 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2403 lbm_value *sptr = get_stack_ptr(ctx, 2);
2404 sptr[0] = lbm_enc_i(cid);
2405 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2406 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2407 ctx->app_cont = true1;
2408 yield_ctx(50000);
2409 } else {
2410 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_WAIT(((0x30007) << 4) | 0x00000000u));
2411 }
2412}
2413
2414/* (eval expr)
2415 (eval env expr) */
2416static void apply_eval(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2417 if ( nargs == 1) {
2418 ctx->curr_exp = args[0];
2419 } else if (nargs == 2) {
2420 ctx->curr_exp = args[1];
2421 ctx->curr_env = args[0];
2422 } else {
2423 lbm_set_error_reason((char*)lbm_error_str_num_args);
2424 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL(((0x30008) << 4) | 0x00000000u));
2425 }
2426 lbm_stack_drop(&ctx->K, nargs+1);
2427}
2428
2429static void apply_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2430 int prg_pos = 0;
2431 if (nargs == 2) {
2432 prg_pos = 1;
2433 ctx->curr_env = args[0];
2434 }
2435 if (nargs == 1 || nargs == 2) {
2436 lbm_value prg = args[prg_pos];
2437 lbm_value app_cont;
2438 lbm_value app_cont_prg;
2439 lbm_value new_prg;
2440 lbm_value prg_copy;
2441
2442 int len = -1;
2443 WITH_GC(prg_copy, lbm_list_copy(&len, prg))(prg_copy) = (lbm_list_copy(&len, prg)); if (lbm_is_symbol_merror
((prg_copy))) { gc(); (prg_copy) = (lbm_list_copy(&len, prg
)); if (lbm_is_symbol_merror((prg_copy))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2444 lbm_stack_drop(&ctx->K, nargs+1);
2445
2446 if (ctx->K.sp > nargs+2) { // if there is a continuation
2447 app_cont = cons_with_gc(ENC_SYM_APP_CONT(((0x111) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2448 app_cont_prg = cons_with_gc(app_cont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2449 new_prg = lbm_list_append(app_cont_prg, ctx->program);
2450 new_prg = lbm_list_append(prg_copy, new_prg);
2451 } else {
2452 new_prg = lbm_list_append(prg_copy, ctx->program);
2453 }
2454 if (!lbm_is_list(new_prg)) {
2455 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2456 }
2457 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);
2458 ctx->program = get_cdr(new_prg);
2459 ctx->curr_exp = get_car(new_prg);
2460 } else {
2461 lbm_set_error_reason((char*)lbm_error_str_num_args);
2462 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2463 }
2464}
2465
2466static void apply_send(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2467 if (nargs == 2) {
2468 if (lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2469 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2470 lbm_value msg = args[1];
2471 lbm_value status = lbm_find_receiver_and_send(cid, msg);
2472 /* return the status */
2473 lbm_stack_drop(&ctx->K, nargs+1);
2474 ctx->r = status;
2475 ctx->app_cont = true1;
2476 } else {
2477 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2478 }
2479 } else {
2480 lbm_set_error_reason((char*)lbm_error_str_num_args);
2481 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2482 }
2483}
2484
2485static void apply_ok(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2486 lbm_value ok_val = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2487 if (nargs >= 1) {
2488 ok_val = args[0];
2489 }
2490 ctx->r = ok_val;
2491 ok_ctx();
2492}
2493
2494static void apply_error(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2495 (void) ctx;
2496 lbm_value err_val = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
2497 if (nargs >= 1) {
2498 err_val = args[0];
2499 }
2500 error_at_ctx(err_val, ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
2501}
2502
2503// (map f arg-list)
2504static void apply_map(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2505 if (nargs == 2 && lbm_is_cons(args[1])) {
2506 lbm_value *sptr = get_stack_ptr(ctx, 3);
2507
2508 lbm_value f = args[0];
2509 lbm_value h = get_car(args[1]);
2510 lbm_value t = get_cdr(args[1]);
2511
2512 lbm_value appli_1;
2513 lbm_value appli;
2514 WITH_GC(appli_1, lbm_heap_allocate_list(2))(appli_1) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli_1))) { gc(); (appli_1) = (lbm_heap_allocate_list(2));
if (lbm_is_symbol_merror((appli_1))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2515 WITH_GC_RMBR_1(appli, lbm_heap_allocate_list(2), appli_1)(appli) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli))) { lbm_gc_mark_phase(appli_1); gc(); (appli) = (lbm_heap_allocate_list
(2)); if (lbm_is_symbol_merror((appli))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2516
2517 lbm_value appli_0 = get_cdr(appli_1);
2518
2519 lbm_set_car_and_cdr(appli_0, h, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2520 lbm_set_car(appli_1, ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u));
2521
2522 lbm_set_car_and_cdr(get_cdr(appli), appli_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2523 lbm_set_car(appli, f);
2524
2525 lbm_value elt = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), appli);
2526 sptr[0] = t; // reuse stack space
2527 sptr[1] = ctx->curr_env;
2528 sptr[2] = elt;
2529 lbm_value *rptr = stack_reserve(ctx,4);
2530 rptr[0] = elt;
2531 rptr[1] = appli;
2532 rptr[2] = appli_0;
2533 rptr[3] = MAP(((26) << 2) | 0xF8000001u);
2534 ctx->curr_exp = appli;
2535 } else if (nargs == 2 && lbm_is_symbol_nil(args[1])) {
2536 lbm_stack_drop(&ctx->K, 3);
2537 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2538 ctx->app_cont = true1;
2539 return;
2540 } else {
2541 lbm_set_error_reason((char*)lbm_error_str_num_args);
2542 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_MAP(((0x3000D) << 4) | 0x00000000u));
2543 }
2544}
2545
2546static void apply_reverse(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2547 if (nargs == 1 && lbm_is_list(args[0])) {
2548 lbm_value curr = args[0];
2549
2550 lbm_value new_list = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2551 while (lbm_is_cons(curr)) {
2552 lbm_value tmp = cons_with_gc(get_car(curr), new_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2553 new_list = tmp;
2554 curr = get_cdr(curr);
2555 }
2556 lbm_stack_drop(&ctx->K, 2);
2557 ctx->r = new_list;
2558 ctx->app_cont = true1;
2559 } else {
2560 lbm_set_error_reason("Reverse requires a list argument");
2561 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_REVERSE(((0x3000E) << 4) | 0x00000000u));
2562 }
2563}
2564
2565static void apply_flatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2566 if (nargs == 1) {
2567
2568 lbm_value v = flatten_value(args[0]);
2569 if ( v == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)) {
2570 gc();
2571 v = flatten_value(args[0]);
2572 }
2573
2574 if (lbm_is_symbol(v)) {
2575 error_at_ctx(v, ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2576 } else {
2577 lbm_stack_drop(&ctx->K, 2);
2578 ctx->r = v;
2579 ctx->app_cont = true1;
2580 }
2581 return;
2582 }
2583 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2584}
2585
2586static void apply_unflatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2587 if(nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2588 lbm_array_header_t *array;
2589 array = (lbm_array_header_t *)get_car(args[0]);
2590
2591 lbm_flat_value_t fv;
2592 fv.buf = (uint8_t*)array->data;
2593 fv.buf_size = array->size;
2594 fv.buf_pos = 0;
2595
2596 lbm_value res;
2597
2598 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2599 if (lbm_unflatten_value(&fv, &res)) {
2600 ctx->r = res;
2601 }
2602 lbm_stack_drop(&ctx->K, 2);
2603 ctx->app_cont = true1;
2604 return;
2605 }
2606 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_UNFLATTEN(((0x30010) << 4) | 0x00000000u));
2607}
2608
2609static void apply_kill(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2610 if (nargs == 2 && lbm_is_number(args[0])) {
2611 lbm_cid cid = lbm_dec_as_i32(args[0]);
2612
2613 if (ctx->id == cid) {
2614 ctx->r = args[1];
2615 finish_ctx();
2616 return;
2617 }
2618 mutex_lock(&qmutex);
2619 eval_context_t *found = NULL((void*)0);
2620 found = lookup_ctx_nm(&blocked, cid);
2621 if (found)
2622 drop_ctx_nm(&blocked, found);
2623 else
2624 found = lookup_ctx_nm(&queue, cid);
2625 if (found)
2626 drop_ctx_nm(&queue, found);
2627
2628 if (found) {
2629 found->K.data[found->K.sp - 1] = KILL(((40) << 2) | 0xF8000001u);
2630 found->r = args[1];
2631 found->app_cont = true1;
2632 enqueue_ctx_nm(&queue,found);
2633 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2634 } else {
2635 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2636 }
2637 lbm_stack_drop(&ctx->K, 3);
2638 ctx->app_cont = true1;
2639 mutex_unlock(&qmutex);
2640 return;
2641 }
2642 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_KILL(((0x30011) << 4) | 0x00000000u));
2643}
2644
2645// (merge comparator list1 list2)
2646static void apply_merge(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2647 if (nargs == 3 && lbm_is_list(args[1]) && lbm_is_list(args[2])) {
2648
2649 if (!lbm_is_closure(args[0])) {
2650 lbm_value closure;
2651 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2652 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2653 lbm_value cl1 = lbm_cdr(closure);
2654 lbm_value par;
2655 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2656 lbm_set_car(cl1, par);
2657 lbm_value cl2 = lbm_cdr(cl1);
2658 lbm_value body;
2659 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2660 lbm_set_car(cl2, body);
2661 lbm_value cl3 = lbm_cdr(cl2);
2662 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2663
2664 // Replace operator on stack with closure and rest of the code is
2665 // compatible.
2666 args[0] = closure;
2667 }
2668
2669 // Copy input lists for functional behaviour at top-level
2670 // merge itself is in-place in the copied lists.
2671 lbm_value a;
2672 lbm_value b;
2673 int len_a = -1;
2674 int len_b = -1;
2675 WITH_GC(a, lbm_list_copy(&len_a, args[1]))(a) = (lbm_list_copy(&len_a, args[1])); if (lbm_is_symbol_merror
((a))) { gc(); (a) = (lbm_list_copy(&len_a, args[1])); if
(lbm_is_symbol_merror((a))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } };
2676 WITH_GC_RMBR_1(b, lbm_list_copy(&len_b, args[2]), a)(b) = (lbm_list_copy(&len_b, args[2])); if (lbm_is_symbol_merror
((b))) { lbm_gc_mark_phase(a); gc(); (b) = (lbm_list_copy(&
len_b, args[2])); if (lbm_is_symbol_merror((b))) { error_ctx(
(((0x23) << 4) | 0x00000000u)); } };
2677
2678 if (len_a == 0) {
2679 ctx->r = b;
2680 lbm_stack_drop(&ctx->K, 4);
2681 ctx->app_cont = true1;
2682 return;
2683 }
2684 if (len_b == 0) {
2685 ctx->r = a;
2686 lbm_stack_drop(&ctx->K, 4);
2687 ctx->app_cont = true1;
2688 return;
2689 }
2690
2691 args[1] = a; // keep safe by replacing the original on stack.
2692 args[2] = b;
2693
2694 lbm_value a_1 = a;
2695 lbm_value a_rest = lbm_cdr(a);
2696 lbm_value b_1 = b;
2697 lbm_value b_rest = lbm_cdr(b);
2698
2699 lbm_value cl[3]; // Comparator closure
2700 extract_n(lbm_cdr(args[0]), cl, 3);
2701 lbm_value cmp_env = cl[CLO_ENV2];
2702 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2703 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2704 lbm_uint len = lbm_list_length(cl[CLO_PARAMS0]);
2705 if (len == 2) {
2706 par1 = get_car(cl[CLO_PARAMS0]);
2707 par2 = get_cadr(cl[CLO_PARAMS0]);
2708 lbm_value new_env0;
2709 lbm_value new_env;
2710 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a_1)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a_1))); if (
lbm_is_symbol_merror((new_env0))) { gc(); (new_env0) = (lbm_env_set
(cmp_env, par1, lbm_car(a_1))); if (lbm_is_symbol_merror((new_env0
))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2711 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b_1)),new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1))); if (
lbm_is_symbol_merror((new_env))) { lbm_gc_mark_phase(new_env0
); gc(); (new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1
))); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2712 cmp_env = new_env;
2713 } else {
2714 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2715 }
2716 lbm_set_cdr(a_1, b_1);
2717 lbm_set_cdr(b_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2718 lbm_value cmp = cl[CLO_BODY1];
2719
2720 lbm_stack_drop(&ctx->K, 4); // TODO: Optimize drop 4 alloc 10 into alloc 6
2721 lbm_uint *sptr = stack_reserve(ctx, 10);
2722 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged list
2723 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged list
2724 sptr[2] = a_1;
2725 sptr[3] = a_rest;
2726 sptr[4] = b_rest;
2727 sptr[5] = cmp;
2728 sptr[6] = cmp_env;
2729 sptr[7] = par1;
2730 sptr[8] = par2;
2731 sptr[9] = MERGE_REST(((43) << 2) | 0xF8000001u);
2732 ctx->curr_exp = cl[CLO_BODY1];
2733 ctx->curr_env = cmp_env;
2734 return;
2735 }
2736 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MERGE(((0x30013) << 4) | 0x00000000u));
2737}
2738
2739// (sort comparator list)
2740static void apply_sort(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2741 if (nargs == 2 && lbm_is_list(args[1])) {
2742
2743 if (!lbm_is_closure(args[0])) {
2744 lbm_value closure;
2745 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2746 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2747 lbm_value cl1 = lbm_cdr(closure);
2748 lbm_value par;
2749 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2750 lbm_set_car(cl1, par);
2751 lbm_value cl2 = lbm_cdr(cl1);
2752 lbm_value body;
2753 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2754 lbm_set_car(cl2, body);
2755 lbm_value cl3 = lbm_cdr(cl2);
2756 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2757
2758 // Replace operator on stack with closure and rest of the code is
2759 // compatible.
2760 args[0] = closure;
2761 }
2762
2763 int len = -1;
2764 lbm_value list_copy;
2765 WITH_GC(list_copy, lbm_list_copy(&len, args[1]))(list_copy) = (lbm_list_copy(&len, args[1])); if (lbm_is_symbol_merror
((list_copy))) { gc(); (list_copy) = (lbm_list_copy(&len,
args[1])); if (lbm_is_symbol_merror((list_copy))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2766 if (len <= 1) {
2767 lbm_stack_drop(&ctx->K, 3);
2768 ctx->r = list_copy;
2769 ctx->app_cont = true1;
2770 return;
2771 }
2772
2773 args[1] = list_copy; // Keep safe, original replaced on stack.
2774
2775 // Take the headmost 2, 1-element sublists.
2776 lbm_value a = list_copy;
2777 lbm_value b = lbm_cdr(a);
2778 lbm_value rest = lbm_cdr(b);
2779 // Do not terminate b. keep rest of list safe from GC in the following
2780 // closure extraction.
2781 //lbm_set_cdr(a, b); // This is void
2782
2783 lbm_value cl[3]; // Comparator closure
2784 extract_n(lbm_cdr(args[0]), cl, 3);
2785 lbm_value cmp_env = cl[CLO_ENV2];
2786 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2787 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2788 lbm_uint cl_len = lbm_list_length(cl[CLO_PARAMS0]);
2789 if (cl_len == 2) {
2790 par1 = get_car(cl[CLO_PARAMS0]);
2791 par2 = get_cadr(cl[CLO_PARAMS0]);
2792 lbm_value new_env0;
2793 lbm_value new_env;
2794 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a))); if (lbm_is_symbol_merror
((new_env0))) { gc(); (new_env0) = (lbm_env_set(cmp_env, par1
, lbm_car(a))); if (lbm_is_symbol_merror((new_env0))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2795 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b)), new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { lbm_gc_mark_phase(new_env0); gc(); (new_env) =
(lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { error_ctx((((0x23) << 4) | 0x00000000u))
; } };
2796 cmp_env = new_env;
2797 } else {
2798 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2799 }
2800 lbm_value cmp = cl[CLO_BODY1];
2801
2802 // Terminate the comparator argument list.
2803 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2804
2805 lbm_stack_drop(&ctx->K, 3); //TODO: optimize drop 3, alloc 20 into alloc 17
2806 lbm_uint *sptr = stack_reserve(ctx, 20);
2807 sptr[0] = cmp;
2808 sptr[1] = cmp_env;
2809 sptr[2] = par1;
2810 sptr[3] = par2;
2811 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged accumulation of sublists
2812 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged accumulation of sublists
2813 sptr[6] = rest;
2814 sptr[7] = lbm_enc_i(1);
2815 sptr[8] = lbm_enc_i(len); //TODO: 28 bit i vs 32 bit i
2816 sptr[9] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
2817 sptr[10] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged sublist
2818 sptr[11] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged sublist
2819 sptr[12] = a;
2820 sptr[13] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no a_rest, 1 element lists in layer 1.
2821 sptr[14] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no b_rest, 1 element lists in layer 1.
2822 sptr[15] = cmp;
2823 sptr[16] = cmp_env;
2824 sptr[17] = par1;
2825 sptr[18] = par2;
2826 sptr[19] = MERGE_REST(((43) << 2) | 0xF8000001u);
2827 ctx->curr_exp = cmp;
2828 ctx->curr_env = cmp_env;
2829 return;
2830 }
2831 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
2832}
2833
2834static void apply_rest_args(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2835 lbm_value res;
2836 if (lbm_env_lookup_b(&res, ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ctx->curr_env)) {
2837 if (nargs == 1 && lbm_is_number(args[0])) {
2838 int32_t ix = lbm_dec_as_i32(args[0]);
2839 res = lbm_index_list(res, ix);
2840 }
2841 ctx->r = res;
2842 } else {
2843 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2844 }
2845 lbm_stack_drop(&ctx->K, nargs+1);
2846 ctx->app_cont = true1;
2847}
2848
2849/* (rotate list-expr dist/dir-expr) */
2850static void apply_rotate(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2851 if (nargs == 2 && lbm_is_list(args[0]) && lbm_is_number(args[1])) {
2852 int len = -1;
2853 lbm_value ls = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2854 WITH_GC(ls, lbm_list_copy(&len, args[0]))(ls) = (lbm_list_copy(&len, args[0])); if (lbm_is_symbol_merror
((ls))) { gc(); (ls) = (lbm_list_copy(&len, args[0])); if
(lbm_is_symbol_merror((ls))) { error_ctx((((0x23) << 4
) | 0x00000000u)); } };
2855 int dist = lbm_dec_as_i32(args[1]);
2856 if (len > 0 && dist != 0) {
2857 int d = dist;
2858 if (dist > 0) {
2859 ls = lbm_list_destructive_reverse(ls);
2860 } else {
2861 d = -dist;
2862 }
2863
2864 lbm_value start = ls;
2865 lbm_value end = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2866 lbm_value curr = start;
2867 while (lbm_is_cons(curr)) {
2868 end = curr;
2869 curr = get_cdr(curr);
2870 }
2871
2872 for (int i = 0; i < d; i ++) {
2873 lbm_value a = start;
2874 start = lbm_cdr(start);
2875 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2876 lbm_set_cdr(end, a);
2877 end = a;
2878 }
2879 ls = start;
2880 if (dist > 0) {
2881 ls = lbm_list_destructive_reverse(ls);
2882 }
2883 }
2884 lbm_stack_drop(&ctx->K, nargs+1);
2885 ctx->app_cont = true1;
2886 ctx->r = ls;
2887 return;
2888 }
2889 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2890}
2891
2892/***************************************************/
2893/* Application lookup table */
2894
2895typedef void (*apply_fun)(lbm_value *, lbm_uint, eval_context_t *);
2896static const apply_fun fun_table[] =
2897 {
2898 apply_setvar,
2899 apply_read,
2900 apply_read_program,
2901 apply_read_eval_program,
2902 apply_spawn,
2903 apply_spawn_trap,
2904 apply_yield,
2905 apply_wait,
2906 apply_eval,
2907 apply_eval_program,
2908 apply_send,
2909 apply_ok,
2910 apply_error,
2911 apply_map,
2912 apply_reverse,
2913 apply_flatten,
2914 apply_unflatten,
2915 apply_kill,
2916 apply_sleep,
2917 apply_merge,
2918 apply_sort,
2919 apply_rest_args,
2920 apply_rotate,
2921 };
2922
2923/***************************************************/
2924/* Application of function that takes arguments */
2925/* passed over the stack. */
2926
2927static void application(eval_context_t *ctx, lbm_value *fun_args, lbm_uint arg_count) {
2928 /* If arriving here, we know that the fun is a symbol.
2929 * and can be a built in operation or an extension.
2930 */
2931 lbm_value fun = fun_args[0];
2932
2933 lbm_uint fun_val = lbm_dec_sym(fun);
2934 lbm_uint fun_kind = SYMBOL_KIND(fun_val)((fun_val) >> 16);
2935
2936 switch (fun_kind) {
2937 case SYMBOL_KIND_EXTENSION1: {
2938 extension_fptr f = extension_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)].fptr;
2939
2940 lbm_value ext_res;
2941 WITH_GC(ext_res, f(&fun_args[1], arg_count))(ext_res) = (f(&fun_args[1], arg_count)); if (lbm_is_symbol_merror
((ext_res))) { gc(); (ext_res) = (f(&fun_args[1], arg_count
)); if (lbm_is_symbol_merror((ext_res))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2942 if (lbm_is_error(ext_res)) { //Error other than merror
2943 error_at_ctx(ext_res, fun);
2944 }
2945 lbm_stack_drop(&ctx->K, arg_count + 1);
2946
2947 ctx->app_cont = true1;
2948 ctx->r = ext_res;
2949
2950 if (blocking_extension) {
2951 blocking_extension = false0;
2952 if (blocking_extension_timeout) {
2953 blocking_extension_timeout = false0;
2954 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, blocking_extension_timeout_us,true1);
2955 } else {
2956 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,true1);
2957 }
2958 mutex_unlock(&blocking_extension_mutex);
2959 }
2960 } break;
2961 case SYMBOL_KIND_FUNDAMENTAL2:
2962 call_fundamental(SYMBOL_IX(fun_val)((fun_val) & 0xFFFF), &fun_args[1], arg_count, ctx);
2963 break;
2964 case SYMBOL_KIND_APPFUN3:
2965 fun_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)](&fun_args[1], arg_count, ctx);
2966 break;
2967 default:
2968 // Symbols that are "special" but not in the way caught above
2969 // ends up here.
2970 lbm_set_error_reason("Symbol does not represent a function");
2971 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),fun_args[0]);
2972 break;
2973 }
2974}
2975
2976static void cont_closure_application_args(eval_context_t *ctx) {
2977 lbm_uint* sptr = get_stack_ptr(ctx, 5);
2978
2979 lbm_value arg_env = (lbm_value)sptr[0];
2980 lbm_value exp = (lbm_value)sptr[1];
2981 lbm_value clo_env = (lbm_value)sptr[2];
2982 lbm_value params = (lbm_value)sptr[3];
2983 lbm_value args = (lbm_value)sptr[4];
2984
2985 lbm_value car_params, cdr_params;
2986 get_car_and_cdr(params, &car_params, &cdr_params);
2987
2988 bool_Bool a_nil = lbm_is_symbol_nil(args);
2989 bool_Bool p_nil = lbm_is_symbol_nil(cdr_params);
2990
2991 lbm_value binder = allocate_binding(car_params, ctx->r, clo_env);
2992
2993 if (!a_nil && !p_nil) {
2994 lbm_value car_args, cdr_args;
2995 get_car_and_cdr(args, &car_args, &cdr_args);
2996 sptr[2] = binder;
2997 sptr[3] = cdr_params;
2998 sptr[4] = cdr_args;
2999 stack_reserve(ctx,1)[0] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
3000 ctx->curr_exp = car_args;
3001 ctx->curr_env = arg_env;
3002 } else if (a_nil && p_nil) {
3003 // Arguments and parameters match up in number
3004 lbm_stack_drop(&ctx->K, 5);
3005 ctx->curr_env = binder;
3006 ctx->curr_exp = exp;
3007 } else if (p_nil) {
3008 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), binder);
3009 sptr[2] = rest_binder;
3010 sptr[3] = get_cdr(args);
3011 sptr[4] = get_car(rest_binder); // last element of rest_args so far
3012 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3013 ctx->curr_exp = get_car(args);
3014 ctx->curr_env = arg_env;
3015 } else {
3016 lbm_set_error_reason((char*)lbm_error_str_num_args);
3017 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
3018 }
3019}
3020
3021
3022static void cont_closure_args_rest(eval_context_t *ctx) {
3023 lbm_uint* sptr = get_stack_ptr(ctx, 5);
3024 lbm_value arg_env = (lbm_value)sptr[0];
3025 lbm_value exp = (lbm_value)sptr[1];
3026 lbm_value clo_env = (lbm_value)sptr[2];
3027 lbm_value args = (lbm_value)sptr[3];
3028 lbm_value last = (lbm_value)sptr[4];
3029 lbm_cons_t* heap = lbm_heap_state.heap;
3030
3031 lbm_value binding = lbm_heap_state.freelist;
3032 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3033 gc();
3034 binding = lbm_heap_state.freelist;
3035 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3036 }
3037 lbm_uint binding_ix = lbm_dec_ptr(binding);
3038 lbm_heap_state.freelist = heap[binding_ix].cdr;
3039 lbm_heap_state.num_alloc += 1;
3040 heap[binding_ix].car = ctx->r;
3041 heap[binding_ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3042
3043
3044 lbm_set_cdr(last, binding);
3045 sptr[4] = binding;
3046
3047 if (args == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3048 lbm_stack_drop(&ctx->K, 5);
3049 ctx->curr_env = clo_env;
3050 ctx->curr_exp = exp;
3051 } else {
3052 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3053 sptr[3] = get_cdr(args);
3054 ctx->curr_exp = get_car(args);
3055 ctx->curr_env = arg_env;
3056 }
3057}
3058
3059static void cont_application_args(eval_context_t *ctx) {
3060 lbm_uint *sptr = get_stack_ptr(ctx, 3);
3061
3062 lbm_value env = sptr[0];
3063 lbm_value rest = sptr[1];
3064 lbm_value count = sptr[2];
3065
3066 ctx->curr_env = env;
3067 sptr[0] = ctx->r; // Function 1st then Arguments
3068 if (lbm_is_cons(rest)) {
3069 lbm_cons_t *cell = lbm_ref_cell(rest);
3070 sptr[1] = env;
3071 sptr[2] = cell->cdr;
3072 lbm_value *rptr = stack_reserve(ctx,2);
3073 rptr[0] = count + (1 << LBM_VAL_SHIFT4);
3074 rptr[1] = APPLICATION_ARGS(((5) << 2) | 0xF8000001u);
3075 ctx->curr_exp = cell->car;
3076 } else {
3077 // No more arguments
3078 lbm_stack_drop(&ctx->K, 2);
3079 lbm_uint nargs = lbm_dec_u(count);
3080 lbm_value *args = get_stack_ptr(ctx, (uint32_t)(nargs + 1));
3081 application(ctx,args, nargs);
3082 }
3083}
3084
3085static void cont_and(eval_context_t *ctx) {
3086 lbm_value env;
3087 lbm_value rest;
3088 lbm_value arg = ctx->r;
3089 lbm_pop_2(&ctx->K, &rest, &env);
3090 if (lbm_is_symbol_nil(arg)) {
3091 ctx->app_cont = true1;
3092 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3093 } else if (lbm_is_symbol_nil(rest)) {
3094 ctx->app_cont = true1;
3095 } else {
3096 lbm_value *sptr = stack_reserve(ctx, 3);
3097 sptr[0] = env;
3098 sptr[1] = get_cdr(rest);
3099 sptr[2] = AND(((6) << 2) | 0xF8000001u);
3100 ctx->curr_env = env;
3101 ctx->curr_exp = get_car(rest);
3102 }
3103}
3104
3105static void cont_or(eval_context_t *ctx) {
3106 lbm_value env;
3107 lbm_value rest;
3108 lbm_value arg = ctx->r;
3109 lbm_pop_2(&ctx->K, &rest, &env);
3110 if (!lbm_is_symbol_nil(arg)) {
3111 ctx->app_cont = true1;
3112 } else if (lbm_is_symbol_nil(rest)) {
3113 ctx->app_cont = true1;
3114 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3115 } else {
3116 lbm_value *sptr = stack_reserve(ctx, 3);
3117 sptr[0] = env;
3118 sptr[1] = get_cdr(rest);
3119 sptr[2] = OR(((7) << 2) | 0xF8000001u);
3120 ctx->curr_exp = get_car(rest);
3121 ctx->curr_env = env;
3122 }
3123}
3124
3125static int fill_binding_location(lbm_value key, lbm_value value, lbm_value env) {
3126 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) {
3127 if (key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return FB_OK0;
3128 lbm_env_modify_binding(env,key,value);
3129 return FB_OK0;
3130 } else if (lbm_is_cons(key) &&
3131 lbm_is_cons(value)) {
3132 int r = fill_binding_location(get_car(key), get_car(value), env);
3133 if (r == FB_OK0) {
3134 r = fill_binding_location(get_cdr(key), get_cdr(value), env);
3135 }
3136 return r;
3137 }
3138 return FB_TYPE_ERROR-1;
3139}
3140
3141static void cont_bind_to_key_rest(eval_context_t *ctx) {
3142
3143 lbm_value *sptr = get_stack_ptr(ctx, 4);
3144
3145 lbm_value rest = sptr[1];
3146 lbm_value env = sptr[2];
3147 lbm_value key = sptr[3];
3148
3149 if (fill_binding_location(key, ctx->r, env) < 0) {
3150 lbm_set_error_reason("Incorrect type of name/key in let-binding");
3151 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
3152 }
3153
3154 if (lbm_is_cons(rest)) {
3155 lbm_value car_rest = get_car(rest);
3156 lbm_value key_val[2];
3157 extract_n(car_rest, key_val, 2);
3158
3159 sptr[1] = get_cdr(rest);
3160 sptr[3] = key_val[0];
3161 stack_reserve(ctx,1)[0] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
3162 ctx->curr_exp = key_val[1];
3163 ctx->curr_env = env;
3164 } else {
3165 // Otherwise evaluate the expression in the populated env
3166 ctx->curr_exp = sptr[0];
3167 ctx->curr_env = env;
3168 lbm_stack_drop(&ctx->K, 4);
3169 }
3170}
3171
3172static void cont_if(eval_context_t *ctx) {
3173
3174 lbm_value arg = ctx->r;
3175
3176 lbm_value *sptr = pop_stack_ptr(ctx, 2);
3177
3178 ctx->curr_env = sptr[1];
3179 if (lbm_is_symbol_nil(arg)) {
3180 ctx->curr_exp = get_cadr(sptr[0]); // else branch
3181 } else {
3182 ctx->curr_exp = get_car(sptr[0]); // then branch
3183 }
3184}
3185
3186static void cont_match(eval_context_t *ctx) {
3187 lbm_value e = ctx->r;
3188 bool_Bool do_gc = false0;
3189
3190 lbm_uint *sptr = get_stack_ptr(ctx, 2);
3191 lbm_value patterns = (lbm_value)sptr[0];
3192 lbm_value orig_env = (lbm_value)sptr[1]; // restore enclosing environment.
3193 lbm_value new_env = orig_env;
3194
3195 if (lbm_is_symbol_nil(patterns)) {
3196 // no more patterns
3197 lbm_stack_drop(&ctx->K, 2);
3198 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
3199 ctx->app_cont = true1;
3200 } else if (lbm_is_cons(patterns)) {
3201 lbm_value match_case = get_car(patterns);
3202 lbm_value pattern = get_car(match_case);
3203 lbm_value n1 = get_cadr(match_case);
3204 lbm_value n2 = get_cadr(get_cdr(match_case));
3205 lbm_value body;
3206 bool_Bool check_guard = false0;
3207 if (lbm_is_symbol_nil(n2)) { // TODO: Not a very robust check.
3208 body = n1;
3209 } else {
3210 body = n2;
3211 check_guard = true1;
3212 }
3213
3214 bool_Bool is_match = match(pattern, e, &new_env, &do_gc);
3215 if (do_gc) {
3216 gc();
3217 do_gc = false0;
3218 new_env = orig_env;
3219 is_match = match(pattern, e, &new_env, &do_gc);
3220 if (do_gc) {
3221 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3222 }
3223 }
3224 if (is_match) {
3225 if (check_guard) {
3226 lbm_value *rptr = stack_reserve(ctx,5);
3227 sptr[0] = get_cdr(patterns);
3228 sptr[1] = ctx->curr_env;
3229 rptr[0] = MATCH(((9) << 2) | 0xF8000001u);
3230 rptr[1] = new_env;
3231 rptr[2] = body;
3232 rptr[3] = e;
3233 rptr[4] = MATCH_GUARD(((27) << 2) | 0xF8000001u);
3234 ctx->curr_env = new_env;
3235 ctx->curr_exp = n1; // The guard
3236 } else {
3237 lbm_stack_drop(&ctx->K, 2);
3238 ctx->curr_env = new_env;
3239 ctx->curr_exp = body;
3240 }
3241 } else {
3242 // set up for checking of next pattern
3243 sptr[0] = get_cdr(patterns);
3244 sptr[1] = orig_env;
3245 stack_reserve(ctx,1)[0] = MATCH(((9) << 2) | 0xF8000001u);
3246 // leave r unaltered
3247 ctx->app_cont = true1;
3248 }
3249 } else {
3250 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MATCH(((0x108) << 4) | 0x00000000u));
3251 }
3252}
3253
3254static void cont_exit_atomic(eval_context_t *ctx) {
3255 is_atomic --;
3256 ctx->app_cont = true1;
3257}
3258
3259static void cont_map(eval_context_t *ctx) {
3260 lbm_value *sptr = get_stack_ptr(ctx, 6);
3261
3262 lbm_value ls = sptr[0];
3263 lbm_value env = sptr[1];
3264 lbm_value t = sptr[3];
3265 lbm_set_car(t, ctx->r); // update car field tailmost position.
3266 if (lbm_is_cons(ls)) {
3267 lbm_value next, rest;
3268 get_car_and_cdr(ls, &next, &rest);
3269 sptr[0] = rest;
3270 stack_reserve(ctx,1)[0] = MAP(((26) << 2) | 0xF8000001u);
3271 lbm_set_car(sptr[5], next); // new arguments
3272
3273 lbm_value elt = cons_with_gc(ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3274 lbm_set_cdr(t, elt);
3275 sptr[3] = elt; // (r1 ... rN . (nil . nil))
3276 ctx->curr_exp = sptr[4];
3277 ctx->curr_env = env;
3278 } else {
3279 ctx->r = sptr[2]; //head of result list
3280 ctx->curr_env = env;
3281 lbm_stack_drop(&ctx->K, 6);
3282 ctx->app_cont = true1;
3283 }
3284}
3285
3286static void cont_match_guard(eval_context_t *ctx) {
3287 if (lbm_is_symbol_nil(ctx->r)) {
3288 lbm_value e;
3289 lbm_pop(&ctx->K, &e);
3290 lbm_stack_drop(&ctx->K, 2);
3291 ctx->r = e;
3292 ctx->app_cont = true1;
3293 } else {
3294 lbm_value body;
3295 lbm_value env;
3296 lbm_stack_drop(&ctx->K, 1);
3297 lbm_pop_2(&ctx->K, &body, &env);
3298 lbm_stack_drop(&ctx->K, 3);
3299 ctx->curr_env = env;
3300 ctx->curr_exp = body;
3301 }
3302}
3303
3304static void cont_terminate(eval_context_t *ctx) {
3305 error_ctx(ctx->r);
3306}
3307
3308static void cont_loop(eval_context_t *ctx) {
3309 lbm_value *sptr = get_stack_ptr(ctx, 2);
3310 stack_reserve(ctx,1)[0] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
3311 ctx->curr_exp = sptr[1];
3312}
3313
3314static void cont_loop_condition(eval_context_t *ctx) {
3315 if (lbm_is_symbol_nil(ctx->r)) {
3316 lbm_stack_drop(&ctx->K, 2);
3317 ctx->app_cont = true1; // A loop returns nil? Makes sense to me... but in general?
3318 return;
3319 }
3320 lbm_value *sptr = get_stack_ptr(ctx, 2);
3321 stack_reserve(ctx,1)[0] = LOOP(((41) << 2) | 0xF8000001u);
3322 ctx->curr_exp = sptr[0];
3323}
3324
3325static void cont_merge_rest(eval_context_t *ctx) {
3326 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3327
3328 // If comparator returns true (result is in ctx->r):
3329 // "a" should be moved to the last element position in merged list.
3330 // A new element from "a_rest" should be moved into comparator argument 1 pos.
3331 // else
3332 // "b" should be moved to last element position in merged list.
3333 // A new element from "b_rest" should be moved into comparator argument 2 pos.
3334 //
3335 // If a_rest or b_rest is NIL:
3336 // we are done, the remaining elements of
3337 // non_nil list should be appended to merged list.
3338 // else
3339 // Set up for a new comparator evaluation and recurse.
3340 lbm_value a = sptr[2];
3341 lbm_value b = lbm_cdr(a);
3342 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate 1 element list
3343
3344 if (ctx->r == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) { // Comparison false
3345
3346 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3347 sptr[0] = b;
3348 sptr[1] = b;
3349 } else {
3350 lbm_set_cdr(sptr[1], b);
3351 sptr[1] = b;
3352 }
3353 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3354 lbm_set_cdr(a, sptr[3]);
3355 lbm_set_cdr(sptr[1], a);
3356 ctx->r = sptr[0];
3357 lbm_stack_drop(&ctx->K, 9);
3358 ctx->app_cont = true1;
3359 return;
3360 } else {
3361 b = sptr[4];
3362 sptr[4] = lbm_cdr(sptr[4]);
3363 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3364 }
3365 } else {
3366 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3367 sptr[0] = a;
3368 sptr[1] = a;
3369 } else {
3370 lbm_set_cdr(sptr[1], a);
3371 sptr[1] = a;
3372 }
3373
3374 if (sptr[3] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3375 lbm_set_cdr(b, sptr[4]);
3376 lbm_set_cdr(sptr[1], b);
3377 ctx->r = sptr[0];
3378 lbm_stack_drop(&ctx->K, 9);
3379 ctx->app_cont = true1;
3380 return;
3381 } else {
3382 a = sptr[3];
3383 sptr[3] = lbm_cdr(sptr[3]);
3384 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3385 }
3386 }
3387 lbm_set_cdr(a, b);
3388 sptr[2] = a;
3389
3390 lbm_value par1 = sptr[7];
3391 lbm_value par2 = sptr[8];
3392 lbm_value cmp_body = sptr[5];
3393 lbm_value cmp_env = sptr[6];
3394 // Environment should be preallocated already at this point
3395 // and the operations below should never need GC.
3396 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3397 lbm_value new_env = lbm_env_set(new_env0, par2, lbm_car(b));
3398 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3399 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3400 }
3401 cmp_env = new_env;
3402
3403 stack_reserve(ctx,1)[0] = MERGE_REST(((43) << 2) | 0xF8000001u);
3404 ctx->curr_exp = cmp_body;
3405 ctx->curr_env = cmp_env;
3406}
3407
3408// merge_layer stack contents
3409// s[sp-9] = cmp
3410// s[sp-8] = cmp_env
3411// s[sp-7] = par1
3412// s[sp-6] = par2
3413// s[sp-5] = acc - first cell
3414// s[sp-4] = acc - last cell
3415// s[sp-3] = rest;
3416// s[sp-2] = layer
3417// s[sp-1] = length or original list
3418//
3419// ctx->r merged sublist
3420static void cont_merge_layer(eval_context_t *ctx) {
3421 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3422 lbm_int layer = lbm_dec_i(sptr[7]);
3423 lbm_int len = lbm_dec_i(sptr[8]);
3424
3425 lbm_value r_curr = ctx->r;
3426 while (lbm_is_cons(r_curr)) {
3427 lbm_value next = lbm_cdr(r_curr);
3428 if (next == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3429 break;
3430 }
3431 r_curr = next;
3432 }
3433
3434 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3435 sptr[4] = ctx->r;
3436 sptr[5] = r_curr;
3437 } else {
3438 lbm_set_cdr(sptr[5], ctx->r); // accumulate merged sublists.
3439 sptr[5] = r_curr;
3440 }
3441
3442 lbm_value layer_rest = sptr[6];
3443 // switch layer or done ?
3444 if (layer_rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3445 if (layer * 2 >= len) {
3446 ctx->r = sptr[4];
3447 ctx->app_cont = true1;
3448 lbm_stack_drop(&ctx->K, 9);
3449 return;
3450 } else {
3451 // Setup for merges of the next layer
3452 layer = layer * 2;
3453 sptr[7] = lbm_enc_i(layer);
3454 layer_rest = sptr[4]; // continue on the accumulation of all sublists.
3455 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3456 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3457 }
3458 }
3459 // merge another sublist based on current layer.
3460 lbm_value a_list = layer_rest;
3461 // build sublist a
3462 lbm_value curr = layer_rest;
3463 for (int i = 0; i < layer-1; i ++) {
3464 if (lbm_is_cons(curr)) {
3465 curr = lbm_cdr(curr);
3466 } else {
3467 break;
3468 }
3469 }
3470 layer_rest = lbm_cdr(curr);
3471 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3472
3473 lbm_value b_list = layer_rest;
3474 // build sublist b
3475 curr = layer_rest;
3476 for (int i = 0; i < layer-1; i ++) {
3477 if (lbm_is_cons(curr)) {
3478 curr = lbm_cdr(curr);
3479 } else {
3480 break;
3481 }
3482 }
3483 layer_rest = lbm_cdr(curr);
3484 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3485
3486 sptr[6] = layer_rest;
3487
3488 if (b_list == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3489 stack_reserve(ctx,1)[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3490 ctx->r = a_list;
3491 ctx->app_cont = true1;
3492 return;
3493 }
3494 // Set up for a merge of sublists.
3495
3496 lbm_value a_rest = lbm_cdr(a_list);
3497 lbm_value b_rest = lbm_cdr(b_list);
3498 lbm_value a = a_list;
3499 lbm_value b = b_list;
3500 lbm_set_cdr(a, b);
3501 // Terminating the b list would be incorrect here
3502 // if there was any chance that the environment update below
3503 // performs GC.
3504 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3505
3506 lbm_value cmp_body = sptr[0];
3507 lbm_value cmp_env = sptr[1];
3508 lbm_value par1 = sptr[2];
3509 lbm_value par2 = sptr[3];
3510 // Environment should be preallocated already at this point
3511 // and the operations below should never need GC.
3512 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3513 lbm_value new_env = lbm_env_set(cmp_env, par2, lbm_car(b));
3514 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3515 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3516 }
3517 cmp_env = new_env;
3518
3519 lbm_uint *merge_cont = stack_reserve(ctx, 11);
3520 merge_cont[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3521 merge_cont[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3522 merge_cont[2] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3523 merge_cont[3] = a;
3524 merge_cont[4] = a_rest;
3525 merge_cont[5] = b_rest;
3526 merge_cont[6] = cmp_body;
3527 merge_cont[7] = cmp_env;
3528 merge_cont[8] = par1;
3529 merge_cont[9] = par2;
3530 merge_cont[10] = MERGE_REST(((43) << 2) | 0xF8000001u);
3531 ctx->curr_exp = cmp_body;
3532 ctx->curr_env = cmp_env;
3533 return;
3534}
3535
3536/****************************************************/
3537/* READER */
3538
3539static void read_finish(lbm_char_channel_t *str, eval_context_t *ctx) {
3540
3541 /* Tokenizer reached "end of file"
3542 The parser could be in a state where it needs
3543 more tokens to correctly finish an expression.
3544
3545 Three cases
3546 1. The program / expression is malformed and the context should die.
3547 2. We are finished reading a program and should close off the
3548 internal representation with a closing parenthesis. Then
3549 apply continuation.
3550 3. We are finished reading an expression and should
3551 apply the continuation.
3552
3553 In case 3, we should find the READ_DONE at sp - 1.
3554 In case 2, we should find the READ_DONE at sp - 5.
3555
3556 */
3557
3558 if (lbm_is_symbol(ctx->r)) {
3559 lbm_uint sym_val = lbm_dec_sym(ctx->r);
3560 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
3561 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
3562 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3563 }
3564 }
3565
3566 if (ctx->K.data[ctx->K.sp-1] == READ_DONE(((20) << 2) | 0xF8000001u) &&
3567 lbm_dec_u(ctx->K.data[ctx->K.sp-3]) == 0) {
3568 /* successfully finished reading an expression (CASE 3) */
3569 ctx->app_cont = true1;
3570 } else if (ctx->K.sp > 4 && ctx->K.data[ctx->K.sp - 4] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3571 lbm_value env;
3572 lbm_value s;
3573 lbm_value sym;
3574 lbm_pop_3(&ctx->K, &sym, &env, &s);
3575 ctx->curr_env = env;
3576 ctx->app_cont = true1; // Program evaluated and result is in ctx->r.
3577 } else if (ctx->K.sp > 5 && ctx->K.data[ctx->K.sp - 5] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3578 /* successfully finished reading a program (CASE 2) */
3579 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3580 ctx->app_cont = true1;
3581 } else {
3582 /* Parsing failed */
3583 if (lbm_channel_row(str) == 1 &&
3584 lbm_channel_column(str) == 1 ){
3585 // eof at empty stream.
3586 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3587 ctx->app_cont = true1;
3588 } else {
3589 lbm_set_error_reason((char*)lbm_error_str_parse_eof);
3590 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3591 }
3592 lbm_channel_reader_close(str);
3593 }
3594}
3595
3596/* cont_read_next_token
3597 sp-2 : Stream
3598 sp-1 : Grab row
3599*/
3600static void cont_read_next_token(eval_context_t *ctx) {
3601 lbm_value *sptr = get_stack_ptr(ctx, 2);
3602 lbm_value stream = sptr[0];
3603 lbm_value grab_row0 = sptr[1];
3604
3605 lbm_char_channel_t *chan = lbm_dec_channel(stream);
3606 if (chan == NULL((void*)0) || chan->state == NULL((void*)0)) {
3607 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3608 }
3609
3610 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3611 lbm_stack_drop(&ctx->K, 2);
3612 read_finish(chan, ctx);
3613 return;
3614 }
3615 /* Eat whitespace and comments */
3616 if (!tok_clean_whitespace(chan)) {
3617 sptr[0] = stream;
3618 sptr[1] = lbm_enc_u(0);
3619 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3620 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3621 return;
3622 }
3623 /* After eating whitespace we may be at end of file/stream */
3624 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3625 lbm_stack_drop(&ctx->K, 2);
3626 read_finish(chan, ctx);
3627 return;
3628 }
3629
3630 if (lbm_dec_u(grab_row0)) {
3631 ctx->row0 = (int32_t)lbm_channel_row(chan);
3632 }
3633
3634 /* Attempt to extract tokens from the character stream */
3635 int n = 0;
3636 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3637 unsigned int string_len = 0;
3638
3639 /*
3640 * SYNTAX
3641 */
3642 uint32_t match;
3643 n = tok_syntax(chan, &match);
3644 if (n > 0) {
3645 if (!lbm_channel_drop(chan, (unsigned int)n)) {
3646 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3647 }
3648 ctx->app_cont = true1;
3649 lbm_uint do_next = 0;
3650 switch(match) {
3651 case TOKOPENPAR1u: {
3652 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3653 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3654 lbm_value *rptr = stack_reserve(ctx,5);
3655 rptr[0] = stream;
3656 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3657 rptr[2] = stream;
3658 rptr[3] = lbm_enc_u(0);
3659 rptr[4] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3660 ctx->r = ENC_SYM_OPENPAR(((0x70) << 4) | 0x00000000u);
3661 } return;
3662 case TOKCLOSEPAR2u: {
3663 lbm_stack_drop(&ctx->K, 2);
3664 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3665 } return;
3666 case TOKOPENBRACK3u: {
3667 sptr[0] = stream;
3668 sptr[1] = READ_START_ARRAY(((24) << 2) | 0xF8000001u);
3669 lbm_value *rptr = stack_reserve(ctx, 3);
3670 rptr[0] = stream;
3671 rptr[1] = lbm_enc_u(0);
3672 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3673 ctx->r = ENC_SYM_OPENBRACK(((0x80) << 4) | 0x00000000u);
3674 } return;
3675 case TOKCLOSEBRACK4u:
3676 lbm_stack_drop(&ctx->K, 2);
3677 ctx->r = ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u);
3678 return;
3679 case TOKDOT5u:
3680 lbm_stack_drop(&ctx->K, 2);
3681 ctx->r = ENC_SYM_DOT(((0x76) << 4) | 0x00000000u);
3682 return;
3683 case TOKDONTCARE6u:
3684 lbm_stack_drop(&ctx->K, 2);
3685 ctx->r = ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u);
3686 return;
3687 case TOKQUOTE7u:
3688 do_next = READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u);
3689 break;
3690 case TOKBACKQUOTE8u: {
3691 sptr[0] = QQ_EXPAND_START(((35) << 2) | 0xF8000001u);
3692 sptr[1] = stream;
3693 lbm_value *rptr = stack_reserve(ctx, 2);
3694 rptr[0] = lbm_enc_u(0);
3695 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3696 ctx->app_cont = true1;
3697 } return;
3698 case TOKCOMMAAT9u:
3699 do_next = READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u);
3700 break;
3701 case TOKCOMMA10u:
3702 do_next = READ_COMMA_RESULT(((23) << 2) | 0xF8000001u);
3703 break;
3704 case TOKMATCHANY11u:
3705 lbm_stack_drop(&ctx->K, 2);
3706 ctx->r = ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u);
3707 return;
3708 case TOKOPENCURL12u: {
3709 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3710 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3711 lbm_value *rptr = stack_reserve(ctx,2);
3712 rptr[0] = stream;
3713 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3714 ctx->r = ENC_SYM_PROGN(((0x102) << 4) | 0x00000000u);
3715 } return;
3716 case TOKCLOSECURL13u:
3717 lbm_stack_drop(&ctx->K, 2);
3718 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3719 return;
3720 case TOKCONSTSTART14u: /* fall through */
3721 case TOKCONSTEND15u:
3722 case TOKCONSTSYMSTR16u: {
3723 if (match == TOKCONSTSTART14u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3724 if (match == TOKCONSTEND15u) ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3725 if (match == TOKCONSTSYMSTR16u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04;
3726 sptr[0] = stream;
3727 sptr[1] = lbm_enc_u(0);
3728 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3729 ctx->app_cont = true1;
3730 } return;
3731 default:
3732 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3733 }
3734 sptr[0] = do_next;
3735 sptr[1] = stream;
3736 lbm_value *rptr = stack_reserve(ctx, 2);
3737 rptr[0] = lbm_enc_u(0);
3738 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3739 ctx->app_cont = true1;
3740 return;
3741 } else if (n < 0) goto retry_token;
3742
3743 /*
3744 * STRING
3745 */
3746 n = tok_string(chan, &string_len);
3747 if (n >= 2) {
3748 lbm_channel_drop(chan, (unsigned int)n);
3749 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3750 gc();
3751 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3752 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3753 return; // dead return but static analysis does not know that.
3754 }
3755 }
3756 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(res);
3757 char *data = (char*)arr->data;
3758 memset(data,0, string_len + 1);
3759 memcpy(data, tokpar_sym_str, string_len);
3760 lbm_stack_drop(&ctx->K, 2);
3761 ctx->r = res;
3762 ctx->app_cont = true1;
3763 return;
3764 } else if (n < 0) goto retry_token;
3765
3766 /*
3767 * FLOAT
3768 */
3769 token_float f_val;
3770 n = tok_double(chan, &f_val);
3771 if (n > 0) {
3772 lbm_channel_drop(chan, (unsigned int) n);
3773 switch(f_val.type) {
3774 case TOKTYPEF32107u:
3775 WITH_GC(res, lbm_enc_float((float)f_val.value))(res) = (lbm_enc_float((float)f_val.value)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (lbm_enc_float((float)f_val.value));
if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
3776 break;
3777 case TOKTYPEF64108u:
3778 res = lbm_enc_double(f_val.value);
3779 break;
3780 default:
3781 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3782 }
3783 lbm_stack_drop(&ctx->K, 2);
3784 ctx->r = res;
3785 ctx->app_cont = true1;
3786 return;
3787 } else if (n < 0) goto retry_token;
3788
3789 /*
3790 * INTEGER
3791 */
3792 token_int int_result;
3793 n = tok_integer(chan, &int_result);
3794 if (n > 0) {
3795 lbm_channel_drop(chan, (unsigned int)n);
3796 switch(int_result.type) {
3797 case TOKTYPEBYTE100u:
3798 res = lbm_enc_char((uint8_t)(int_result.negative ? -int_result.value : int_result.value));
3799 break;
3800 case TOKTYPEI101u:
3801 res = lbm_enc_i((lbm_int)(int_result.negative ? -int_result.value : int_result.value));
3802 break;
3803 case TOKTYPEU102u:
3804 res = lbm_enc_u((lbm_uint)(int_result.negative ? -int_result.value : int_result.value));
3805 break;
3806 case TOKTYPEI32103u:
3807 WITH_GC(res, lbm_enc_i32((int32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i32((int32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i32((int32_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3808 break;
3809 case TOKTYPEU32104u:
3810 WITH_GC(res,lbm_enc_u32((uint32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u32((uint32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u32((uint32_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3811 break;
3812 case TOKTYPEI64105u:
3813 WITH_GC(res,lbm_enc_i64((int64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i64((int64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i64((int64_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3814 break;
3815 case TOKTYPEU64106u:
3816 WITH_GC(res,lbm_enc_u64((uint64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u64((uint64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u64((uint64_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3817 break;
3818 default:
3819 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3820 }
3821 lbm_stack_drop(&ctx->K, 2);
3822 ctx->r = res;
3823 ctx->app_cont = true1;
3824 return;
3825 } else if (n < 0) goto retry_token;
3826
3827 /*
3828 * SYMBOL
3829 */
3830 n = tok_symbol(chan);
3831 if (n > 0) {
3832 lbm_channel_drop(chan, (unsigned int) n);
3833 lbm_uint symbol_id;
3834 if (lbm_get_symbol_by_name(tokpar_sym_str, &symbol_id)) {
3835 res = lbm_enc_sym(symbol_id);
3836 } else {
3837 int r = 0;
3838 if (n > 4 &&
3839 tokpar_sym_str[0] == 'e' &&
3840 tokpar_sym_str[1] == 'x' &&
3841 tokpar_sym_str[2] == 't' &&
3842 tokpar_sym_str[3] == '-') {
3843 lbm_uint ext_id;
3844 lbm_uint ext_name_len = (lbm_uint)n + 1;
3845 char *ext_name = lbm_malloc(ext_name_len);
3846 if (!ext_name) {
3847 gc();
3848 ext_name = lbm_malloc(ext_name_len);
3849 }
3850 if (ext_name) {
3851 memcpy(ext_name, tokpar_sym_str, ext_name_len);
3852 r = lbm_add_extension(ext_name, lbm_extensions_default);
3853 if (!lbm_lookup_extension_id(ext_name, &ext_id)) {
3854 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3855 }
3856 symbol_id = ext_id;
3857 } else {
3858 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3859 }
3860 } else {
3861 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04 &&
3862 ctx->flags & EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08) {
3863 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id, true1); //flash
3864 if (!r) {
3865 lbm_set_error_reason((char*)lbm_error_str_flash_error);
3866 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3867 }
3868 } else {
3869 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3870 if (!r) {
3871 gc();
3872 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3873 }
3874 }
3875 }
3876 if (r) {
3877 res = lbm_enc_sym(symbol_id);
3878 } else {
3879 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3880 }
3881 }
3882 lbm_stack_drop(&ctx->K, 2);
3883 ctx->r = res;
3884 ctx->app_cont = true1;
3885 return;
3886 } else if (n == TOKENIZER_NEED_MORE-1) {
3887 goto retry_token;
3888 } else if (n <= TOKENIZER_STRING_ERROR-2) {
3889 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3890 }
3891
3892 /*
3893 * CHAR
3894 */
3895 char c_val;
3896 n = tok_char(chan, &c_val);
3897 if(n > 0) {
3898 lbm_channel_drop(chan,(unsigned int) n);
3899 lbm_stack_drop(&ctx->K, 2);
3900 ctx->r = lbm_enc_char((uint8_t)c_val);
3901 ctx->app_cont = true1;
3902 return;
3903 }else if (n < 0) goto retry_token;
3904
3905 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3906
3907 retry_token:
3908 if (n == TOKENIZER_NEED_MORE-1) {
3909 sptr[0] = stream;
3910 sptr[1] = lbm_enc_u(0);
3911 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3912 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3913 return;
3914 }
3915 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3916}
3917
3918static void cont_read_start_array(eval_context_t *ctx) {
3919 lbm_value *sptr = get_stack_ptr(ctx, 1);
3920 lbm_value stream = sptr[0];
3921
3922 lbm_char_channel_t *str = lbm_dec_channel(stream);
3923 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
3924 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3925 }
3926
3927 lbm_uint num_free = lbm_memory_longest_free();
3928 lbm_uint initial_size = (lbm_uint)((float)num_free * 0.9);
3929 if (initial_size == 0) {
3930 gc();
3931 num_free = lbm_memory_longest_free();
3932 initial_size = (lbm_uint)((float)num_free * 0.9);
3933 if (initial_size == 0) {
3934 lbm_channel_reader_close(str);
3935 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3936 }
3937 }
3938
3939 if (lbm_is_number(ctx->r)) {
3940 lbm_value array;
3941 initial_size = sizeof(lbm_uint) * initial_size;
3942
3943 if (!lbm_heap_allocate_array(&array, initial_size)) {
3944 lbm_set_error_reason("Out of memory while reading.");
3945 lbm_channel_reader_close(str);
3946 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3947 // NOTE: If array is not created evaluation ends here.
3948 // Static analysis seems unaware.
3949 }
3950
3951 sptr[0] = array;
3952 lbm_value *rptr = stack_reserve(ctx, 4);
3953 rptr[0] = lbm_enc_u(initial_size);
3954 rptr[1] = lbm_enc_u(0);
3955 rptr[2] = stream;
3956 rptr[3] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3957 ctx->app_cont = true1;
3958 } else {
3959 lbm_channel_reader_close(str);
3960 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3961 }
3962}
3963
3964static void cont_read_append_array(eval_context_t *ctx) {
3965 lbm_uint *sptr = get_stack_ptr(ctx, 4);
3966
3967 lbm_value array = sptr[0];
3968 lbm_value size = lbm_dec_as_u32(sptr[1]);
3969 lbm_value ix = lbm_dec_as_u32(sptr[2]);
3970 lbm_value stream = sptr[3];
3971
3972 if (ix >= (size - 1)) {
3973 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3974 }
3975
3976 // get_car can return nil. Whose value is 0!
3977 // So static Analysis is right about this being a potential NULL pointer.
3978 // However, if the array was created correcly to begin with, it should be fine.
3979 lbm_value arr_car = get_car(array);
3980 lbm_array_header_t *arr = (lbm_array_header_t*)arr_car;
3981
3982 if (lbm_is_number(ctx->r)) {
3983 ((uint8_t*)arr->data)[ix] = (uint8_t)lbm_dec_as_u32(ctx->r);
3984
3985 sptr[2] = lbm_enc_u(ix + 1);
3986 lbm_value *rptr = stack_reserve(ctx, 4);
3987 rptr[0] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3988 rptr[1] = stream;
3989 rptr[2] = lbm_enc_u(0);
3990 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3991 ctx->app_cont = true1;
3992 } else if (lbm_is_symbol(ctx->r) && ctx->r == ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u)) {
3993 lbm_uint array_size = ix / sizeof(lbm_uint);
3994
3995 if (ix % sizeof(lbm_uint) != 0) {
3996 array_size = array_size + 1;
3997 }
3998 lbm_memory_shrink((lbm_uint*)arr->data, array_size);
3999 arr->size = ix;
4000 lbm_stack_drop(&ctx->K, 4);
4001 ctx->r = array;
4002 ctx->app_cont = true1;
4003 } else {
4004 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
4005 }
4006}
4007
4008static void cont_read_append_continue(eval_context_t *ctx) {
4009 lbm_value *sptr = get_stack_ptr(ctx, 3);
4010
4011 lbm_value first_cell = sptr[0];
4012 lbm_value last_cell = sptr[1];
4013 lbm_value stream = sptr[2];
4014
4015 lbm_char_channel_t *str = lbm_dec_channel(stream);
4016 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4017 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4018 }
4019
4020 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4021
4022 switch(ctx->r) {
4023 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4024 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4025 lbm_set_cdr(last_cell, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate the list
4026 ctx->r = first_cell;
4027 } else {
4028 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4029 }
4030 lbm_stack_drop(&ctx->K, 3);
4031 /* Skip reading another token and apply the continuation */
4032 ctx->app_cont = true1;
4033 return;
4034 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4035 lbm_value *rptr = stack_reserve(ctx, 4);
4036 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4037 rptr[1] = stream;
4038 rptr[2] = lbm_enc_u(0);
4039 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4040 ctx->app_cont = true1;
4041 } return;
4042 }
4043 }
4044 lbm_value new_cell = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4045 if (lbm_is_symbol_merror(new_cell)) {
4046 lbm_channel_reader_close(str);
4047 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4048 return;
4049 }
4050 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4051 lbm_set_cdr(last_cell, new_cell);
4052 last_cell = new_cell;
4053 } else {
4054 first_cell = last_cell = new_cell;
4055 }
4056 sptr[0] = first_cell;
4057 sptr[1] = last_cell;
4058 sptr[2] = stream; // unchanged.
4059 lbm_value *rptr = stack_reserve(ctx, 4);
4060 rptr[0] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
4061 rptr[1] = stream;
4062 rptr[2] = lbm_enc_u(0);
4063 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4064 ctx->app_cont = true1;
4065}
4066
4067static void cont_read_eval_continue(eval_context_t *ctx) {
4068 lbm_value env;
4069 lbm_value stream;
4070 lbm_pop_2(&ctx->K, &env, &stream);
4071
4072 lbm_char_channel_t *str = lbm_dec_channel(stream);
4073 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4074 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4075 }
4076
4077 ctx->row1 = (lbm_int)str->row(str);
4078
4079 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4080
4081 switch(ctx->r) {
4082 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4083 ctx->app_cont = true1;
4084 return;
4085 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4086 // This case is a bit mysterious.
4087 // A dot, may in reality be an error in this location.
4088 lbm_value *rptr = stack_reserve(ctx, 4);
4089 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4090 rptr[1] = stream;
4091 rptr[2] = lbm_enc_u(0);
4092 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4093 ctx->app_cont = true1;
4094 } return;
4095 }
4096 }
4097
4098 lbm_value *rptr = stack_reserve(ctx, 6);
4099 rptr[0] = stream;
4100 rptr[1] = env;
4101 rptr[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
4102 rptr[3] = stream;
4103 rptr[4] = lbm_enc_u(1);
4104 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4105 rptr[6] = lbm_enc_u(ctx->flags);
4106 rptr[7] = POP_READER_FLAGS(((47) << 2) | 0xF8000001u);
4107 ctx->curr_env = env;
4108 ctx->curr_exp = ctx->r;
4109}
4110
4111static void cont_read_expect_closepar(eval_context_t *ctx) {
4112 lbm_value res;
4113 lbm_value stream;
4114
4115 lbm_pop_2(&ctx->K, &res, &stream);
4116
4117 lbm_char_channel_t *str = lbm_dec_channel(stream);
4118 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4119 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4120 }
4121
4122 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4123 ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u)) {
4124 ctx->r = res;
4125 ctx->app_cont = true1;
4126 } else {
4127 lbm_channel_reader_close(str);
4128 lbm_set_error_reason((char*)lbm_error_str_parse_close);
4129 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4130 }
4131}
4132
4133static void cont_read_dot_terminate(eval_context_t *ctx) {
4134 lbm_value *sptr = get_stack_ptr(ctx, 3);
4135
4136 lbm_value first_cell = sptr[0];
4137 lbm_value last_cell = sptr[1];
4138 lbm_value stream = sptr[2];
4139
4140 lbm_char_channel_t *str = lbm_dec_channel(stream);
4141 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4142 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4143 }
4144
4145 lbm_stack_drop(&ctx->K ,3);
4146
4147 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4148 (ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u) ||
4149 ctx->r == ENC_SYM_DOT(((0x76) << 4) | 0x00000000u))) {
4150 lbm_channel_reader_close(str);
4151 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4152 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4153 } else {
4154 if (lbm_is_cons(last_cell)) {
4155 lbm_set_cdr(last_cell, ctx->r);
4156 ctx->r = first_cell;
4157 lbm_value *rptr = stack_reserve(ctx, 6);
4158 rptr[0] = stream;
4159 rptr[1] = ctx->r;
4160 rptr[2] = READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u);
4161 rptr[3] = stream;
4162 rptr[4] = lbm_enc_u(0);
4163 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4164 ctx->app_cont = true1;
4165 } else {
4166 lbm_channel_reader_close(str);
4167 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4168 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4169 }
4170 }
4171}
4172
4173static void cont_read_done(eval_context_t *ctx) {
4174 lbm_value stream;
4175 lbm_value f_val;
4176 lbm_pop_2(&ctx->K, &stream ,&f_val);
4177
4178 uint32_t flags = lbm_dec_as_u32(f_val);
4179 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4180 ctx->flags |= (flags & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4181
4182 lbm_char_channel_t *str = lbm_dec_channel(stream);
4183 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4184 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4185 }
4186
4187 lbm_channel_reader_close(str);
4188 if (lbm_is_symbol(ctx->r)) {
4189 lbm_uint sym_val = lbm_dec_sym(ctx->r);
4190 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
4191 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
4192 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4193 }
4194 }
4195
4196 ctx->row0 = -1;
4197 ctx->row1 = -1;
4198 ctx->app_cont = true1;
4199}
4200
4201static void cont_read_quote_result(eval_context_t *ctx) {
4202 lbm_value cell;
4203 WITH_GC(cell, lbm_heap_allocate_list_init(2,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4204 ENC_SYM_QUOTE,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4205 ctx->r))(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
};
4206 ctx->r = cell;
4207 ctx->app_cont = true1;
4208}
4209
4210static void cont_read_commaat_result(eval_context_t *ctx) {
4211 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4212 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4213 ctx->r = cell1;
4214 ctx->app_cont = true1;
4215}
4216
4217static void cont_read_comma_result(eval_context_t *ctx) {
4218 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u),ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4219 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4220 ctx->r = cell1;
4221 ctx->app_cont = true1;
4222}
4223
4224static void cont_application_start(eval_context_t *ctx) {
4225
4226 /* sptr[0] = env
4227 * sptr[1] = args
4228 * ctx->r = function
4229 */
4230
4231 if (lbm_is_symbol(ctx->r)) {
1
Calling 'lbm_is_symbol'
→
4
←
Returning from 'lbm_is_symbol'
→
5
←
Taking false branch
→
4232 stack_reserve(ctx,1)[0] = lbm_enc_u(0);
4233 cont_application_args(ctx);
4234 } else if (lbm_is_cons(ctx->r)) {
6
←
Calling 'lbm_is_cons'
→
10
←
Returning from 'lbm_is_cons'
→
11
←
Taking true branch
→
4235 lbm_uint *sptr = get_stack_ptr(ctx, 2);
4236 lbm_value args = (lbm_value)sptr[1];
4237 switch (get_car(ctx->r)) {
12
←
Calling 'get_car'
→
15
←
Returning from 'get_car'
→
16
←
Control jumps to 'case 4336:' at line 4238
→
4238 case ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u): {
4239 lbm_value cl[3];
4240 extract_n(get_cdr(ctx->r), cl, 3);
4241 lbm_value arg_env = (lbm_value)sptr[0];
4242 lbm_value arg0, arg_rest;
17
←
'arg0' declared without an initial value
→
4243 get_car_and_cdr(args, &arg0, &arg_rest);
18
←
Calling 'get_car_and_cdr'
→
26
←
Returning from 'get_car_and_cdr'
→
4244 sptr[1] = cl[CLO_BODY1];
4245 bool_Bool a_nil = lbm_is_symbol_nil(args);
27
←
Calling 'lbm_is_symbol_nil'
→
29
←
Returning from 'lbm_is_symbol_nil'
→
4246 bool_Bool p_nil = lbm_is_symbol_nil(cl[CLO_PARAMS0]);
30
←
Calling 'lbm_is_symbol_nil'
→
33
←
Returning from 'lbm_is_symbol_nil'
→
4247 lbm_value *reserved = stack_reserve(ctx, 4);
4248
4249 if (!a_nil
33.1
'a_nil' is false
33.1
'a_nil' is false
 && !p_nil
33.2
'p_nil' is false
33.2
'p_nil' is false
) {
34
←
Taking true branch
→
4250 reserved[0] = cl[CLO_ENV2];
4251 reserved[1] = cl[CLO_PARAMS0];
4252 reserved[2] = arg_rest;
4253 reserved[3] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
4254 ctx->curr_exp = arg0;
35
←
Assigned value is garbage or undefined
4255 ctx->curr_env = arg_env;
4256 } else if (a_nil && p_nil) {
4257 // No params, No args
4258 lbm_stack_drop(&ctx->K, 6);
4259 ctx->curr_exp = cl[CLO_BODY1];
4260 ctx->curr_env = cl[CLO_ENV2];
4261 } else if (p_nil) {
4262 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), cl[CLO_ENV2]);
4263 reserved[0] = rest_binder;
4264 reserved[1] = get_cdr(args);
4265 reserved[2] = get_car(rest_binder);
4266 reserved[3] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
4267 ctx->curr_exp = get_car(args);
4268 ctx->curr_env = arg_env;
4269 } else {
4270 lbm_set_error_reason((char*)lbm_error_str_num_args);
4271 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->r);
4272 }
4273 } break;
4274 case ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u):{
4275 /* Continuation created using call-cc.
4276 * ((SYM_CONT . cont-array) arg0 )
4277 */
4278 lbm_value c = get_cdr(ctx->r); /* should be the continuation array*/
4279
4280 if (!lbm_is_lisp_array_r(c)) {
4281 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4282 }
4283
4284 lbm_uint arg_count = lbm_list_length(args);
4285 lbm_value arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4286 switch (arg_count) {
4287 case 0:
4288 arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4289 break;
4290 case 1:
4291 arg = get_car(args);
4292 break;
4293 default:
4294 lbm_set_error_reason((char*)lbm_error_str_num_args);
4295 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4296 }
4297 lbm_stack_clear(&ctx->K);
4298
4299 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(c);
4300
4301 ctx->K.sp = arr->size / sizeof(lbm_uint);
4302 memcpy(ctx->K.data, arr->data, arr->size);
4303
4304 ctx->curr_exp = arg;
4305 break;
4306 }
4307 case ENC_SYM_MACRO(((0x10D) << 4) | 0x00000000u):{
4308 /*
4309 * Perform macro expansion.
4310 * Macro expansion is really just evaluation in an
4311 * environment augmented with the unevaluated expressions passed
4312 * as arguments.
4313 */
4314 lbm_value env = (lbm_value)sptr[0];
4315
4316 lbm_value curr_param = get_cadr(ctx->r);
4317 lbm_value curr_arg = args;
4318 lbm_value expand_env = env;
4319 while (lbm_is_cons(curr_param) &&
4320 lbm_is_cons(curr_arg)) {
4321 lbm_value car_curr_param, cdr_curr_param;
4322 lbm_value car_curr_arg, cdr_curr_arg;
4323 get_car_and_cdr(curr_param, &car_curr_param, &cdr_curr_param);
4324 get_car_and_cdr(curr_arg, &car_curr_arg, &cdr_curr_arg);
4325
4326 lbm_value entry = cons_with_gc(car_curr_param, car_curr_arg, expand_env);
4327 lbm_value aug_env = cons_with_gc(entry, expand_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4328 expand_env = aug_env;
4329
4330 curr_param = cdr_curr_param;
4331 curr_arg = cdr_curr_arg;
4332 }
4333 /* Two rounds of evaluation is performed.
4334 * First to instantiate the arguments into the macro body.
4335 * Second to evaluate the resulting program.
4336 */
4337 sptr[1] = EVAL_R(((11) << 2) | 0xF8000001u);
4338 lbm_value exp = get_cadr(get_cdr(ctx->r));
4339 ctx->curr_exp = exp;
4340 ctx->curr_env = expand_env;
4341 } break;
4342 default:
4343 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4344 }
4345 } else {
4346 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4347 }
4348}
4349
4350static void cont_eval_r(eval_context_t* ctx) {
4351 lbm_value env;
4352 lbm_pop(&ctx->K, &env);
4353 ctx->curr_exp = ctx->r;
4354 ctx->curr_env = env;
4355}
4356
4357static void cont_progn_var(eval_context_t* ctx) {
4358
4359 lbm_value key;
4360 lbm_value env;
4361
4362 lbm_pop_2(&ctx->K, &key, &env);
4363
4364 if (fill_binding_location(key, ctx->r, env) < 0) {
4365 lbm_set_error_reason("Incorrect type of name/key in let-binding");
4366 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
4367 }
4368
4369 ctx->app_cont = true1;
4370}
4371
4372static void cont_setq(eval_context_t *ctx) {
4373 lbm_value sym;
4374 lbm_value env;
4375 lbm_pop_2(&ctx->K, &sym, &env);
4376 lbm_value res;
4377 WITH_GC(res, perform_setvar(sym, ctx->r, env))(res) = (perform_setvar(sym, ctx->r, env)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (perform_setvar(sym, ctx->r, env)
); if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
4378 ctx->r = res;
4379 ctx->app_cont = true1;
4380}
4381
4382lbm_flash_status request_flash_storage_cell(lbm_value val, lbm_value *res) {
4383
4384 lbm_value flash_cell;
4385 lbm_flash_status s = lbm_allocate_const_cell(&flash_cell);
4386 if (s != LBM_FLASH_WRITE_OK)
4387 return s;
4388 lbm_value new_val = val;
4389 new_val &= ~LBM_PTR_VAL_MASK0x03FFFFFCu; // clear the value part of the ptr
4390 new_val |= (flash_cell & LBM_PTR_VAL_MASK0x03FFFFFCu);
4391 new_val |= LBM_PTR_TO_CONSTANT_BIT0x04000000u;
4392 *res = new_val;
4393 return s;
4394}
4395
4396static void cont_move_to_flash(eval_context_t *ctx) {
4397
4398 lbm_value args;
4399 lbm_pop(&ctx->K, &args);
4400
4401 if (lbm_is_symbol_nil(args)) {
4402 // Done looping over arguments. return true.
4403 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
4404 ctx->app_cont = true1;
4405 return;
4406 }
4407
4408 lbm_value first_arg, rest;
4409 get_car_and_cdr(args, &first_arg, &rest);
4410
4411 lbm_value val;
4412 if (lbm_is_symbol(first_arg) && lbm_global_env_lookup(&val, first_arg)) {
4413 // Prepare to copy the rest of the arguments when done with first.
4414 lbm_value *rptr = stack_reserve(ctx, 2);
4415 rptr[0] = rest;
4416 rptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
4417 if (lbm_is_ptr(val) &&
4418 (!(val & LBM_PTR_TO_CONSTANT_BIT0x04000000u))) {
4419 lbm_value * rptr1 = stack_reserve(ctx, 3);
4420 rptr1[0] = first_arg;
4421 rptr1[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
4422 rptr1[2] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4423 ctx->r = val;
4424 }
4425 ctx->app_cont = true1;
4426 return;
4427 }
4428 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4429}
4430
4431static void cont_move_val_to_flash_dispatch(eval_context_t *ctx) {
4432
4433 lbm_value val = ctx->r;
4434
4435 if (lbm_is_cons(val)) {
4436 lbm_value *rptr = stack_reserve(ctx, 5);
4437 rptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // fst cell of list
4438 rptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last cell of list
4439 rptr[2] = get_cdr(val);
4440 rptr[3] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4441 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4442 ctx->r = get_car(val);
4443 ctx->app_cont = true1;
4444 return;
4445 }
4446
4447 if (lbm_is_ptr(val) && (val & LBM_PTR_TO_CONSTANT_BIT0x04000000u)) {
4448 ctx->r = val;
4449 ctx->app_cont = true1;
4450 return;
4451 }
4452
4453 if (lbm_is_ptr(val)) {
4454 lbm_cons_t *ref = lbm_ref_cell(val);
4455 if (lbm_type_of(ref->cdr) == LBM_TYPE_SYMBOL0x00000000u) {
4456 switch (ref->cdr) {
4457 case ENC_SYM_RAW_I_TYPE(((0x31) << 4) | 0x00000000u): /* fall through */
4458 case ENC_SYM_RAW_U_TYPE(((0x32) << 4) | 0x00000000u):
4459 case ENC_SYM_RAW_F_TYPE(((0x33) << 4) | 0x00000000u): {
4460 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4461 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4462 handle_flash_status(write_const_car(flash_cell, ref->car));
4463 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4464 ctx->r = flash_cell;
4465 } break;
4466 case ENC_SYM_IND_I_TYPE(((0x34) << 4) | 0x00000000u): /* fall through */
4467 case ENC_SYM_IND_U_TYPE(((0x35) << 4) | 0x00000000u):
4468 case ENC_SYM_IND_F_TYPE(((0x36) << 4) | 0x00000000u): {
4469#ifndef LBM64
4470 /* 64 bit values are in lbm mem on 32bit platforms. */
4471 lbm_uint *lbm_mem_ptr = (lbm_uint*)ref->car;
4472 lbm_uint flash_ptr;
4473
4474 handle_flash_status(lbm_write_const_raw(lbm_mem_ptr, 2, &flash_ptr));
4475 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4476 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4477 handle_flash_status(write_const_car(flash_cell, flash_ptr));
4478 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4479 ctx->r = flash_cell;
4480#else
4481 // There are no indirect types in LBM64
4482 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4483#endif
4484 } break;
4485 case ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u): {
4486 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4487 lbm_uint size = arr->size / sizeof(lbm_uint);
4488 lbm_uint flash_addr;
4489 lbm_value *arrdata = (lbm_value *)arr->data;
4490 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4491 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4492 handle_flash_status(lbm_allocate_const_raw(size, &flash_addr));
4493 lift_array_flash(flash_cell,
4494 false0,
4495 (char *)flash_addr,
4496 arr->size);
4497 // Move array contents to flash recursively
4498 lbm_value *rptr = stack_reserve(ctx, 5);
4499 rptr[0] = flash_cell;
4500 rptr[1] = lbm_enc_u(0);
4501 rptr[2] = val;
4502 rptr[3] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4503 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4504 ctx->r = arrdata[0];
4505 ctx->app_cont = true1;
4506 return;
4507 }
4508 case ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u): {
4509 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4510 // arbitrary address: flash_arr.
4511 lbm_uint flash_arr;
4512 handle_flash_status(lbm_write_const_array_padded((uint8_t*)arr->data, arr->size, &flash_arr));
4513 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4514 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4515 lift_array_flash(flash_cell,
4516 true1,
4517 (char *)flash_arr,
4518 arr->size);
4519 ctx->r = flash_cell;
4520 } break;
4521 case ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u): /* fall through */
4522 case ENC_SYM_CUSTOM_TYPE(((0x38) << 4) | 0x00000000u):
4523 lbm_set_error_reason((char *)lbm_error_str_flash_not_possible);
4524 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4525 }
4526 } else {
4527 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4528 }
4529 ctx->app_cont = true1;
4530 return;
4531 }
4532 ctx->r = val;
4533 ctx->app_cont = true1;
4534}
4535
4536static void cont_move_list_to_flash(eval_context_t *ctx) {
4537
4538 // ctx->r holds the value that should go in car
4539
4540 lbm_value *sptr = get_stack_ptr(ctx, 3);
4541
4542 lbm_value fst = sptr[0];
4543 lbm_value lst = sptr[1];
4544 lbm_value val = sptr[2];
4545
4546
4547 lbm_value new_lst = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4548 // Allocate element ptr storage after storing the element to flash.
4549 handle_flash_status(request_flash_storage_cell(lbm_enc_cons_ptr(LBM_PTR_NULL(0x03FFFFFCu >> 2)), &new_lst));
4550
4551 if (lbm_is_symbol_nil(fst)) {
4552 lst = new_lst;
4553 fst = new_lst;
4554 handle_flash_status(write_const_car(lst, ctx->r));
4555 } else {
4556 handle_flash_status(write_const_cdr(lst, new_lst)); // low before high
4557 handle_flash_status(write_const_car(new_lst, ctx->r));
4558 lst = new_lst;
4559 }
4560
4561 if (lbm_is_cons(val)) {
4562 sptr[0] = fst;
4563 sptr[1] = lst;//rest_cell;
4564 sptr[2] = get_cdr(val);
4565 lbm_value *rptr = stack_reserve(ctx, 2);
4566 rptr[0] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4567 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4568 ctx->r = get_car(val);
4569 } else {
4570 sptr[0] = fst;
4571 sptr[1] = lst;
4572 sptr[2] = CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u);
4573 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4574 ctx->r = val;
4575 }
4576 ctx->app_cont = true1;
4577}
4578
4579static void cont_close_list_in_flash(eval_context_t *ctx) {
4580 lbm_value fst;
4581 lbm_value lst;
4582 lbm_pop_2(&ctx->K, &lst, &fst);
4583 lbm_value val = ctx->r;
4584 handle_flash_status(write_const_cdr(lst, val));
4585 ctx->r = fst;
4586 ctx->app_cont = true1;
4587}
4588
4589static void cont_move_array_elts_to_flash(eval_context_t *ctx) {
4590 lbm_value *sptr = get_stack_ptr(ctx, 3);
4591 // sptr[2] = source array in RAM
4592 // sptr[1] = current index
4593 // sptr[0] = target array in flash
4594 lbm_array_header_t *src_arr = (lbm_array_header_t*)get_car(sptr[2]);
4595 lbm_uint size = src_arr->size / sizeof(lbm_uint);
4596 lbm_value *srcdata = (lbm_value *)src_arr->data;
4597
4598 lbm_array_header_t *tgt_arr = (lbm_array_header_t*)get_car(sptr[0]);
4599 lbm_uint *tgtdata = (lbm_value *)tgt_arr->data;
4600 lbm_uint ix = lbm_dec_as_u32(sptr[1]);
4601 handle_flash_status(lbm_const_write(&tgtdata[ix], ctx->r));
4602 if (ix >= size-1) {
4603 ctx->r = sptr[0];
4604 lbm_stack_drop(&ctx->K, 3);
4605 ctx->app_cont = true1;
4606 return;
4607 }
4608 sptr[1] = lbm_enc_u(ix + 1);
4609 lbm_value *rptr = stack_reserve(ctx, 2);
4610 rptr[0] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4611 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4612 ctx->r = srcdata[ix+1];
4613 ctx->app_cont = true1;
4614 return;
4615}
4616
4617static void cont_qq_expand_start(eval_context_t *ctx) {
4618 lbm_value *rptr = stack_reserve(ctx, 2);
4619 rptr[0] = ctx->r;
4620 rptr[1] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4621 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4622 ctx->app_cont = true1;
4623}
4624
4625lbm_value quote_it(lbm_value qquoted) {
4626 if (lbm_is_symbol(qquoted) &&
4627 lbm_is_special(qquoted)) return qquoted;
4628
4629 lbm_value val = cons_with_gc(qquoted, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4630 return cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4631}
4632
4633bool_Bool is_append(lbm_value a) {
4634 return (lbm_is_cons(a) &&
4635 lbm_is_symbol(get_car(a)) &&
4636 (get_car(a) == ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u)));
4637}
4638
4639lbm_value append(lbm_value front, lbm_value back) {
4640 if (lbm_is_symbol_nil(front)) return back;
4641 if (lbm_is_symbol_nil(back)) return front;
4642
4643 if (lbm_is_quoted_list(front) &&
4644 lbm_is_quoted_list(back)) {
4645 lbm_value f = get_cadr(front);
4646 lbm_value b = get_cadr(back);
4647 return quote_it(lbm_list_append(f, b));
4648 }
4649
4650 if (is_append(back) &&
4651 lbm_is_quoted_list(get_cadr(back)) &&
4652 lbm_is_quoted_list(front)) {
4653 lbm_value ql = get_cadr(back);
4654 lbm_value f = get_cadr(front);
4655 lbm_value b = get_cadr(ql);
4656
4657 lbm_value v = lbm_list_append(f, b);
4658 lbm_set_car(get_cdr(ql), v);
4659 return back;
4660 }
4661
4662 if (is_append(back)) {
4663 back = get_cdr(back);
4664 lbm_value new = cons_with_gc(front, back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4665 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), new, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4666 }
4667
4668 lbm_value t0, t1;
4669
4670 t0 = cons_with_gc(back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), front);
4671 t1 = cons_with_gc(front, t0, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4672 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), t1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4673}
4674
4675/* Bawden's qq-expand implementation
4676(define (qq-expand x)
4677 (cond ((tag-comma? x)
4678 (tag-data x))
4679 ((tag-comma-atsign? x)
4680 (error "Illegal"))
4681 ((tag-backquote? x)
4682 (qq-expand
4683 (qq-expand (tag-data x))))
4684 ((pair? x)
4685 `(append
4686 ,(qq-expand-list (car x))
4687 ,(qq-expand (cdr x))))
4688 (else `',x)))
4689 */
4690static void cont_qq_expand(eval_context_t *ctx) {
4691 lbm_value qquoted;
4692 lbm_pop(&ctx->K, &qquoted);
4693
4694 switch(lbm_type_of(qquoted)) {
4695 case LBM_TYPE_CONS0x10000000u: {
4696 lbm_value car_val = get_car(qquoted);
4697 lbm_value cdr_val = get_cdr(qquoted);
4698 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4699 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4700 ctx->r = append(ctx->r, get_car(cdr_val));
4701 ctx->app_cont = true1;
4702 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4703 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4704 error_ctx(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u));
4705 } else {
4706 lbm_value *rptr = stack_reserve(ctx, 6);
4707 rptr[0] = ctx->r;
4708 rptr[1] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4709 rptr[2] = cdr_val;
4710 rptr[3] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4711 rptr[4] = car_val;
4712 rptr[5] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4713 ctx->app_cont = true1;
4714 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4715 }
4716
4717 } break;
4718 default: {
4719 lbm_value res = quote_it(qquoted);
4720 ctx->r = append(ctx->r, res);
4721 ctx->app_cont = true1;
4722 }
4723 }
4724}
4725
4726static void cont_qq_append(eval_context_t *ctx) {
4727 lbm_value head;
4728 lbm_pop(&ctx->K, &head);
4729 ctx->r = append(head, ctx->r);
4730 ctx->app_cont = true1;
4731}
4732
4733/* Bawden's qq-expand-list implementation
4734(define (qq-expand-list x)
4735 (cond ((tag-comma? x)
4736 `(list ,(tag-data x)))
4737 ((tag-comma-atsign? x)
4738 (tag-data x))
4739 ((tag-backquote? x)
4740 (qq-expand-list
4741 (qq-expand (tag-data x))))
4742 ((pair? x)
4743 `(list
4744 (append
4745 ,(qq-expand-list (car x))
4746 ,(qq-expand (cdr x)))))
4747 (else `'(,x))))
4748*/
4749
4750static void cont_qq_expand_list(eval_context_t* ctx) {
4751 lbm_value l;
4752 lbm_pop(&ctx->K, &l);
4753
4754 ctx->app_cont = true1;
4755 switch(lbm_type_of(l)) {
4756 case LBM_TYPE_CONS0x10000000u: {
4757 lbm_value car_val = get_car(l);
4758 lbm_value cdr_val = get_cdr(l);
4759 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4760 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4761 lbm_value tl = cons_with_gc(get_car(cdr_val), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4762 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4763 ctx->r = append(ctx->r, tmp);
4764 return;
4765 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4766 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4767 ctx->r = get_car(cdr_val);
4768 return;
4769 } else {
4770 lbm_value *rptr = stack_reserve(ctx, 7);
4771 rptr[0] = QQ_LIST(((39) << 2) | 0xF8000001u);
4772 rptr[1] = ctx->r;
4773 rptr[2] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4774 rptr[3] = cdr_val;
4775 rptr[4] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4776 rptr[5] = car_val;
4777 rptr[6] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4778 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4779 }
4780
4781 } break;
4782 default: {
4783 lbm_value a_list = cons_with_gc(l, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4784 lbm_value tl = cons_with_gc(a_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4785 lbm_value tmp = cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4786 ctx->r = append(ctx->r, tmp);
4787 }
4788 }
4789}
4790
4791static void cont_qq_list(eval_context_t *ctx) {
4792 lbm_value val = ctx->r;
4793 lbm_value apnd_app = cons_with_gc(val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4794 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), apnd_app, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4795 ctx->r = tmp;
4796 ctx->app_cont = true1;
4797}
4798
4799static void cont_kill(eval_context_t *ctx) {
4800 (void) ctx;
4801 finish_ctx();
4802}
4803
4804static void cont_pop_reader_flags(eval_context_t *ctx) {
4805 lbm_value flags;
4806 lbm_pop(&ctx->K, &flags);
4807 ctx->flags = ctx->flags & ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4808 ctx->flags |= (lbm_dec_as_u32(flags) & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4809 // r is unchanged.
4810 ctx->app_cont = true1;
4811}
4812
4813static void cont_exception_handler(eval_context_t *ctx) {
4814 lbm_value *sptr = pop_stack_ptr(ctx, 2);
4815 lbm_value retval = sptr[0];
4816 lbm_value flags = sptr[1];
4817 lbm_set_car(get_cdr(retval), ctx->r);
4818 ctx->flags = flags;
4819 ctx->r = retval;
4820 ctx->app_cont = true1;
4821}
4822
4823/*********************************************************/
4824/* Continuations table */
4825typedef void (*cont_fun)(eval_context_t *);
4826
4827static const cont_fun continuations[NUM_CONTINUATIONS49] =
4828 { advance_ctx, // CONT_DONE
4829 cont_set_global_env,
4830 cont_bind_to_key_rest,
4831 cont_if,
4832 cont_progn_rest,
4833 cont_application_args,
4834 cont_and,
4835 cont_or,
4836 cont_wait,
4837 cont_match,
4838 cont_application_start,
4839 cont_eval_r,
4840 cont_resume,
4841 cont_closure_application_args,
4842 cont_exit_atomic,
4843 cont_read_next_token,
4844 cont_read_append_continue,
4845 cont_read_eval_continue,
4846 cont_read_expect_closepar,
4847 cont_read_dot_terminate,
4848 cont_read_done,
4849 cont_read_quote_result,
4850 cont_read_commaat_result,
4851 cont_read_comma_result,
4852 cont_read_start_array,
4853 cont_read_append_array,
4854 cont_map,
4855 cont_match_guard,
4856 cont_terminate,
4857 cont_progn_var,
4858 cont_setq,
4859 cont_move_to_flash,
4860 cont_move_val_to_flash_dispatch,
4861 cont_move_list_to_flash,
4862 cont_close_list_in_flash,
4863 cont_qq_expand_start,
4864 cont_qq_expand,
4865 cont_qq_append,
4866 cont_qq_expand_list,
4867 cont_qq_list,
4868 cont_kill,
4869 cont_loop,
4870 cont_loop_condition,
4871 cont_merge_rest,
4872 cont_merge_layer,
4873 cont_closure_args_rest,
4874 cont_move_array_elts_to_flash,
4875 cont_pop_reader_flags,
4876 cont_exception_handler
4877 };
4878
4879/*********************************************************/
4880/* Evaluators lookup table (special forms) */
4881typedef void (*evaluator_fun)(eval_context_t *);
4882
4883static const evaluator_fun evaluators[] =
4884 {
4885 eval_quote,
4886 eval_define,
4887 eval_progn,
4888 eval_lambda,
4889 eval_if,
4890 eval_let,
4891 eval_and,
4892 eval_or,
4893 eval_match,
4894 eval_receive,
4895 eval_receive_timeout,
4896 eval_callcc,
4897 eval_atomic,
4898 eval_selfevaluating, // macro
4899 eval_selfevaluating, // cont
4900 eval_selfevaluating, // closure
4901 eval_cond,
4902 eval_app_cont,
4903 eval_var,
4904 eval_setq,
4905 eval_move_to_flash,
4906 eval_loop,
4907 eval_trap
4908 };
4909
4910
4911/*********************************************************/
4912/* Evaluator step function */
4913
4914static void evaluation_step(void){
4915 eval_context_t *ctx = ctx_running;
4916#ifdef VISUALIZE_HEAP
4917 heap_vis_gen_image();
4918#endif
4919
4920 if (ctx->app_cont) {
4921 lbm_value k;
4922 lbm_pop(&ctx->K, &k);
4923 ctx->app_cont = false0;
4924
4925 lbm_uint decoded_k = DEC_CONTINUATION(k)(((k) & ~0xF8000001u) >> 2);
4926
4927 if (decoded_k < NUM_CONTINUATIONS49) {
4928 continuations[decoded_k](ctx);
4929 } else {
4930 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4931 }
4932 return;
4933 }
4934
4935 if (lbm_is_symbol(ctx->curr_exp)) {
4936 eval_symbol(ctx);
4937 return;
4938 }
4939 if (lbm_is_cons(ctx->curr_exp)) {
4940 lbm_cons_t *cell = lbm_ref_cell(ctx->curr_exp);
4941 lbm_value h = cell->car;
4942 if (lbm_is_symbol(h) && ((h & ENC_SPECIAL_FORMS_MASK0xFFFFF000) == ENC_SPECIAL_FORMS_BIT0x00001000)) {
4943 lbm_uint eval_index = lbm_dec_sym(h) & SPECIAL_FORMS_INDEX_MASK0x000000FF;
4944 evaluators[eval_index](ctx);
4945 return;
4946 }
4947 /*
4948 * At this point head can be anything. It should evaluate
4949 * into a form that can be applied (closure, symbol, ...) though.
4950 */
4951 lbm_value *reserved = stack_reserve(ctx, 3);
4952 reserved[0] = ctx->curr_env;
4953 reserved[1] = cell->cdr;
4954 reserved[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
4955 ctx->curr_exp = h; // evaluate the function
4956 return;
4957 }
4958
4959 eval_selfevaluating(ctx);
4960 return;
4961}
4962
4963void lbm_pause_eval(void ) {
4964 eval_cps_next_state_arg = 0;
4965 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4966 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4967}
4968
4969void lbm_pause_eval_with_gc(uint32_t num_free) {
4970 eval_cps_next_state_arg = num_free;
4971 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4972 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4973}
4974
4975void lbm_continue_eval(void) {
4976 eval_cps_next_state = EVAL_CPS_STATE_RUNNING2;
4977 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4978}
4979
4980void lbm_kill_eval(void) {
4981 eval_cps_next_state = EVAL_CPS_STATE_KILL4;
4982 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4983}
4984
4985uint32_t lbm_get_eval_state(void) {
4986 return eval_cps_run_state;
4987}
4988
4989// Will wake up thread that is sleeping as well.
4990// Not sure this is good behavior.
4991static void handle_event_unblock_ctx(lbm_cid cid, lbm_value v) {
4992 eval_context_t *found = NULL((void*)0);
4993 mutex_lock(&qmutex);
4994
4995 found = lookup_ctx_nm(&blocked, cid);
4996 if (found) {
4997 drop_ctx_nm(&blocked,found);
4998 if (lbm_is_error(v)) {
4999 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
5000 found->app_cont = true1;
5001 }
5002 found->r = v;
5003 enqueue_ctx_nm(&queue,found);
5004 }
5005 mutex_unlock(&qmutex);
5006}
5007
5008static void handle_event_define(lbm_value key, lbm_value val) {
5009 lbm_uint dec_key = lbm_dec_sym(key);
5010 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
5011 lbm_value *global_env = lbm_get_global_env();
5012 lbm_uint orig_env = global_env[ix_key];
5013 lbm_value new_env;
5014 // A key is a symbol and should not need to be remembered.
5015 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
5016
5017 global_env[ix_key] = new_env;
5018}
5019
5020static lbm_value get_event_value(lbm_event_t *e) {
5021 lbm_value v;
5022 if (e->buf_len > 0) {
5023 lbm_flat_value_t fv;
5024 fv.buf = (uint8_t*)e->buf_ptr;
5025 fv.buf_size = e->buf_len;
5026 fv.buf_pos = 0;
5027 if (!lbm_unflatten_value(&fv, &v)) {
5028 lbm_set_flags(LBM_FLAG_HANDLER_EVENT_DELIVERY_FAILED(1 << 1));
5029 v = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
5030 }
5031 // Free the flat value buffer. GC is unaware of its existence.
5032 lbm_free(fv.buf);
5033 } else {
5034 v = (lbm_value)e->buf_ptr;
5035 }
5036 return v;
5037}
5038
5039static void process_events(void) {
5040
5041 if (!lbm_events) return;
5042 lbm_event_t e;
5043
5044 while (lbm_event_pop(&e)) {
5045
5046 lbm_value event_val = get_event_value(&e);
5047 switch(e.type) {
5048 case LBM_EVENT_UNBLOCK_CTX:
5049 handle_event_unblock_ctx((lbm_cid)e.parameter, event_val);
5050 break;
5051 case LBM_EVENT_DEFINE:
5052 handle_event_define((lbm_value)e.parameter, event_val);
5053 break;
5054 case LBM_EVENT_FOR_HANDLER:
5055 if (lbm_event_handler_pid >= 0) {
5056 lbm_find_receiver_and_send(lbm_event_handler_pid, event_val);
5057 }
5058 break;
5059 }
5060 }
5061}
5062
5063/* eval_cps_run can be paused
5064 I think it would be better use a mailbox for
5065 communication between other threads and the run_eval
5066 but for now a set of variables will be used. */
5067void lbm_run_eval(void){
5068
5069 if (setjmp(critical_error_jmp_buf)_setjmp (critical_error_jmp_buf) > 0) {
5070 printf_callback("GC stack overflow!\n");
5071 critical_error_callback();
5072 // terminate evaluation thread.
5073 return;
5074 }
5075
5076 setjmp(error_jmp_buf)_setjmp (error_jmp_buf);
5077
5078 while (eval_running) {
5079 if (eval_cps_state_changed || eval_cps_run_state == EVAL_CPS_STATE_PAUSED1) {
5080 eval_cps_state_changed = false0;
5081 switch (eval_cps_next_state) {
5082 case EVAL_CPS_STATE_PAUSED1:
5083 if (eval_cps_run_state != EVAL_CPS_STATE_PAUSED1) {
5084 if (lbm_heap_num_free() < eval_cps_next_state_arg) {
5085 gc();
5086 }
5087 eval_cps_next_state_arg = 0;
5088 }
5089 eval_cps_run_state = EVAL_CPS_STATE_PAUSED1;
5090 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5091 continue; /* jump back to start of eval_running loop */
5092 case EVAL_CPS_STATE_KILL4:
5093 eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
5094 eval_running = false0;
5095 continue;
5096 default: // running state
5097 eval_cps_run_state = eval_cps_next_state;
5098 break;
5099 }
5100 }
5101 while (true1) {
5102 if (eval_steps_quota && ctx_running) {
5103 eval_steps_quota--;
5104 evaluation_step();
5105 } else {
5106 if (eval_cps_state_changed) break;
5107 eval_steps_quota = eval_steps_refill;
5108 if (is_atomic) {
5109 if (!ctx_running) {
5110 lbm_set_flags(LBM_FLAG_ATOMIC_MALFUNCTION(1 << 0));
5111 is_atomic = 0;
5112 }
5113 } else {
5114 if (gc_requested) {
5115 gc();
5116 }
5117 process_events();
5118 mutex_lock(&qmutex);
5119 if (ctx_running) {
5120 enqueue_ctx_nm(&queue, ctx_running);
5121 ctx_running = NULL((void*)0);
5122 }
5123 wake_up_ctxs_nm();
5124 ctx_running = dequeue_ctx_nm(&queue);
5125 mutex_unlock(&qmutex);
5126 if (!ctx_running) {
5127 lbm_system_sleeping = true1;
5128 //Fixed sleep interval to poll events regularly.
5129 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5130 lbm_system_sleeping = false0;
5131 }
5132 }
5133 }
5134 }
5135 }
5136}
5137
5138lbm_cid lbm_eval_program(lbm_value lisp) {
5139 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), 256, NULL((void*)0));
5140}
5141
5142lbm_cid lbm_eval_program_ext(lbm_value lisp, unsigned int stack_size) {
5143 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), stack_size, NULL((void*)0));
5144}
5145
5146int lbm_eval_init() {
5147 if (!qmutex_initialized) {
5148 mutex_init(&qmutex);
5149 qmutex_initialized = true1;
5150 }
5151 if (!lbm_events_mutex_initialized) {
5152 mutex_init(&lbm_events_mutex);
5153 lbm_events_mutex_initialized = true1;
5154 }
5155 if (!blocking_extension_mutex_initialized) {
5156 mutex_init(&blocking_extension_mutex);
5157 blocking_extension_mutex_initialized = true1;
5158 }
5159
5160 mutex_lock(&qmutex);
5161 mutex_lock(&lbm_events_mutex);
5162
5163 blocked.first = NULL((void*)0);
5164 blocked.last = NULL((void*)0);
5165 queue.first = NULL((void*)0);
5166 queue.last = NULL((void*)0);
5167 ctx_running = NULL((void*)0);
5168
5169 eval_cps_run_state = EVAL_CPS_STATE_RUNNING2;
5170
5171 mutex_unlock(&lbm_events_mutex);
5172 mutex_unlock(&qmutex);
5173
5174 if (!lbm_init_env()) return 0;
5175 eval_running = true1;
5176 return 1;
5177}
5178
5179bool_Bool lbm_eval_init_events(unsigned int num_events) {
5180
5181 mutex_lock(&lbm_events_mutex);
5182 lbm_events = (lbm_event_t*)lbm_malloc(num_events * sizeof(lbm_event_t));
5183 bool_Bool r = false0;
5184 if (lbm_events) {
5185 lbm_events_max = num_events;
5186 lbm_events_head = 0;
5187 lbm_events_tail = 0;
5188 lbm_events_full = false0;
5189 lbm_event_handler_pid = -1;
5190 r = true1;
5191 }
5192 mutex_unlock(&lbm_events_mutex);
5193 return r;
5194}
+
+
←

./include/heap.h

+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1
2/*
3 Copyright 2018, 2024 Joel Svensson svenssonjoel@yahoo.se
4
5 This program is free software: you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation, either version 3 of the License, or
8 (at your option) any later version.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
14
15 You should have received a copy of the GNU General Public License
16 along with this program. If not, see <http://www.gnu.org/licenses/>.
17*/
18/** \file heap.h */
19
20#ifndef HEAP_H_
21#define HEAP_H_
22
23#include <string.h>
24#include <stdarg.h>
25
26#include "lbm_types.h"
27#include "symrepr.h"
28#include "stack.h"
29#include "lbm_memory.h"
30#include "lbm_defines.h"
31#include "lbm_channel.h"
32
33#ifdef __cplusplus
34extern "C" {
35#endif
36
37/*
38Planning for a more space efficient heap representation.
39TODO: Need to find a good reference to read up on this.
40 - List based heap
41 - Easy to implement and somewhat efficient
42
430000 0000 Size Free bits
44003F FFFF 4MB 10
45007F FFFF 8MB 9
4600FF FFFF 16MB 8
4701FF FFFF 32MB 7
4803FF FFFF 64MB 6 * Kind of heap size I am looking for
4907FF FFFF 128MB 5
500FFF FFFF 256MB 4
511FFF FFFF 512MB 3
52
53
54--- May 9 2021 ---
55Actually now I am much more interested in way smaller memories ;)
56
570000 0000 Size Free bits
580000 0FFF 4KB 20 |
590000 1FFF 8KB 19 |
600000 3FFF 16KB 18 |
610000 7FFF 32KB 17 |
620000 FFFF 64KB 16 |
630001 FFFF 128KB 15 |
640003 FFFF 256KB 14 | - This range is very interesting.
650007 FFFF 512KB 13
66000F FFFF 1MB 12
67001F FFFF 2MB 11
68003F FFFF 4MB 10
69007F FFFF 8MB 9
7000FF FFFF 16MB 8
7101FF FFFF 32MB 7
7203FF FFFF 64MB 6
7307FF FFFF 128MB 5
740FFF FFFF 256MB 4
751FFF FFFF 512MB 3
76
77Those are the kind of platforms that are fun... so a bunch of
78wasted bits in heap pointers if we run on small MCUs.
79
80-----------------
81
82it is also the case that not all addresses will be used if all "cells" are
83of the same size, 8 bytes...
84
85value 0: 0000 0000
86value 1: 0000 0008
87value 3: 0000 0010
88value 4: 0000 0018
89
90Means bits 0,1,2 will always be empty in a valid address.
91
92Cons cells also need to be have room for 2 pointers. So each ted cell from
93memory should be 8bytes.
94
95Things that needs to be represented within these bits:
96
97 - GC MARK one per cell
98 - TYPE: type of CAR and type of cons
99
100Types I would want:
101 - Full 32bit integer. Does not leave room for identification of type
102 - Float values. Same problem
103
104
105Free bits in pointers 64MB heap:
10631 30 29 28 27 26 2 1 0
1070 0 0 0 0 0 XX XXXX XXXX XXXX XXXX XXXX X 0 0 0
108
109
110Information needed for each cell:
111 Meaning | bits total | bits per car | bits per cdr
112 GC mark | 2 | 1 | 1 - only one of them will be used (the other is wasted)
113 Type | 2x | x | x
114 Ptr/!ptr | 2 | 1 | 1
115
116
117Types (unboxed):
118 - Symbols
119 - 28bit integer ( will need signed shift right functionality )
120 - 28bit unsigned integer
121 - Character
122
123If four types is all that should be possible (unboxed). then 2 bits are needed to differentiate.
1242 + 1 + 1 = 4 => 28bits for data.
125
126bit 0: ptr/!ptr
127bit 1: gc
128bit 2-3: type (if not ptr)
129bit 3 - 24 ptr (if ptr)
130bit 4 - 31 value (if value)
131
132An unboxed value can occupy a car or cdr field in a cons cell.
133
134types (boxed) extra information in pointer to cell can contain information
135 - 32 bit integer
136 - 32 bit unsigned integer
137 - 32 bit float
138
139boxed representation:
140 [ptr| cdr]
141 |
142 [Value | Aux + GC_MARK]
143
144Kinds of pointers:
145 - Pointer to cons cell.
146 - Pointer to unboxed value (fixnums not in a list, I hope this is so rare that it can be removed )
147 - integer
148 - unsigned integer
149 - symbol
150 - float
151 - Pointer to boxed value.
152 - 32 bit integer
153 - 32 bit unsigned integer
154 - 32 bit float
155 - (Maybe something else ? Vectors/strings allocated in memory not occupied by heap?)
156 - vector of int
157 - vector of uint
158 - vector of float
159 - vector of double
160 - String
161
16213 pointer"types" -> needs 4 bits
163for 64MB heap there are 6 free bits. So with this scheme going to 128MB or 256MB heap
164is also possible
165
166 a pointer to some off heap vector/string could be represented by
167
168 [ptr | cdr]
169 |
170 [full pointer | Aux + GC_MARK]
171 |
172 [VECTOR]
173
174Aux bits could be used for storing vector size. Up to 30bits should be available there
175>> This is problematic. Now the information that something is a vector is split up
176>> between 2 cons cells. This means GC needs both of these intact to be able to make
177>> proper decision.
178>> Will try to resolve this by adding some special symbols. But these must be symbols
179>> that cannot occur normally in programs. Then an array could be:
180
181 [Full pointer | ARRAY_SYM + GC_MARK]
182 |
183 [VECTOR]
184
185>> Boxed values same treatment as above.
186>> TODO: Could this be simpler?
187
188[ VALUE | TYPE_SYM + GC_MARK]
189
190
1910000 00XX XXXX XXXX XXXX XXXX XXXX X000 : 0x03FF FFF8
1921111 AA00 0000 0000 0000 0000 0000 0000 : 0xFC00 0000 (AA bits left unused for now, future heap growth?)
193 */
194
195typedef enum {
196 LBM_FLASH_WRITE_OK,
197 LBM_FLASH_FULL,
198 LBM_FLASH_WRITE_ERROR
199} lbm_flash_status;
200
201/** Struct representing a heap cons-cell.
202 *
203 */
204typedef struct {
205 lbm_value car;
206 lbm_value cdr;
207} lbm_cons_t;
208
209/**
210 * Heap state
211 */
212typedef struct {
213 lbm_cons_t *heap;
214 lbm_value freelist; // list of free cons cells.
215 lbm_stack_t gc_stack;
216
217 lbm_uint heap_size; // In number of cells.
218 lbm_uint heap_bytes; // In bytes.
219
220 lbm_uint num_alloc; // Number of cells allocated.
221 lbm_uint num_alloc_arrays; // Number of arrays allocated.
222
223 lbm_uint gc_num; // Number of times gc has been performed.
224 lbm_uint gc_marked; // Number of cells marked by mark phase.
225 lbm_uint gc_recovered; // Number of cells recovered by sweep phase.
226 lbm_uint gc_recovered_arrays;// Number of arrays recovered by sweep.
227 lbm_uint gc_least_free; // The smallest length of the freelist.
228 lbm_uint gc_last_free; // Number of elements on the freelist
229 // after most recent GC.
230} lbm_heap_state_t;
231
232extern lbm_heap_state_t lbm_heap_state;
233
234typedef bool_Bool (*const_heap_write_fun)(lbm_uint ix, lbm_uint w);
235
236typedef struct {
237 lbm_uint *heap;
238 lbm_uint next; // next free index.
239 lbm_uint size; // in lbm_uint words. (cons-cells = words / 2)
240} lbm_const_heap_t;
241
242/**
243 * The header portion of an array stored in array and symbol memory.
244 * An array is always a byte array. use the array-extensions for
245 * storing and reading larger values from arrays.
246 */
247typedef struct {
248 lbm_uint size; /// Number of elements
249 lbm_uint *data; /// pointer to lbm_memory array or C array.
250} lbm_array_header_t;
251
252typedef struct {
253 lbm_uint size;
254 lbm_uint *data;
255 uint32_t index; // Limits arrays to max 2^32-1 elements.
256} lbm_array_header_extended_t;
257
258/** Lock GC mutex
259 * Locks a mutex during GC marking when using the pointer reversal algorithm.
260 * Does nothing when using stack based GC mark.
261 */
262void lbm_gc_lock(void);
263/* Unlock GC mutex
264 */
265void lbm_gc_unlock(void);
266
267/** Initialize heap storage.
268 * \param addr Pointer to an array of lbm_cons_t elements. This array must at least be aligned 4.
269 * \param num_cells Number of lbm_cons_t elements in the array.
270 * \param gc_stack_size Size of the gc_stack in number of words.
271 * \return 1 on success or 0 for failure.
272 */
273int lbm_heap_init(lbm_cons_t *addr, lbm_uint num_cells,
274 lbm_uint gc_stack_size);
275
276/** Add GC time statistics to heap_stats
277 *
278 * \param dur Duration as reported by the timestamp callback.
279 */
280void lbm_heap_new_gc_time(lbm_uint dur);
281/** Add a new free_list length to the heap_stats.
282 * Calculates a new freelist length and updates
283 * the GC statistics.
284 */
285void lbm_heap_new_freelist_length(void);
286/** Check how many lbm_cons_t cells are on the free-list
287 *
288 * \return Number of free lbm_cons_t cells.
289 */
290lbm_uint lbm_heap_num_free(void);
291/** Check how many lbm_cons_t cells are allocated.
292 *
293 * \return Number of lbm_cons_t cells that are currently allocated.
294 */
295lbm_uint lbm_heap_num_allocated(void);
296/** Size of the heap in number of lbm_cons_t cells.
297 *
298 * \return Size of the heap in number of lbm_cons_t cells.
299 */
300lbm_uint lbm_heap_size(void);
301/** Size of the heap in bytes.
302 *
303 * \return Size of heap in bytes.
304 */
305lbm_uint lbm_heap_size_bytes(void);
306/** Allocate an lbm_cons_t cell from the heap.
307 *
308 * \param type A type that can be encoded onto the cell (most often LBM_PTR_TYPE_CONS).
309 * \param car Value to write into car position of allocated cell.
310 * \param cdr Value to write into cdr position of allocated cell.
311 * \return An lbm_value referring to a cons_cell or enc_sym(SYM_MERROR) in case the heap is full.
312 */
313lbm_value lbm_heap_allocate_cell(lbm_type type, lbm_value car, lbm_value cdr);
314/** Allocate a list of n heap-cells.
315 * \param n The number of heap-cells to allocate.
316 * \return A list of heap-cells of Memory error if unable to allocate.
317 */
318lbm_value lbm_heap_allocate_list(lbm_uint n);
319/** Allocate a list of n heap-cells and initialize the values.
320 * \pram ls The result list is passed through this ptr.
321 * \param n The length of list to allocate.
322 * \param valist The values in a va_list to initialize the list with.
323 * \return True of False depending on success of allocation.
324 */
325lbm_value lbm_heap_allocate_list_init_va(unsigned int n, va_list valist);
326/** Allocate a list of n heap-cells and initialize the values.
327 * \param n The length of list to allocate.
328 * \param ... The values to initialize the list with.
329 * \return allocated list or error symbol.
330 */
331lbm_value lbm_heap_allocate_list_init(unsigned int n, ...);
332/** Decode an lbm_value representing a string into a C string
333 *
334 * \param val Value
335 * \return allocated list or error symbol
336 */
337char *lbm_dec_str(lbm_value val);
338/** Decode an lbm_value representing a char channel into an lbm_char_channel_t pointer.
339 *
340 * \param val Value
341 * \return A pointer to an lbm_char_channel_t or NULL if the value does not encode a channel.
342 */
343lbm_char_channel_t *lbm_dec_channel(lbm_value val);
344/** Decode an lbm_value representing a custom type into a lbm_uint value.
345 *
346 * \param val Value.
347 * \return The custom type payload.
348 */
349lbm_uint lbm_dec_custom(lbm_value val);
350/** Decode a numerical value as if it is char
351 *
352 * \param val Value to decode
353 * \return The value encoded in val casted to a char. Returns 0 if val does not encode a number.
354 */
355uint8_t lbm_dec_as_char(lbm_value a);
356/** Decode a numerical value as if it is unsigned
357 *
358 * \param val Value to decode
359 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
360 */
361uint32_t lbm_dec_as_u32(lbm_value val);
362/** Decode a numerical value as a signed integer.
363 *
364 * \param val Value to decode
365 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
366 */
367int32_t lbm_dec_as_i32(lbm_value val);
368/** Decode a numerical value as a float.
369 *
370 * \param val Value to decode.
371 * \return The value encoded in val casted to a float. Returns 0 if val does not encode a number.
372 */
373float lbm_dec_as_float(lbm_value val);
374/** Decode a numerical value as if it is a 64bit unsigned
375 *
376 * \param val Value to decode
377 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
378 */
379uint64_t lbm_dec_as_u64(lbm_value val);
380/** Decode a numerical value as a 64bit signed integer.
381 *
382 * \param val Value to decode
383 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
384 */
385int64_t lbm_dec_as_i64(lbm_value val);
386/** Decode a numerical value as a float.
387 *
388 * \param val Value to decode.
389 * \return The value encoded in val casted to a float. Returns 0 if val does not encode a number.
390 */
391double lbm_dec_as_double(lbm_value val);
392
393/** Decode a numerical value into the architecture defined unsigned integer type.
394 *
395 * \param val Value to decode
396 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
397 */
398lbm_uint lbm_dec_as_uint(lbm_value val);
399
400/** Decode a numerical value into the architecture defined signed integer type.
401 *
402 * \param val Value to decode
403 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
404 */
405lbm_int lbm_dec_as_int(lbm_value val);
406
407lbm_uint lbm_dec_raw(lbm_value v);
408/** Allocates an lbm_cons_t cell from the heap and populates it.
409 *
410 * \param car The value to put in the car field of the allocated lbm_cons_t.
411 * \param cdr The value to put in the cdr field of the allocated lbm_cons_t.
412 * \return A value referencing the lbm_cons_t or enc_sym(SYM_MERROR) if heap is full.
413 */
414lbm_value lbm_cons(lbm_value car, lbm_value cdr);
415
416/** Accesses the car field of an lbm_cons_t.
417 *
418 * \param cons Value
419 * \return The car field of the lbm_cons_t if cons is a reference to a heap cell.
420 * If cons is nil, the return value is nil. If the value
421 * is not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
422 */
423lbm_value lbm_car(lbm_value cons);
424/** Accesses the car field the car field of an lbm_cons_t.
425 *
426 * \param cons Value
427 * \return The car of car field or nil.
428 */
429lbm_value lbm_caar(lbm_value c);
430/** Accesses the car of the cdr of an cons cell
431 *
432 * \param c Value
433 * \return the cdr field or type error.
434 */
435lbm_value lbm_cadr(lbm_value c);
436/** Accesses the cdr field of an lbm_cons_t.
437 *
438 * \param cons Value
439 * \return The cdr field of the lbm_cons_t if cons is a reference to a heap cell.
440 * If cons is nil, the return value is nil. If the value
441 * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
442 */
443lbm_value lbm_cdr(lbm_value cons);
444/** Accesses the cdr of an cdr field of an lbm_cons_t.
445 *
446 * \param cons Value
447 * \return The cdr of the cdr field of the lbm_cons_t if cons is a reference to a heap cell.
448 * If cons is nil, the return value is nil. If the value
449 * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
450 */
451lbm_value lbm_cddr(lbm_value c);
452/** Update the value stored in the car field of a heap cell.
453 *
454 * \param c Value referring to a heap cell.
455 * \param v Value to replace the car field with.
456 * \return 1 on success and 0 if the c value does not refer to a heap cell.
457 */
458int lbm_set_car(lbm_value c, lbm_value v);
459/** Update the value stored in the cdr field of a heap cell.
460 *
461 * \param c Value referring to a heap cell.
462 * \param v Value to replace the cdr field with.
463 * \return 1 on success and 0 if the c value does not refer to a heap cell.
464 */
465int lbm_set_cdr(lbm_value c, lbm_value v);
466/** Update the value stored in the car and cdr fields of a heap cell.
467 *
468 * \param c Value referring to a heap cell.
469 * \param car_val Value to replace the car field with.
470 * \param cdr_val Value to replace the cdr field with.
471 * \return 1 on success and 0 if the c value does not refer to a heap cell.
472 */
473int lbm_set_car_and_cdr(lbm_value c, lbm_value car_val, lbm_value cdr_val);
474// List functions
475/** Calculate the length of a proper list
476 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
477 * may lead to the function not terminating.
478 *
479 * \param c A list
480 * \return The length of the list. Unless the value is a cyclic structure on the heap, this function will terminate.
481 */
482lbm_uint lbm_list_length(lbm_value c);
483
484/** Calculate the length of a proper list and evaluate a predicate for each element.
485 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
486 * may lead to the function not terminating.
487 *
488 * \param c A list
489 * \param pres Boolean result of predicate, false if predicate is false for any of the elements in the list, otherwise true.
490 * \param pred Predicate to evaluate for each element of the list.
491 */
492unsigned int lbm_list_length_pred(lbm_value c, bool_Bool *pres, bool_Bool (*pred)(lbm_value));
493/** Reverse a proper list
494 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
495 * may lead to the function not terminating.
496 *
497 * \param list A list
498 * \return The list reversed or enc_sym(SYM_MERROR) if heap is full.
499 */
500lbm_value lbm_list_reverse(lbm_value list);
501/** Reverse a proper list destroying the original.
502 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
503 * may lead to the function not terminating.
504 *
505 * \param list A list
506 * \return The list reversed
507 */
508lbm_value lbm_list_destructive_reverse(lbm_value list);
509/** Copy a list
510 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
511 * may lead to the function not terminating.
512 *
513 * \param m Number of elements to copy or -1 for all. If 1, m will be updated with the length of the list
514 * \param list A list.
515 * \return Reversed list or enc_sym(SYM_MERROR) if heap is full.
516 */
517lbm_value lbm_list_copy(int *m, lbm_value list);
518
519/** A destructive append of two lists
520 *
521 * \param list1 A list
522 * \param list2 A list
523 * \return list1 with list2 appended at the end.
524 */
525lbm_value lbm_list_append(lbm_value list1, lbm_value list2);
526
527/** Drop values from the head of a list.
528 * \param n Number of values to drop.
529 * \param ls List to drop values from.
530 * \return The list with the n first elements removed.
531 */
532lbm_value lbm_list_drop(unsigned int n, lbm_value ls);
533/** Index into a list.
534 * \param l List to index into.
535 * \param n Position to read out of the list.
536 * \return Value at position n of l or nil if out of bounds.
537 */
538lbm_value lbm_index_list(lbm_value l, int32_t n);
539
540// State and statistics
541/** Get a copy of the heap statistics structure.
542 *
543 * \param A pointer to an lbm_heap_state_t to populate
544 * with the current statistics.
545 */
546void lbm_get_heap_state(lbm_heap_state_t *);
547/** Get the maximum stack level of the GC stack
548 * \return maximum value the gc stack sp reached so far.
549 */
550lbm_uint lbm_get_gc_stack_max(void);
551/** Get the size of the GC stack.
552 * \return the size of the gc stack.
553 */
554lbm_uint lbm_get_gc_stack_size(void);
555// Garbage collection
556/** Increment the counter that is counting the number of times GC ran
557 *
558 */
559void lbm_gc_state_inc(void);
560/** Set the freelist to NIL. Means that no memory will be available
561 * until after a garbage collection.
562 */
563void lbm_nil_freelist(void);
564/** Mark all heap cells reachable from an environment.
565 * \param environment.
566 */
567void lbm_gc_mark_env(lbm_value);
568/** Mark heap cells reachable from the lbm_value v.
569 * \param root
570 */
571void lbm_gc_mark_phase(lbm_value root);
572/** Performs lbm_gc_mark_phase on all the values of an array.
573 * This function is similar to lbm_gc_mark_roots but performs
574 * extra checks to not traverse into non-standard values.
575 * TODO: Check if this function is really needed.
576 * \param data Array of roots to traverse from.
577 * \param n Number of elements in roots-array.
578 */
579void lbm_gc_mark_aux(lbm_uint *data, lbm_uint n);
580/** Performs lbm_gc_mark_phase on all the values in the roots array.
581 * \param roots pointer to array of roots.
582 * \param num_roots size of array of roots.
583 */
584void lbm_gc_mark_roots(lbm_uint *roots, lbm_uint num_roots);
585/** Sweep up all non marked heap cells and place them on the free list.
586 *
587 * \return 1
588 */
589int lbm_gc_sweep_phase(void);
590
591// Array functionality
592/** Allocate an bytearray in symbols and arrays memory (lispbm_memory.h)
593 * and create a heap cell that refers to this bytearray.
594 * \param res The resulting lbm_value is returned through this argument.
595 * \param size Array size in number of 32 bit words.
596 * \return 1 for success of 0 for failure.
597 */
598int lbm_heap_allocate_array(lbm_value *res, lbm_uint size);
599/** Allocate an array in symbols and arrays memory (lispbm_memory.h)
600 * and create a heap cell that refers to this array.
601 * \param res The resulting lbm_value is returned through this argument.
602 * \param size Array size in number of 32 bit words.
603 * \return 1 for success of 0 for failure.
604 */
605int lbm_heap_allocate_lisp_array(lbm_value *res, lbm_uint size);
606/** Convert a C array into an lbm array. If the C array is allocated in LBM MEMORY
607 * the lifetime of the array will be managed by GC.
608 * \param res lbm_value result pointer for storage of the result array.
609 * \param data C array.
610 * \param type The type tag to assign to the resulting LBM array.
611 * \param num_elt Number of elements in the array.
612 * \return 1 for success and 0 for failure.
613 */
614int lbm_lift_array(lbm_value *value, char *data, lbm_uint num_elt);
615/** Get the size of an array value.
616 * \param arr lbm_value array to get size of.
617 * \return -1 for failure or length of array.
618 */
619lbm_int lbm_heap_array_get_size(lbm_value arr);
620/** Get a pointer to the data of an array for read only purposes.
621 * \param arr lbm_value array to get pointer from.
622 * \return NULL or valid pointer.
623 */
624const uint8_t *lbm_heap_array_get_data_ro(lbm_value arr);
625/** Get a pointer to the data of an array for read/write purposes.
626 * \param arr lbm_value array to get pointer from.
627 * \return NULL or valid pointer.
628 */
629uint8_t *lbm_heap_array_get_data_rw(lbm_value arr);
630/** Explicitly free an array.
631 * This function needs to be used with care and knowledge.
632 * \param arr Array value.
633 */
634int lbm_heap_explicit_free_array(lbm_value arr);
635/** Query the size in bytes of an lbm_type.
636 * \param t Type
637 * \return Size in bytes of type or 0 if the type represents a composite.
638 */
639lbm_uint lbm_size_of(lbm_type t);
640
641int lbm_const_heap_init(const_heap_write_fun w_fun,
642 lbm_const_heap_t *heap,
643 lbm_uint *addr,
644 lbm_uint num_words);
645
646lbm_flash_status lbm_allocate_const_cell(lbm_value *res);
647lbm_flash_status lbm_write_const_raw(lbm_uint *data, lbm_uint n, lbm_uint *res);
648lbm_flash_status lbm_allocate_const_raw(lbm_uint nwords, lbm_uint *res);
649lbm_flash_status write_const_cdr(lbm_value cell, lbm_value val);
650lbm_flash_status write_const_car(lbm_value cell, lbm_value val);
651lbm_flash_status lbm_const_write(lbm_uint *tgt, lbm_uint val);
652lbm_uint lbm_flash_memory_usage(void);
653
654/** Query the type information of a value.
655 *
656 * \param x Value to check the type of.
657 * \return The type information.
658 */
659static inline lbm_type lbm_type_of(lbm_value x) {
660 return (x & LBM_PTR_BIT0x00000001u) ? (x & LBM_PTR_TYPE_MASK0xFC000000u) : (x & LBM_VAL_TYPE_MASK0x0000000Cu);
661}
662
663// type-of check that is safe in functional code
664static inline lbm_type lbm_type_of_functional(lbm_value x) {
665 return (x & LBM_PTR_BIT0x00000001u) ?
666 (x & (LBM_PTR_TO_CONSTANT_MASK~0x04000000u & LBM_PTR_TYPE_MASK0xFC000000u)) :
667 (x & LBM_VAL_TYPE_MASK0x0000000Cu);
668}
669
670static inline lbm_value lbm_enc_cons_ptr(lbm_uint x) {
671 return ((x << LBM_ADDRESS_SHIFT2) | LBM_TYPE_CONS0x10000000u | LBM_PTR_BIT0x00000001u);
672}
673
674static inline lbm_uint lbm_dec_ptr(lbm_value p) {
675 return ((LBM_PTR_VAL_MASK0x03FFFFFCu & p) >> LBM_ADDRESS_SHIFT2);
676}
677
678extern lbm_cons_t *lbm_heaps[2];
679
680static inline lbm_uint lbm_dec_cons_cell_ptr(lbm_value p) {
681 lbm_uint h = (p & LBM_PTR_TO_CONSTANT_BIT0x04000000u) >> LBM_PTR_TO_CONSTANT_SHIFT26;
682 return lbm_dec_ptr(p) >> h;
683}
684
685static inline lbm_cons_t *lbm_dec_heap(lbm_value p) {
686 lbm_uint h = (p & LBM_PTR_TO_CONSTANT_BIT0x04000000u) >> LBM_PTR_TO_CONSTANT_SHIFT26;
687 return lbm_heaps[h];
688}
689
690static inline lbm_value lbm_set_ptr_type(lbm_value p, lbm_type t) {
691 return ((LBM_PTR_VAL_MASK0x03FFFFFCu & p) | t | LBM_PTR_BIT0x00000001u);
692}
693
694static inline lbm_value lbm_enc_sym(lbm_uint s) {
695 return (s << LBM_VAL_SHIFT4) | LBM_TYPE_SYMBOL0x00000000u;
696}
697
698static inline lbm_value lbm_enc_i(lbm_int x) {
699 return ((lbm_uint)x << LBM_VAL_SHIFT4) | LBM_TYPE_I0x00000008u;
700}
701
702static inline lbm_value lbm_enc_u(lbm_uint x) {
703 return (x << LBM_VAL_SHIFT4) | LBM_TYPE_U0x0000000Cu;
704}
705
706/** Encode 32 bit integer into an lbm_value.
707 * \param x Value to encode.
708 * \return result encoded value.
709 */
710extern lbm_value lbm_enc_i32(int32_t x);
711
712/** Encode 32 bit unsigned integer into an lbm_value.
713 * \param x Value to encode.
714 * \return result encoded value.
715 */
716extern lbm_value lbm_enc_u32(uint32_t x);
717
718/** Encode a float into an lbm_value.
719 * \param x float value to encode.
720 * \return result encoded value.
721 */
722extern lbm_value lbm_enc_float(float x);
723
724/** Encode a 64 bit integer into an lbm_value.
725 * \param x 64 bit integer to encode.
726 * \return result encoded value.
727 */
728extern lbm_value lbm_enc_i64(int64_t x);
729
730/** Encode a 64 bit unsigned integer into an lbm_value.
731 * \param x 64 bit unsigned integer to encode.
732 * \return result encoded value.
733 */
734extern lbm_value lbm_enc_u64(uint64_t x);
735
736/** Encode a double into an lbm_value.
737 * \param x double to encode.
738 * \return result encoded value.
739 */
740extern lbm_value lbm_enc_double(double x);
741
742static inline lbm_value lbm_enc_char(uint8_t x) {
743 return ((lbm_uint)x << LBM_VAL_SHIFT4) | LBM_TYPE_CHAR0x00000004u;
744}
745
746static inline lbm_int lbm_dec_i(lbm_value x) {
747 return (lbm_int)x >> LBM_VAL_SHIFT4;
748}
749
750static inline lbm_uint lbm_dec_u(lbm_value x) {
751 return x >> LBM_VAL_SHIFT4;
752}
753
754static inline uint8_t lbm_dec_char(lbm_value x) {
755 return (uint8_t)(x >> LBM_VAL_SHIFT4);
756}
757
758static inline lbm_uint lbm_dec_sym(lbm_value x) {
759 return x >> LBM_VAL_SHIFT4;
760}
761
762/** Decode an lbm_value representing a float.
763 * \param x Value to decode.
764 * \return decoded float.
765 */
766extern float lbm_dec_float(lbm_value x);
767
768/** Decode an lbm_value representing a double.
769 * \param x Value to decode.
770 * \return decoded float.
771 */
772extern double lbm_dec_double(lbm_value x);
773
774
775static inline uint32_t lbm_dec_u32(lbm_value x) {
776#ifndef LBM64
777 return (uint32_t)lbm_car(x);
778#else
779 return (uint32_t)(x >> LBM_VAL_SHIFT4);
780#endif
781}
782
783/** Decode an lbm_value representing a 64 bit unsigned integer.
784 * \param x Value to decode.
785 * \return decoded uint64_t.
786 */
787extern uint64_t lbm_dec_u64(lbm_value x);
788
789static inline int32_t lbm_dec_i32(lbm_value x) {
790#ifndef LBM64
791 return (int32_t)lbm_car(x);
792#else
793 return (int32_t)(x >> LBM_VAL_SHIFT4);
794#endif
795}
796
797/** Decode an lbm_value representing a 64 bit integer.
798 * \param x Value to decode.
799 * \return decoded int64_t.
800 */
801extern int64_t lbm_dec_i64(lbm_value x);
802
803/**
804 * Check if a value is a heap pointer
805 * \param x Value to check
806 * \return true if x is a pointer to a heap cell, false otherwise.
807 */
808static inline bool_Bool lbm_is_ptr(lbm_value x) {
809 return (x & LBM_PTR_BIT0x00000001u);
810}
811
812/**
813 * Check if a value is a Read/Writeable cons cell
814 * \param x Value to check
815 * \return true if x is a Read/Writeable cons cell, false otherwise.
816 */
817static inline bool_Bool lbm_is_cons_rw(lbm_value x) {
818 return (lbm_type_of(x) == LBM_TYPE_CONS0x10000000u);
819}
820
821/**
822 * Check if a value is a Readable cons cell
823 * \param x Value to check
824 * \return true if x is a readable cons cell, false otherwise.
825 */
826static inline bool_Bool lbm_is_cons(lbm_value x) {
827 return lbm_is_ptr(x) && ((x & LBM_CONS_TYPE_MASK0xF0000000u) == LBM_TYPE_CONS0x10000000u);
7
←
Assuming the condition is true
→
8
←
Assuming the condition is true
→
9
←
Returning the value 1, which participates in a condition later
→
828}
829
830/** Check if a value represents a number
831 * \param x Value to check.
832 * \return true is x represents a number and false otherwise.
833 */
834static inline bool_Bool lbm_is_number(lbm_value x) {
835 return
836 (x & LBM_PTR_BIT0x00000001u) ?
837 ((x & LBM_NUMBER_MASK0x08000000u) == LBM_NUMBER_MASK0x08000000u) :
838 (x & LBM_VAL_TYPE_MASK0x0000000Cu);
839}
840
841/** Check if value is an array that can be READ
842 * \param x Value to check.
843 * \return true if x represents a readable array and false otherwise.
844 */
845static inline bool_Bool lbm_is_array_r(lbm_value x) {
846 lbm_type t = lbm_type_of(x);
847 return ((t & LBM_PTR_TO_CONSTANT_MASK~0x04000000u) == LBM_TYPE_ARRAY0x80000000u);
848}
849
850static inline bool_Bool lbm_is_array_rw(lbm_value x) {
851 return( (lbm_type_of(x) == LBM_TYPE_ARRAY0x80000000u) && !(x & LBM_PTR_TO_CONSTANT_BIT0x04000000u));
852}
853
854static inline bool_Bool lbm_is_lisp_array_r(lbm_value x) {
855 lbm_type t = lbm_type_of(x);
856 return ((t & LBM_PTR_TO_CONSTANT_MASK~0x04000000u) == LBM_TYPE_LISPARRAY0xB0000000u);
857}
858
859static inline bool_Bool lbm_is_lisp_array_rw(lbm_value x) {
860 return( (lbm_type_of(x) == LBM_TYPE_LISPARRAY0xB0000000u) && !(x & LBM_PTR_TO_CONSTANT_BIT0x04000000u));
861}
862
863
864static inline bool_Bool lbm_is_channel(lbm_value x) {
865 return (lbm_type_of(x) == LBM_TYPE_CHANNEL0x90000000u &&
866 lbm_type_of(lbm_cdr(x)) == LBM_TYPE_SYMBOL0x00000000u &&
867 lbm_cdr(x) == ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
868}
869static inline bool_Bool lbm_is_char(lbm_value x) {
870 return (lbm_type_of(x) == LBM_TYPE_CHAR0x00000004u);
871}
872
873static inline bool_Bool lbm_is_special(lbm_value symrep) {
874 return ((lbm_type_of(symrep) == LBM_TYPE_SYMBOL0x00000000u) &&
875 (lbm_dec_sym(symrep) < SPECIAL_SYMBOLS_END0xFFFF));
876}
877
878static inline bool_Bool lbm_is_closure(lbm_value exp) {
879 return ((lbm_is_cons(exp)) &&
880 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
881 (lbm_car(exp) == ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u)));
882}
883
884static inline bool_Bool lbm_is_continuation(lbm_value exp) {
885 return ((lbm_type_of(exp) == LBM_TYPE_CONS0x10000000u) &&
886 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
887 (lbm_car(exp) == ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u)));
888}
889
890static inline bool_Bool lbm_is_macro(lbm_value exp) {
891 return ((lbm_type_of(exp) == LBM_TYPE_CONS0x10000000u) &&
892 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
893 (lbm_car(exp) == ENC_SYM_MACRO(((0x10D) << 4) | 0x00000000u)));
894}
895
896static inline bool_Bool lbm_is_match_binder(lbm_value exp) {
897 return (lbm_is_cons(exp) &&
898 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
899 (lbm_car(exp) == ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u)));
900}
901
902static inline bool_Bool lbm_is_comma_qualified_symbol(lbm_value exp) {
903 return (lbm_is_cons(exp) &&
904 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
905 (lbm_car(exp) == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) &&
906 (lbm_type_of(lbm_cadr(exp)) == LBM_TYPE_SYMBOL0x00000000u));
907}
908
909static inline bool_Bool lbm_is_symbol(lbm_value exp) {
910 return !(exp & LBM_LOW_RESERVED_BITS0x0000000Fu);
2
←
Assuming the condition is false
→
3
←
Returning zero, which participates in a condition later
→
911}
912
913static inline bool_Bool lbm_is_symbol_nil(lbm_value exp) {
914 return !exp
27.1
'exp' is not equal to 0, which participates in a condition later
27.1
'exp' is not equal to 0, which participates in a condition later
;
22
←
Assuming 'exp' is not equal to 0, which participates in a condition later
→
28
←
Returning zero, which participates in a condition later
→
31
←
Assuming 'exp' is not equal to 0, which participates in a condition later
→
32
←
Returning zero, which participates in a condition later
→
915}
916
917static inline bool_Bool lbm_is_symbol_true(lbm_value exp) {
918 return (lbm_is_symbol(exp) && exp == ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u));
919}
920
921static inline bool_Bool lbm_is_symbol_eval(lbm_value exp) {
922 return (lbm_is_symbol(exp) && exp == ENC_SYM_EVAL(((0x30008) << 4) | 0x00000000u));
923}
924
925static inline bool_Bool lbm_is_symbol_merror(lbm_value exp) {
926 return lbm_is_symbol(exp) && (exp == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
927}
928
929static inline bool_Bool lbm_is_list(lbm_value x) {
930 return (lbm_is_cons(x) || lbm_is_symbol_nil(x));
931}
932
933static inline bool_Bool lbm_is_list_rw(lbm_value x) {
934 return (lbm_is_cons_rw(x) || lbm_is_symbol_nil(x));
935}
936
937static inline bool_Bool lbm_is_quoted_list(lbm_value x) {
938 return (lbm_is_cons(x) &&
939 lbm_is_symbol(lbm_car(x)) &&
940 (lbm_car(x) == ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u)) &&
941 lbm_is_cons(lbm_cdr(x)) &&
942 lbm_is_cons(lbm_cadr(x)));
943}
944
945#ifndef LBM64
946#define ERROR_SYMBOL_MASK0xFFFFFFF0 0xFFFFFFF0
947#else
948#define ERROR_SYMBOL_MASK0xFFFFFFF0 0xFFFFFFFFFFFFFFF0
949#endif
950
951/* all error signaling symbols are in the range 0x20 - 0x2F */
952static inline bool_Bool lbm_is_error(lbm_value v){
953 return (lbm_is_symbol(v) &&
954 ((lbm_dec_sym(v) & ERROR_SYMBOL_MASK0xFFFFFFF0) == 0x20));
955}
956
957// ref_cell: returns a reference to the cell addressed by bits 3 - 26
958// Assumes user has checked that is_ptr was set
959static inline lbm_cons_t* lbm_ref_cell(lbm_value addr) {
960 return &lbm_dec_heap(addr)[lbm_dec_cons_cell_ptr(addr)];
961 //return &lbm_heap_state.heap[lbm_dec_ptr(addr)];
962}
963
964
965// lbm_uint a = lbm_heaps[0];
966// lbm_uint b = lbm_heaps[1];
967// lbm_uint i = (addr & LBM_PTR_TO_CONSTANT_BIT) >> LBM_PTR_TO_CONSTANT_SHIFT) - 1;
968// lbm_uint h = (a & i) | (b & ~i);
969
970#ifdef __cplusplus
971}
972#endif
973#endif
diff --git a/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-f5608d.html b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-f5608d.html new file mode 100644 index 00000000..dfedc04b --- /dev/null +++ b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-f5608d.html @@ -0,0 +1,6533 @@ + + + +src/eval_cps.c + + + + + + + + + + + + + + + + + + + + + + + + + + +

Bug Summary

+ + + + +
File:eval_cps.c
Warning:line 4595, column 19
Access to field 'size' results in a dereference of a null pointer (loaded from variable 'src_arr')
+ +

Annotated Source Code

+

Press '?' + to see keyboard shortcuts

+ + +
clang -cc1 -triple i386-pc-linux-gnu -analyze -disable-free -disable-llvm-verifier -discard-value-names -main-file-name eval_cps.c -analyzer-store=region -analyzer-opt-analyze-nested-blocks -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -mrelocation-model static -mthread-model posix -mframe-pointer=none -fmath-errno -fno-rounding-math -masm-verbose -mconstructor-aliases -target-cpu i686 -dwarf-column-info -fno-split-dwarf-inlining -debugger-tuning=gdb -resource-dir /usr/lib/llvm-10/lib/clang/10.0.0 -I ./include -I ./include/extensions -I platform/linux/include -D _PRELUDE -internal-isystem /usr/local/include -internal-isystem /usr/lib/llvm-10/lib/clang/10.0.0/include -internal-externc-isystem /usr/include/i386-linux-gnu -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -std=c99 -fdebug-compilation-dir /home/joels/Current/lispbm -ferror-limit 19 -fmessage-length 0 -fgnuc-version=4.2.1 -fobjc-runtime=gcc -fdiagnostics-show-option -vectorize-loops -vectorize-slp -analyzer-output=html -faddrsig -o /home/joels/Current/lispbm/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1 -x c src/eval_cps.c +
+ + + +
+ + +
+ + + + +
+

src/eval_cps.c

+
→
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1/*
2 Copyright 2018, 2020 - 2024 Joel Svensson svenssonjoel@yahoo.se
3
4 This program is free software: you can redistribute it and/or modify
5 it under the terms of the GNU General Public License as published by
6 the Free Software Foundation, either version 3 of the License, or
7 (at your option) any later version.
8
9 This program is distributed in the hope that it will be useful,
10 but WITHOUT ANY WARRANTY; without even the implied warranty of
11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 GNU General Public License for more details.
13
14 You should have received a copy of the GNU General Public License
15 along with this program. If not, see <http://www.gnu.org/licenses/>.
16*/
17
18#include <lbm_memory.h>
19#include <lbm_types.h>
20#include "symrepr.h"
21#include "heap.h"
22#include "env.h"
23#include "eval_cps.h"
24#include "stack.h"
25#include "fundamental.h"
26#include "extensions.h"
27#include "tokpar.h"
28#include "lbm_channel.h"
29#include "print.h"
30#include "platform_mutex.h"
31#include "lbm_flat_value.h"
32#include "lbm_flags.h"
33
34#ifdef VISUALIZE_HEAP
35#include "heap_vis.h"
36#endif
37
38#include <setjmp.h>
39#include <stdarg.h>
40
41static jmp_buf error_jmp_buf;
42static jmp_buf critical_error_jmp_buf;
43
44#define S_TO_US(X)(lbm_uint)((X) * 1000000) (lbm_uint)((X) * 1000000)
45
46#define DEC_CONTINUATION(x)(((x) & ~0xF8000001u) >> 2) (((x) & ~LBM_CONTINUATION_INTERNAL0xF8000001u) >> LBM_ADDRESS_SHIFT2)
47#define IS_CONTINUATION(x)(((x) & 0xF8000001u) == 0xF8000001u) (((x) & LBM_CONTINUATION_INTERNAL0xF8000001u) == LBM_CONTINUATION_INTERNAL0xF8000001u)
48#define CONTINUATION(x)(((x) << 2) | 0xF8000001u) (((x) << LBM_ADDRESS_SHIFT2) | LBM_CONTINUATION_INTERNAL0xF8000001u)
49
50#define DONE(((0) << 2) | 0xF8000001u) CONTINUATION(0)(((0) << 2) | 0xF8000001u)
51#define SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u) CONTINUATION(1)(((1) << 2) | 0xF8000001u)
52#define BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u) CONTINUATION(2)(((2) << 2) | 0xF8000001u)
53#define IF(((3) << 2) | 0xF8000001u) CONTINUATION(3)(((3) << 2) | 0xF8000001u)
54#define PROGN_REST(((4) << 2) | 0xF8000001u) CONTINUATION(4)(((4) << 2) | 0xF8000001u)
55#define APPLICATION_ARGS(((5) << 2) | 0xF8000001u) CONTINUATION(5)(((5) << 2) | 0xF8000001u)
56#define AND(((6) << 2) | 0xF8000001u) CONTINUATION(6)(((6) << 2) | 0xF8000001u)
57#define OR(((7) << 2) | 0xF8000001u) CONTINUATION(7)(((7) << 2) | 0xF8000001u)
58#define WAIT(((8) << 2) | 0xF8000001u) CONTINUATION(8)(((8) << 2) | 0xF8000001u)
59#define MATCH(((9) << 2) | 0xF8000001u) CONTINUATION(9)(((9) << 2) | 0xF8000001u)
60#define APPLICATION_START(((10) << 2) | 0xF8000001u) CONTINUATION(10)(((10) << 2) | 0xF8000001u)
61#define EVAL_R(((11) << 2) | 0xF8000001u) CONTINUATION(11)(((11) << 2) | 0xF8000001u)
62#define RESUME(((12) << 2) | 0xF8000001u) CONTINUATION(12)(((12) << 2) | 0xF8000001u)
63#define CLOSURE_ARGS(((13) << 2) | 0xF8000001u) CONTINUATION(13)(((13) << 2) | 0xF8000001u)
64#define EXIT_ATOMIC(((14) << 2) | 0xF8000001u) CONTINUATION(14)(((14) << 2) | 0xF8000001u)
65#define READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u) CONTINUATION(15)(((15) << 2) | 0xF8000001u)
66#define READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u) CONTINUATION(16)(((16) << 2) | 0xF8000001u)
67#define READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u) CONTINUATION(17)(((17) << 2) | 0xF8000001u)
68#define READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u) CONTINUATION(18)(((18) << 2) | 0xF8000001u)
69#define READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u) CONTINUATION(19)(((19) << 2) | 0xF8000001u)
70#define READ_DONE(((20) << 2) | 0xF8000001u) CONTINUATION(20)(((20) << 2) | 0xF8000001u)
71#define READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u) CONTINUATION(21)(((21) << 2) | 0xF8000001u)
72#define READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u) CONTINUATION(22)(((22) << 2) | 0xF8000001u)
73#define READ_COMMA_RESULT(((23) << 2) | 0xF8000001u) CONTINUATION(23)(((23) << 2) | 0xF8000001u)
74#define READ_START_ARRAY(((24) << 2) | 0xF8000001u) CONTINUATION(24)(((24) << 2) | 0xF8000001u)
75#define READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u) CONTINUATION(25)(((25) << 2) | 0xF8000001u)
76#define MAP(((26) << 2) | 0xF8000001u) CONTINUATION(26)(((26) << 2) | 0xF8000001u)
77#define MATCH_GUARD(((27) << 2) | 0xF8000001u) CONTINUATION(27)(((27) << 2) | 0xF8000001u)
78#define TERMINATE(((28) << 2) | 0xF8000001u) CONTINUATION(28)(((28) << 2) | 0xF8000001u)
79#define PROGN_VAR(((29) << 2) | 0xF8000001u) CONTINUATION(29)(((29) << 2) | 0xF8000001u)
80#define SETQ(((30) << 2) | 0xF8000001u) CONTINUATION(30)(((30) << 2) | 0xF8000001u)
81#define MOVE_TO_FLASH(((31) << 2) | 0xF8000001u) CONTINUATION(31)(((31) << 2) | 0xF8000001u)
82#define MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u) CONTINUATION(32)(((32) << 2) | 0xF8000001u)
83#define MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u) CONTINUATION(33)(((33) << 2) | 0xF8000001u)
84#define CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u) CONTINUATION(34)(((34) << 2) | 0xF8000001u)
85#define QQ_EXPAND_START(((35) << 2) | 0xF8000001u) CONTINUATION(35)(((35) << 2) | 0xF8000001u)
86#define QQ_EXPAND(((36) << 2) | 0xF8000001u) CONTINUATION(36)(((36) << 2) | 0xF8000001u)
87#define QQ_APPEND(((37) << 2) | 0xF8000001u) CONTINUATION(37)(((37) << 2) | 0xF8000001u)
88#define QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u) CONTINUATION(38)(((38) << 2) | 0xF8000001u)
89#define QQ_LIST(((39) << 2) | 0xF8000001u) CONTINUATION(39)(((39) << 2) | 0xF8000001u)
90#define KILL(((40) << 2) | 0xF8000001u) CONTINUATION(40)(((40) << 2) | 0xF8000001u)
91#define LOOP(((41) << 2) | 0xF8000001u) CONTINUATION(41)(((41) << 2) | 0xF8000001u)
92#define LOOP_CONDITION(((42) << 2) | 0xF8000001u) CONTINUATION(42)(((42) << 2) | 0xF8000001u)
93#define MERGE_REST(((43) << 2) | 0xF8000001u) CONTINUATION(43)(((43) << 2) | 0xF8000001u)
94#define MERGE_LAYER(((44) << 2) | 0xF8000001u) CONTINUATION(44)(((44) << 2) | 0xF8000001u)
95#define CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u) CONTINUATION(45)(((45) << 2) | 0xF8000001u)
96#define MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u) CONTINUATION(46)(((46) << 2) | 0xF8000001u)
97#define POP_READER_FLAGS(((47) << 2) | 0xF8000001u) CONTINUATION(47)(((47) << 2) | 0xF8000001u)
98#define EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u) CONTINUATION(48)(((48) << 2) | 0xF8000001u)
99#define NUM_CONTINUATIONS49 49
100
101#define FM_NEED_GC-1 -1
102#define FM_NO_MATCH-2 -2
103#define FM_PATTERN_ERROR-3 -3
104
105typedef enum {
106 BL_OK = 0,
107 BL_NO_MEMORY,
108 BL_INCORRECT_KEY
109} binding_location_status;
110
111#define FB_OK0 0
112#define FB_TYPE_ERROR-1 -1
113
114const char* lbm_error_str_parse_eof = "End of parse stream.";
115const char* lbm_error_str_parse_dot = "Incorrect usage of '.'.";
116const char* lbm_error_str_parse_close = "Expected closing parenthesis.";
117const char* lbm_error_str_num_args = "Incorrect number of arguments.";
118const char* lbm_error_str_forbidden_in_atomic = "Operation is forbidden in an atomic block.";
119const char* lbm_error_str_no_number = "Argument(s) must be a number.";
120const char* lbm_error_str_not_a_boolean = "Argument must be t or nil (true or false).";
121const char* lbm_error_str_incorrect_arg = "Incorrect argument.";
122const char* lbm_error_str_var_outside_progn = "Usage of var outside of progn.";
123const char* lbm_error_str_flash_not_possible = "Value cannot be written to flash.";
124const char* lbm_error_str_flash_error = "Error writing to flash.";
125const char* lbm_error_str_flash_full = "Flash memory is full.";
126const char* lbm_error_str_variable_not_bound = "Variable not bound.";
127
128static lbm_value lbm_error_suspect;
129static bool_Bool lbm_error_has_suspect = false0;
130#ifdef LBM_ALWAYS_GC
131
132#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
133 gc(); \
134 (y) = (x); \
135 if (lbm_is_symbol_merror((y))) { \
136 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
137 }
138
139#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
140 lbm_gc_mark_phase(r); \
141 gc(); \
142 (y) = (x); \
143 if (lbm_is_symbol_merror((y))) { \
144 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
145 }
146
147#else
148
149#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
150 (y) = (x); \
151 if (lbm_is_symbol_merror((y))) { \
152 gc(); \
153 (y) = (x); \
154 if (lbm_is_symbol_merror((y))) { \
155 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
156 } \
157 /* continue executing statements below */ \
158 }
159#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
160 (y) = (x); \
161 if (lbm_is_symbol_merror((y))) { \
162 lbm_gc_mark_phase(r); \
163 gc(); \
164 (y) = (x); \
165 if (lbm_is_symbol_merror((y))) { \
166 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
167 } \
168 /* continue executing statements below */ \
169 }
170
171#endif
172
173typedef struct {
174 eval_context_t *first;
175 eval_context_t *last;
176} eval_context_queue_t;
177
178#ifdef CLEAN_UP_CLOSURES
179static lbm_value clean_cl_env_symbol = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
180#endif
181
182static int gc(void);
183static void error_ctx(lbm_value);
184static void error_at_ctx(lbm_value err_val, lbm_value at);
185static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx);
186static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail);
187
188// The currently executing context.
189eval_context_t *ctx_running = NULL((void*)0);
190volatile bool_Bool lbm_system_sleeping = false0;
191
192static volatile bool_Bool gc_requested = false0;
193void lbm_request_gc(void) {
194 gc_requested = true1;
195}
196
197/*
198 On ChibiOs the CH_CFG_ST_FREQUENCY setting in chconf.h sets the
199 resolution of the timer used for sleep operations. If this is set
200 to 10KHz the resolution is 100us.
201
202 The CH_CFG_ST_TIMEDELTA specifies the minimum number of ticks that
203 can be safely specified in a timeout directive (wonder if that
204 means sleep-period). The timedelta is set to 2.
205
206 If I have understood these correctly it means that the minimum
207 sleep duration possible is 2 * 100us = 200us.
208*/
209
210#define EVAL_CPS_DEFAULT_STACK_SIZE256 256
211#define EVAL_CPS_MIN_SLEEP200 200
212#define EVAL_STEPS_QUOTA10 10
213
214static volatile uint32_t eval_steps_refill = EVAL_STEPS_QUOTA10;
215static uint32_t eval_steps_quota = EVAL_STEPS_QUOTA10;
216
217void lbm_set_eval_step_quota(uint32_t quota) {
218 eval_steps_refill = quota;
219}
220
221static uint32_t eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
222static volatile uint32_t eval_cps_next_state = EVAL_CPS_STATE_NONE0;
223static volatile uint32_t eval_cps_next_state_arg = 0;
224static volatile bool_Bool eval_cps_state_changed = false0;
225
226static void usleep_nonsense(uint32_t us) {
227 (void) us;
228}
229
230static bool_Bool dynamic_load_nonsense(const char *sym, const char **code) {
231 (void) sym;
232 (void) code;
233 return false0;
234}
235
236static uint32_t timestamp_nonsense(void) {
237 return 0;
238}
239
240static int printf_nonsense(const char *fmt, ...) {
241 (void) fmt;
242 return 0;
243}
244
245static void ctx_done_nonsense(eval_context_t *ctx) {
246 (void) ctx;
247}
248
249static void critical_nonsense(void) {
250 return;
251}
252
253static void (*critical_error_callback)(void) = critical_nonsense;
254static void (*usleep_callback)(uint32_t) = usleep_nonsense;
255static uint32_t (*timestamp_us_callback)(void) = timestamp_nonsense;
256static void (*ctx_done_callback)(eval_context_t *) = ctx_done_nonsense;
257static int (*printf_callback)(const char *, ...) = printf_nonsense;
258static bool_Bool (*dynamic_load_callback)(const char *, const char **) = dynamic_load_nonsense;
259
260void lbm_set_critical_error_callback(void (*fptr)(void)) {
261 if (fptr == NULL((void*)0)) critical_error_callback = critical_nonsense;
262 else critical_error_callback = fptr;
263}
264
265void lbm_set_usleep_callback(void (*fptr)(uint32_t)) {
266 if (fptr == NULL((void*)0)) usleep_callback = usleep_nonsense;
267 else usleep_callback = fptr;
268}
269
270void lbm_set_timestamp_us_callback(uint32_t (*fptr)(void)) {
271 if (fptr == NULL((void*)0)) timestamp_us_callback = timestamp_nonsense;
272 else timestamp_us_callback = fptr;
273}
274
275void lbm_set_ctx_done_callback(void (*fptr)(eval_context_t *)) {
276 if (fptr == NULL((void*)0)) ctx_done_callback = ctx_done_nonsense;
277 else ctx_done_callback = fptr;
278}
279
280void lbm_set_printf_callback(int (*fptr)(const char*, ...)){
281 if (fptr == NULL((void*)0)) printf_callback = printf_nonsense;
282 else printf_callback = fptr;
283}
284
285void lbm_set_dynamic_load_callback(bool_Bool (*fptr)(const char *, const char **)) {
286 if (fptr == NULL((void*)0)) dynamic_load_callback = dynamic_load_nonsense;
287 else dynamic_load_callback = fptr;
288}
289
290static volatile lbm_event_t *lbm_events = NULL((void*)0);
291static unsigned int lbm_events_head = 0;
292static unsigned int lbm_events_tail = 0;
293static unsigned int lbm_events_max = 0;
294static bool_Bool lbm_events_full = false0;
295static mutex_t lbm_events_mutex;
296static bool_Bool lbm_events_mutex_initialized = false0;
297static volatile lbm_cid lbm_event_handler_pid = -1;
298
299lbm_cid lbm_get_event_handler_pid(void) {
300 return lbm_event_handler_pid;
301}
302
303void lbm_set_event_handler_pid(lbm_cid pid) {
304 lbm_event_handler_pid = pid;
305}
306
307bool_Bool lbm_event_handler_exists(void) {
308 return(lbm_event_handler_pid > 0);
309}
310
311
312static bool_Bool event_internal(lbm_event_type_t event_type, lbm_uint parameter, lbm_uint buf_ptr, lbm_uint buf_len) {
313 bool_Bool r = false0;
314 if (lbm_events) {
315 mutex_lock(&lbm_events_mutex);
316 if (!lbm_events_full) {
317 lbm_event_t event;
318 event.type = event_type;
319 event.parameter = parameter;
320 event.buf_ptr = buf_ptr;
321 event.buf_len = buf_len;
322 lbm_events[lbm_events_head] = event;
323 lbm_events_head = (lbm_events_head + 1) % lbm_events_max;
324 lbm_events_full = lbm_events_head == lbm_events_tail;
325 r = true1;
326 }
327 mutex_unlock(&lbm_events_mutex);
328 }
329 return r;
330}
331
332bool_Bool lbm_event_define(lbm_value key, lbm_flat_value_t *fv) {
333 return event_internal(LBM_EVENT_DEFINE, key, (lbm_uint)fv->buf, fv->buf_size);
334}
335
336bool_Bool lbm_event_unboxed(lbm_value unboxed) {
337 lbm_uint t = lbm_type_of(unboxed);
338 if (t == LBM_TYPE_SYMBOL0x00000000u ||
339 t == LBM_TYPE_I0x00000008u ||
340 t == LBM_TYPE_U0x0000000Cu ||
341 t == LBM_TYPE_CHAR0x00000004u) {
342 if (lbm_event_handler_pid > 0) {
343 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)unboxed, 0);
344 }
345 }
346 return false0;
347}
348
349bool_Bool lbm_event(lbm_flat_value_t *fv) {
350 if (lbm_event_handler_pid > 0) {
351 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)fv->buf, fv->buf_size);
352 }
353 return false0;
354}
355
356static bool_Bool lbm_event_pop(lbm_event_t *event) {
357 mutex_lock(&lbm_events_mutex);
358 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
359 mutex_unlock(&lbm_events_mutex);
360 return false0;
361 }
362 *event = lbm_events[lbm_events_tail];
363 lbm_events_tail = (lbm_events_tail + 1) % lbm_events_max;
364 lbm_events_full = false0;
365 mutex_unlock(&lbm_events_mutex);
366 return true1;
367}
368
369bool_Bool lbm_event_queue_is_empty(void) {
370 mutex_lock(&lbm_events_mutex);
371 bool_Bool empty = false0;
372 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
373 empty = true1;
374 }
375 mutex_unlock(&lbm_events_mutex);
376 return empty;
377}
378
379static bool_Bool eval_running = false0;
380static volatile bool_Bool blocking_extension = false0;
381static mutex_t blocking_extension_mutex;
382static bool_Bool blocking_extension_mutex_initialized = false0;
383static lbm_uint blocking_extension_timeout_us = 0;
384static bool_Bool blocking_extension_timeout = false0;
385
386static uint32_t is_atomic = 0;
387
388/* Process queues */
389static eval_context_queue_t blocked = {NULL((void*)0), NULL((void*)0)};
390static eval_context_queue_t queue = {NULL((void*)0), NULL((void*)0)};
391
392/* one mutex for all queue operations */
393mutex_t qmutex;
394bool_Bool qmutex_initialized = false0;
395
396
397// MODES
398static volatile bool_Bool lbm_verbose = false0;
399
400void lbm_toggle_verbose(void) {
401 lbm_verbose = !lbm_verbose;
402}
403
404void lbm_set_verbose(bool_Bool verbose) {
405 lbm_verbose = verbose;
406}
407
408lbm_cid lbm_get_current_cid(void) {
409 if (ctx_running)
410 return ctx_running->id;
411 else
412 return -1;
413}
414
415eval_context_t *lbm_get_current_context(void) {
416 return ctx_running;
417}
418
419/****************************************************/
420/* Utilities used locally in this file */
421
422static lbm_value cons_with_gc(lbm_value head, lbm_value tail, lbm_value remember) {
423#ifdef LBM_ALWAYS_GC
424 lbm_value roots[3] = {head, tail, remember};
425 lbm_gc_mark_roots(roots, 3);
426 gc();
427 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
428 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
429 if (lbm_is_symbol_merror(res)) {
430 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
431 }
432 return res;
433#else
434 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
435 if (lbm_is_symbol_merror(res)) {
436 lbm_value roots[3] = {head, tail, remember};
437 lbm_gc_mark_roots(roots,3);
438 gc();
439 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
440 if (lbm_is_symbol_merror(res)) {
441 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
442 }
443 }
444 return res;
445#endif
446}
447
448static lbm_uint *get_stack_ptr(eval_context_t *ctx, unsigned int n) {
449 if (n <= ctx->K.sp) {
450 lbm_uint index = ctx->K.sp - n;
451 return &ctx->K.data[index];
452 }
453 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
454 return 0; // dead code cannot be reached, but C compiler doesn't realise.
455}
456
457// pop_stack_ptr is safe when no GC is performed and
458// the values of the stack will be dropped.
459static lbm_uint *pop_stack_ptr(eval_context_t *ctx, unsigned int n) {
460 if (n <= ctx->K.sp) {
461 ctx->K.sp -= n;
462 return &ctx->K.data[ctx->K.sp];
463 }
464 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
465 return 0; // dead code cannot be reached, but C compiler doesn't realise.
466}
467
468static inline lbm_uint *stack_reserve(eval_context_t *ctx, unsigned int n) {
469 if (ctx->K.sp + n < ctx->K.size) {
470 lbm_uint *ptr = &ctx->K.data[ctx->K.sp];
471 ctx->K.sp += n;
472 return ptr;
473 }
474 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
475 return 0; // dead code cannot be reached, but C compiler doesn't realise.
476}
477
478static void handle_flash_status(lbm_flash_status s) {
479 if ( s == LBM_FLASH_FULL) {
480 lbm_set_error_reason((char*)lbm_error_str_flash_full);
481 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
482 }
483 if (s == LBM_FLASH_WRITE_ERROR) {
484 lbm_set_error_reason((char*)lbm_error_str_flash_error);
485 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
486 }
487}
488
489static void lift_array_flash(lbm_value flash_cell, bool_Bool bytearray, char *data, lbm_uint num_elt) {
490
491 lbm_array_header_t flash_array_header;
492 flash_array_header.size = num_elt;
493 flash_array_header.data = (lbm_uint*)data;
494 lbm_uint flash_array_header_ptr;
495 handle_flash_status(lbm_write_const_raw((lbm_uint*)&flash_array_header,
496 sizeof(lbm_array_header_t) / sizeof(lbm_uint),
497 &flash_array_header_ptr));
498 handle_flash_status(write_const_car(flash_cell, flash_array_header_ptr));
499 lbm_uint t = bytearray ? ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u) : ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u);
500 handle_flash_status(write_const_cdr(flash_cell, t));
501}
502
503static void get_car_and_cdr(lbm_value a, lbm_value *a_car, lbm_value *a_cdr) {
504 if (lbm_is_ptr(a)) {
505 lbm_cons_t *cell = lbm_ref_cell(a);
506 *a_car = cell->car;
507 *a_cdr = cell->cdr;
508 } else if (lbm_is_symbol_nil(a)) {
509 *a_car = *a_cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
510 } else {
511 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
512 }
513}
514
515/* car cdr caar cadr replacements that are evaluator safe. */
516static lbm_value get_car(lbm_value a) {
517 if (lbm_is_ptr(a)) {
2
←
Assuming the condition is false
→
3
←
Taking false branch
→
518 lbm_cons_t *cell = lbm_ref_cell(a);
519 return cell->car;
520 } else if (lbm_is_symbol_nil(a)) {
4
←
Calling 'lbm_is_symbol_nil'
→
7
←
Returning from 'lbm_is_symbol_nil'
→
8
←
Taking true branch
→
521 return a;
9
←
Returning zero (loaded from 'a')
→
522 }
523 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
524 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
525}
526
527static lbm_value get_cdr(lbm_value a) {
528 if (lbm_is_ptr(a)) {
529 lbm_cons_t *cell = lbm_ref_cell(a);
530 return cell->cdr;
531 } else if (lbm_is_symbol_nil(a)) {
532 return a;
533 }
534 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
535 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
536}
537
538static lbm_value get_cadr(lbm_value a) {
539 if (lbm_is_ptr(a)) {
540 lbm_cons_t *cell = lbm_ref_cell(a);
541 lbm_value tmp = cell->cdr;
542 if (lbm_is_ptr(tmp)) {
543 return lbm_ref_cell(tmp)->car;
544 } else if (lbm_is_symbol_nil(tmp)) {
545 return tmp;
546 }
547 } else if (lbm_is_symbol_nil(a)) {
548 return a;
549 }
550 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
551 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
552}
553
554static lbm_value allocate_closure(lbm_value params, lbm_value body, lbm_value env) {
555
556#ifdef LBM_ALWAYS_GC
557 gc();
558 if (lbm_heap_num_free() < 4) {
559 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
560 }
561#else
562 if (lbm_heap_num_free() < 4) {
563 gc();
564 if (lbm_heap_num_free() < 4) {
565 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
566 }
567 }
568#endif
569 // The freelist will always contain just plain heap-cells.
570 // So dec_ptr is sufficient.
571 lbm_value res = lbm_heap_state.freelist;
572 if (lbm_type_of(res) == LBM_TYPE_CONS0x10000000u) {
573 lbm_cons_t *heap = lbm_heap_state.heap;
574 lbm_uint ix = lbm_dec_ptr(res);
575 heap[ix].car = ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u);
576 ix = lbm_dec_ptr(heap[ix].cdr);
577 heap[ix].car = params;
578 ix = lbm_dec_ptr(heap[ix].cdr);
579 heap[ix].car = body;
580 ix = lbm_dec_ptr(heap[ix].cdr);
581 heap[ix].car = env;
582 lbm_heap_state.freelist = heap[ix].cdr;
583 heap[ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
584 lbm_heap_state.num_alloc+=4;
585 } else {
586 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
587 }
588 return res;
589}
590
591// Allocate a binding and attach it to a list (if so desired)
592static lbm_value allocate_binding(lbm_value key, lbm_value val, lbm_value the_cdr) {
593 if (lbm_heap_num_free() < 2) {
594 gc();
595 if (lbm_heap_num_free() < 2) {
596 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
597 }
598 }
599 lbm_cons_t* heap = lbm_heap_state.heap;
600 lbm_value binding_cell = lbm_heap_state.freelist;
601 lbm_uint binding_cell_ix = lbm_dec_ptr(binding_cell);
602 lbm_value list_cell = heap[binding_cell_ix].cdr;
603 lbm_uint list_cell_ix = lbm_dec_ptr(list_cell);
604 lbm_heap_state.freelist = heap[list_cell_ix].cdr;
605 lbm_heap_state.num_alloc += 2;
606 heap[binding_cell_ix].car = key;
607 heap[binding_cell_ix].cdr = val;
608 heap[list_cell_ix].car = binding_cell;
609 heap[list_cell_ix].cdr = the_cdr;
610 return list_cell;
611}
612
613#define CLO_PARAMS0 0
614#define CLO_BODY1 1
615#define CLO_ENV2 2
616#define LOOP_BINDS0 0
617#define LOOP_COND1 1
618#define LOOP_BODY2 2
619
620// (a b c) -> [a b c]
621static lbm_value extract_n(lbm_value curr, lbm_value *res, unsigned int n) {
622 for (unsigned int i = 0; i < n; i ++) {
623 if (lbm_is_ptr(curr)) {
624 lbm_cons_t *cell = lbm_ref_cell(curr);
625 res[i] = cell->car;
626 curr = cell->cdr;
627 } else {
628 res[i] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
629 }
630 }
631 return curr; // Rest of list is returned here.
632}
633
634static void call_fundamental(lbm_uint fundamental, lbm_value *args, lbm_uint arg_count, eval_context_t *ctx) {
635 lbm_value res;
636 res = fundamental_table[fundamental](args, arg_count, ctx);
637 if (lbm_is_error(res)) {
638 if (lbm_is_symbol_merror(res)) {
639 gc();
640 res = fundamental_table[fundamental](args, arg_count, ctx);
641 }
642 if (lbm_is_error(res)) {
643 error_at_ctx(res, lbm_enc_sym(FUNDAMENTAL_SYMBOLS_START0x20000 | fundamental));
644 }
645 }
646 lbm_stack_drop(&ctx->K, arg_count+1);
647 ctx->app_cont = true1;
648 ctx->r = res;
649}
650
651// block_current_ctx blocks a context until it is
652// woken up externally or a timeout period of time passes.
653static void block_current_ctx(uint32_t state, lbm_uint sleep_us, bool_Bool do_cont) {
654 ctx_running->timestamp = timestamp_us_callback();
655 ctx_running->sleep_us = sleep_us;
656 ctx_running->state = state;
657 ctx_running->app_cont = do_cont;
658 enqueue_ctx(&blocked, ctx_running);
659 ctx_running = NULL((void*)0);
660}
661
662lbm_flash_status lbm_write_const_array_padded(uint8_t *data, lbm_uint n, lbm_uint *res) {
663 lbm_uint full_words = n / sizeof(lbm_uint);
664 lbm_uint n_mod = n % sizeof(lbm_uint);
665
666 if (n_mod == 0) { // perfect fit.
667 return lbm_write_const_raw((lbm_uint*)data, full_words, res);
668 } else {
669 lbm_uint last_word = 0;
670 memcpy(&last_word, &data[full_words * sizeof(lbm_uint)], n_mod);
671 if (full_words >= 1) {
672 lbm_flash_status s = lbm_write_const_raw((lbm_uint*)data, full_words, res);
673 if ( s == LBM_FLASH_WRITE_OK) {
674 lbm_uint dummy;
675 s = lbm_write_const_raw(&last_word, 1, &dummy);
676 }
677 return s;
678 } else {
679 return lbm_write_const_raw(&last_word, 1, res);
680 }
681 }
682}
683
684/****************************************************/
685/* Error message creation */
686
687#define ERROR_MESSAGE_BUFFER_SIZE_BYTES256 256
688
689void print_environments(char *buf, unsigned int size) {
690
691 lbm_value curr_l = ctx_running->curr_env;
692 printf_callback("\tCurrent local environment:\n");
693 while (lbm_type_of(curr_l) == LBM_TYPE_CONS0x10000000u) {
694 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_l));
695 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_l)));
696 printf_callback("\t%s = %s\n", buf, buf+(size/2));
697 curr_l = lbm_cdr(curr_l);
698 }
699 printf_callback("\n\n");
700 printf_callback("\tCurrent global environment:\n");
701 lbm_value *glob_env = lbm_get_global_env();
702
703 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
704 lbm_value curr_g = glob_env[i];;
705 while (lbm_type_of(curr_g) == LBM_TYPE_CONS0x10000000u) {
706
707 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_g));
708 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_g)));
709 printf_callback("\t%s = %s\n", buf, buf+(size/2));
710 curr_g = lbm_cdr(curr_g);
711 }
712 }
713}
714
715void print_error_message(lbm_value error, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int col, lbm_int row0, lbm_int row1) {
716 if (!printf_callback) return;
717
718 /* try to allocate a lbm_print_value buffer on the lbm_memory */
719 char *buf = lbm_malloc_reserve(ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
720 if (!buf) {
721 printf_callback("Error: Not enough free memory to create a human readable error message\n");
722 return;
723 }
724
725 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, error);
726 printf_callback( "*** Error: %s\n", buf);
727 if (has_at) {
728 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, at);
729 printf_callback("*** In: %s\n",buf);
730 if (lbm_error_has_suspect) {
731 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, lbm_error_suspect);
732 lbm_error_has_suspect = false0;
733 printf_callback("*** At: %s\n", buf);
734 } else {
735 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
736 printf_callback("*** After: %s\n",buf);
737 }
738 } else {
739 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
740 printf_callback("*** Near: %s\n",buf);
741 }
742
743 printf_callback("\n");
744
745 if (lbm_is_symbol(error) &&
746 error == ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u)) {
747 printf_callback("*** Line: %u\n", row);
748 printf_callback("*** Column: %u\n", col);
749 } else if (row0 != -1 || row1 != -1 ) {
750 printf_callback("*** Between rows: (-1 unknown) \n");
751 printf_callback("*** Start: %d\n", (int32_t)row0);
752 printf_callback("*** End: %d\n", (int32_t)row1);
753 }
754
755 printf_callback("\n");
756
757 if (ctx_running->error_reason) {
758 printf_callback("Reason:\n %s\n\n", ctx_running->error_reason);
759 }
760 if (lbm_verbose) {
761 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
762 printf_callback(" In context: %d\n", ctx_running->id);
763 printf_callback(" Current intermediate result: %s\n\n", buf);
764
765 print_environments(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
766 printf_callback("\n\n");
767
768 printf_callback(" Stack:\n");
769 for (unsigned int i = 0; i < ctx_running->K.sp; i ++) {
770 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->K.data[i]);
771 printf_callback(" %s\n", buf);
772 }
773 }
774 lbm_free(buf);
775}
776
777/****************************************************/
778/* Tokenizing and parsing */
779
780bool_Bool create_string_channel(char *str, lbm_value *res) {
781
782 lbm_char_channel_t *chan = NULL((void*)0);
783 lbm_string_channel_state_t *st = NULL((void*)0);
784
785 st = (lbm_string_channel_state_t*)lbm_memory_allocate(sizeof(lbm_string_channel_state_t) / sizeof(lbm_uint) +1);
786 if (st == NULL((void*)0)) {
787 return false0;
788 }
789 chan = (lbm_char_channel_t*)lbm_memory_allocate(sizeof(lbm_char_channel_t) / sizeof(lbm_uint) + 1);
790 if (chan == NULL((void*)0)) {
791 lbm_memory_free((lbm_uint*)st);
792 return false0;
793 }
794
795 lbm_create_string_char_channel(st, chan, str);
796 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
797 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
798 lbm_memory_free((lbm_uint*)st);
799 lbm_memory_free((lbm_uint*)chan);
800 return false0;
801 }
802
803 *res = cell;
804 return true1;
805}
806
807bool_Bool lift_char_channel(lbm_char_channel_t *chan , lbm_value *res) {
808 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
809 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
810 return false0;
811 }
812 *res = cell;
813 return true1;
814}
815
816
817/****************************************************/
818/* Queue functions */
819
820static void queue_iterator_nm(eval_context_queue_t *q, ctx_fun f, void *arg1, void *arg2) {
821 eval_context_t *curr;
822 curr = q->first;
823
824 while (curr != NULL((void*)0)) {
825 f(curr, arg1, arg2);
826 curr = curr->next;
827 }
828}
829
830void lbm_running_iterator(ctx_fun f, void *arg1, void *arg2){
831 mutex_lock(&qmutex);
832 queue_iterator_nm(&queue, f, arg1, arg2);
833 mutex_unlock(&qmutex);
834}
835
836void lbm_blocked_iterator(ctx_fun f, void *arg1, void *arg2){
837 mutex_lock(&qmutex);
838 queue_iterator_nm(&blocked, f, arg1, arg2);
839 mutex_unlock(&qmutex);
840}
841
842static void enqueue_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
843 if (q->last == NULL((void*)0)) {
844 ctx->prev = NULL((void*)0);
845 ctx->next = NULL((void*)0);
846 q->first = ctx;
847 q->last = ctx;
848 } else {
849 ctx->prev = q->last;
850 ctx->next = NULL((void*)0);
851 q->last->next = ctx;
852 q->last = ctx;
853 }
854}
855
856static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx) {
857 mutex_lock(&qmutex);
858 enqueue_ctx_nm(q,ctx);
859 mutex_unlock(&qmutex);
860}
861
862static eval_context_t *lookup_ctx_nm(eval_context_queue_t *q, lbm_cid cid) {
863 eval_context_t *curr;
864 curr = q->first;
865 while (curr != NULL((void*)0)) {
866 if (curr->id == cid) {
867 return curr;
868 }
869 curr = curr->next;
870 }
871 return NULL((void*)0);
872}
873
874static bool_Bool drop_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
875
876 bool_Bool res = false0;
877 if (q->first == NULL((void*)0) || q->last == NULL((void*)0)) {
878 if (!(q->last == NULL((void*)0) && q->first == NULL((void*)0))) {
879 /* error state that should not happen */
880 return res;
881 }
882 /* Queue is empty */
883 return res;
884 }
885
886 eval_context_t *curr = q->first;
887 while (curr) {
888 if (curr->id == ctx->id) {
889 res = true1;
890 eval_context_t *tmp = curr->next;
891 if (curr->prev == NULL((void*)0)) {
892 if (curr->next == NULL((void*)0)) {
893 q->last = NULL((void*)0);
894 q->first = NULL((void*)0);
895 } else {
896 q->first = tmp;
897 tmp->prev = NULL((void*)0);
898 }
899 } else { /* curr->prev != NULL */
900 if (curr->next == NULL((void*)0)) {
901 q->last = curr->prev;
902 q->last->next = NULL((void*)0);
903 } else {
904 curr->prev->next = tmp;
905 tmp->prev = curr->prev;
906 }
907 }
908 break;
909 }
910 curr = curr->next;
911 }
912 return res;
913}
914
915/* End execution of the running context. */
916static void finish_ctx(void) {
917
918 if (!ctx_running) {
919 return;
920 }
921 /* Drop the continuation stack immediately to free up lbm_memory */
922 lbm_stack_free(&ctx_running->K);
923 ctx_done_callback(ctx_running);
924 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->name)) {
925 lbm_free(ctx_running->name);
926 }
927 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->error_reason)) {
928 lbm_memory_free((lbm_uint*)ctx_running->error_reason);
929 }
930 lbm_memory_free((lbm_uint*)ctx_running->mailbox);
931 lbm_memory_free((lbm_uint*)ctx_running);
932 ctx_running = NULL((void*)0);
933}
934
935static void context_exists(eval_context_t *ctx, void *cid, void *b) {
936 if (ctx->id == *(lbm_cid*)cid) {
937 *(bool_Bool*)b = true1;
938 }
939}
940
941bool_Bool lbm_wait_ctx(lbm_cid cid, lbm_uint timeout_ms) {
942
943 bool_Bool exists;
944 uint32_t i = 0;
945
946 do {
947 exists = false0;
948 lbm_blocked_iterator(context_exists, &cid, &exists);
949 lbm_running_iterator(context_exists, &cid, &exists);
950
951 if (ctx_running &&
952 ctx_running->id == cid) {
953 exists = true1;
954 }
955
956 if (exists) {
957 if (usleep_callback) {
958 usleep_callback(1000);
959 }
960 if (timeout_ms > 0) i ++;
961 }
962 } while (exists && i < timeout_ms);
963
964 if (exists) return false0;
965 return true1;
966}
967
968void lbm_set_error_suspect(lbm_value suspect) {
969 lbm_error_suspect = suspect;
970 lbm_error_has_suspect = true1;
971}
972
973void lbm_set_error_reason(char *error_str) {
974 if (ctx_running != NULL((void*)0)) {
975 ctx_running->error_reason = error_str;
976 }
977}
978
979// Not possible to CONS_WITH_GC in error_ctx_base (potential loop)
980static void error_ctx_base(lbm_value err_val, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int column) {
981
982 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
983 if (lbm_heap_num_free() < 3) {
984 gc();
985 }
986
987 if (lbm_heap_num_free() >= 3) {
988 lbm_value msg = lbm_cons(err_val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
989 msg = lbm_cons(lbm_enc_i(ctx_running->id), msg);
990 msg = lbm_cons(ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u), msg);
991 if (!lbm_is_symbol_merror(msg)) {
992 lbm_find_receiver_and_send(ctx_running->parent, msg);
993 goto error_ctx_base_done;
994 }
995 }
996 }
997 if ((ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10) &&
998 (err_val != ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u))) {
999 lbm_uint v;
1000 while (ctx_running->K.sp > 0) {
1001 lbm_pop(&ctx_running->K, &v);
1002 if (v == EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u)) {
1003 lbm_value *sptr = get_stack_ptr(ctx_running, 2);
1004 lbm_set_car(sptr[0], ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
1005 stack_reserve(ctx_running, 1)[0] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1006 ctx_running->app_cont = true1;
1007 ctx_running->r = err_val;
1008 longjmp(error_jmp_buf, 1);
1009 }
1010 }
1011 err_val = ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u);
1012 }
1013 print_error_message(err_val,
1014 has_at,
1015 at,
1016 row,
1017 column,
1018 ctx_running->row0,
1019 ctx_running->row1);
1020 error_ctx_base_done:
1021 ctx_running->r = err_val;
1022 finish_ctx();
1023 longjmp(error_jmp_buf, 1);
1024}
1025
1026static void error_at_ctx(lbm_value err_val, lbm_value at) {
1027 error_ctx_base(err_val, true1, at, 0, 0);
1028}
1029
1030static void error_ctx(lbm_value err_val) {
1031 error_ctx_base(err_val, false0, 0, 0, 0);
1032}
1033
1034static void read_error_ctx(unsigned int row, unsigned int column) {
1035 error_ctx_base(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u), false0, 0, row, column);
1036}
1037
1038void lbm_critical_error(void) {
1039 longjmp(critical_error_jmp_buf, 1);
1040}
1041
1042// successfully finish a context
1043static void ok_ctx(void) {
1044 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
1045 lbm_value msg;
1046 WITH_GC(msg, lbm_heap_allocate_list_init(3,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1047 ENC_SYM_EXIT_OK,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1048 lbm_enc_i(ctx_running->id),(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1049 ctx_running->r))(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
1050 lbm_find_receiver_and_send(ctx_running->parent, msg);
1051 }
1052 finish_ctx();
1053}
1054
1055static eval_context_t *dequeue_ctx_nm(eval_context_queue_t *q) {
1056 if (q->last == NULL((void*)0)) {
1057 return NULL((void*)0);
1058 }
1059 // q->first should only be NULL if q->last is.
1060 eval_context_t *res = q->first;
1061
1062 if (q->first == q->last) { // One thing in queue
1063 q->first = NULL((void*)0);
1064 q->last = NULL((void*)0);
1065 } else {
1066 q->first = q->first->next;
1067 q->first->prev = NULL((void*)0);
1068 }
1069 res->prev = NULL((void*)0);
1070 res->next = NULL((void*)0);
1071 return res;
1072}
1073
1074static void wake_up_ctxs_nm(void) {
1075 lbm_uint t_now;
1076
1077 if (timestamp_us_callback) {
1078 t_now = timestamp_us_callback();
1079 } else {
1080 t_now = 0;
1081 }
1082
1083 eval_context_queue_t *q = &blocked;
1084 eval_context_t *curr = q->first;
1085
1086 while (curr != NULL((void*)0)) {
1087 lbm_uint t_diff;
1088 eval_context_t *next = curr->next;
1089 if (curr->state != LBM_THREAD_STATE_BLOCKED(uint32_t)1) {
1090 if ( curr->timestamp > t_now) {
1091 /* There was an overflow on the counter */
1092#ifndef LBM64
1093 t_diff = (0xFFFFFFFF - curr->timestamp) + t_now;
1094#else
1095 t_diff = (0xFFFFFFFFFFFFFFFF - curr->timestamp) + t_now;
1096#endif
1097 } else {
1098 t_diff = t_now - curr->timestamp;
1099 }
1100
1101 if (t_diff >= curr->sleep_us) {
1102 eval_context_t *wake_ctx = curr;
1103 if (curr == q->last) {
1104 if (curr->prev) {
1105 q->last = curr->prev;
1106 q->last->next = NULL((void*)0);
1107 } else {
1108 q->first = NULL((void*)0);
1109 q->last = NULL((void*)0);
1110 }
1111 } else if (curr->prev == NULL((void*)0)) {
1112 q->first = curr->next;
1113 q->first->prev = NULL((void*)0);
1114 } else {
1115 curr->prev->next = curr->next;
1116 if (curr->next) {
1117 curr->next->prev = curr->prev;
1118 }
1119 }
1120 wake_ctx->next = NULL((void*)0);
1121 wake_ctx->prev = NULL((void*)0);
1122 if (curr->state == LBM_THREAD_STATE_TIMEOUT(uint32_t)2) {
1123 mailbox_add_mail(wake_ctx, ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u));
1124 wake_ctx->r = ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u);
1125 }
1126 wake_ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1127 enqueue_ctx_nm(&queue, wake_ctx);
1128 }
1129 }
1130 curr = next;
1131 }
1132}
1133
1134static void yield_ctx(lbm_uint sleep_us) {
1135 if (timestamp_us_callback) {
1136 ctx_running->timestamp = timestamp_us_callback();
1137 ctx_running->sleep_us = sleep_us;
1138 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1139 } else {
1140 ctx_running->timestamp = 0;
1141 ctx_running->sleep_us = 0;
1142 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1143 }
1144 ctx_running->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1145 ctx_running->app_cont = true1;
1146 enqueue_ctx(&blocked,ctx_running);
1147 ctx_running = NULL((void*)0);
1148}
1149
1150static lbm_cid lbm_create_ctx_parent(lbm_value program, lbm_value env, lbm_uint stack_size, lbm_cid parent, uint32_t context_flags, char *name) {
1151
1152 if (!lbm_is_cons(program)) return -1;
1153
1154 eval_context_t *ctx = NULL((void*)0);
1155
1156 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1157 if (ctx == NULL((void*)0)) {
1158 lbm_uint roots[2] = {program, env};
1159 lbm_gc_mark_roots(roots, 2);
1160 gc();
1161 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1162 }
1163 if (ctx == NULL((void*)0)) return -1;
1164
1165 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1166 lbm_uint roots[2] = {program, env};
1167 lbm_gc_mark_roots(roots, 2);
1168 gc();
1169 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1170 lbm_memory_free((lbm_uint*)ctx);
1171 return -1;
1172 }
1173 }
1174
1175 lbm_value *mailbox = NULL((void*)0);
1176 mailbox = (lbm_value*)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1177 if (mailbox == NULL((void*)0)) {
1178 lbm_value roots[2] = {program, env};
1179 lbm_gc_mark_roots(roots,2);
1180 gc();
1181 mailbox = (lbm_value *)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1182 }
1183 if (mailbox == NULL((void*)0)) {
1184 lbm_stack_free(&ctx->K);
1185 lbm_memory_free((lbm_uint*)ctx);
1186 return -1;
1187 }
1188
1189 // TODO: Limit names to 19 chars + 1 char for 0? (or something similar).
1190 if (name) {
1191 lbm_uint name_len = strlen(name) + 1;
1192 ctx->name = lbm_malloc(strlen(name) + 1);
1193 if (ctx->name == NULL((void*)0)) {
1194 lbm_value roots[2] = {program, env};
1195 lbm_gc_mark_roots(roots, 2);
1196 gc();
1197 ctx->name = lbm_malloc(strlen(name) + 1);
1198 }
1199 if (ctx->name == NULL((void*)0)) {
1200 lbm_stack_free(&ctx->K);
1201 lbm_memory_free((lbm_uint*)mailbox);
1202 lbm_memory_free((lbm_uint*)ctx);
1203 return -1;
1204 }
1205 memcpy(ctx->name, name, name_len+1);
1206 } else {
1207 ctx->name = NULL((void*)0);
1208 }
1209
1210 lbm_int cid = lbm_memory_address_to_ix((lbm_uint*)ctx);
1211
1212 ctx->program = lbm_cdr(program);
1213 ctx->curr_exp = lbm_car(program);
1214 ctx->curr_env = env;
1215 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1216 ctx->error_reason = NULL((void*)0);
1217 ctx->mailbox = mailbox;
1218 ctx->mailbox_size = EVAL_CPS_DEFAULT_MAILBOX_SIZE10;
1219 ctx->flags = context_flags;
1220 ctx->num_mail = 0;
1221 ctx->app_cont = false0;
1222 ctx->timestamp = 0;
1223 ctx->sleep_us = 0;
1224 ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1225 ctx->prev = NULL((void*)0);
1226 ctx->next = NULL((void*)0);
1227
1228 ctx->row0 = -1;
1229 ctx->row1 = -1;
1230
1231 ctx->id = cid;
1232 ctx->parent = parent;
1233
1234 if (!lbm_push(&ctx->K, DONE(((0) << 2) | 0xF8000001u))) {
1235 lbm_memory_free((lbm_uint*)ctx->mailbox);
1236 lbm_stack_free(&ctx->K);
1237 lbm_memory_free((lbm_uint*)ctx);
1238 return -1;
1239 }
1240
1241 enqueue_ctx(&queue,ctx);
1242
1243 return ctx->id;
1244}
1245
1246lbm_cid lbm_create_ctx(lbm_value program, lbm_value env, lbm_uint stack_size, char *name) {
1247 // Creates a parentless context.
1248 return lbm_create_ctx_parent(program,
1249 env,
1250 stack_size,
1251 -1,
1252 EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00,
1253 name);
1254}
1255
1256bool_Bool lbm_mailbox_change_size(eval_context_t *ctx, lbm_uint new_size) {
1257
1258 lbm_value *mailbox = NULL((void*)0);
1259 mailbox = (lbm_value*)lbm_memory_allocate(new_size);
1260 if (mailbox == NULL((void*)0)) {
1261 gc();
1262 mailbox = (lbm_value *)lbm_memory_allocate(new_size);
1263 }
1264 if (mailbox == NULL((void*)0)) {
1265 return false0;
1266 }
1267
1268 for (lbm_uint i = 0; i < ctx->num_mail; i ++ ) {
1269 mailbox[i] = ctx->mailbox[i];
1270 }
1271 lbm_memory_free(ctx->mailbox);
1272 ctx->mailbox = mailbox;
1273 ctx->mailbox_size = (uint32_t)new_size;
1274 return true1;
1275}
1276
1277static void mailbox_remove_mail(eval_context_t *ctx, lbm_uint ix) {
1278
1279 for (lbm_uint i = ix; i < ctx->num_mail-1; i ++) {
1280 ctx->mailbox[i] = ctx->mailbox[i+1];
1281 }
1282 ctx->num_mail --;
1283}
1284
1285static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail) {
1286
1287 if (ctx->num_mail >= ctx->mailbox_size) {
1288 mailbox_remove_mail(ctx, 0);
1289 }
1290
1291 ctx->mailbox[ctx->num_mail] = mail;
1292 ctx->num_mail ++;
1293 return true1;
1294}
1295
1296/* Advance execution to the next expression in the program */
1297static void advance_ctx(eval_context_t *ctx) {
1298 if (lbm_is_cons(ctx->program)) {
1299 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);;
1300 get_car_and_cdr(ctx->program, &ctx->curr_exp, &ctx->program);
1301 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1302 } else {
1303 if (ctx_running == ctx) { // This should always be the case because of odd historical reasons.
1304 ok_ctx();
1305 }
1306 }
1307}
1308
1309bool_Bool lbm_unblock_ctx(lbm_cid cid, lbm_flat_value_t *fv) {
1310 return event_internal(LBM_EVENT_UNBLOCK_CTX, (lbm_uint)cid, (lbm_uint)fv->buf, fv->buf_size);
1311}
1312
1313bool_Bool lbm_unblock_ctx_r(lbm_cid cid) {
1314 mutex_lock(&blocking_extension_mutex);
1315 bool_Bool r = false0;
1316 eval_context_t *found = NULL((void*)0);
1317 mutex_lock(&qmutex);
1318 found = lookup_ctx_nm(&blocked, cid);
1319 if (found) {
1320 drop_ctx_nm(&blocked,found);
1321 enqueue_ctx_nm(&queue,found);
1322 r = true1;
1323 }
1324 mutex_unlock(&qmutex);
1325 mutex_unlock(&blocking_extension_mutex);
1326 return r;
1327}
1328
1329// unblock unboxed is also safe for rmbr:ed things.
1330bool_Bool lbm_unblock_ctx_unboxed(lbm_cid cid, lbm_value unboxed) {
1331 mutex_lock(&blocking_extension_mutex);
1332 bool_Bool r = false0;
1333 eval_context_t *found = NULL((void*)0);
1334 mutex_lock(&qmutex);
1335 found = lookup_ctx_nm(&blocked, cid);
1336 if (found) {
1337 drop_ctx_nm(&blocked,found);
1338 found->r = unboxed;
1339 if (lbm_is_error(unboxed)) {
1340 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
1341 found->app_cont = true1;
1342 }
1343 enqueue_ctx_nm(&queue,found);
1344 r = true1;
1345 }
1346 mutex_unlock(&qmutex);
1347 mutex_unlock(&blocking_extension_mutex);
1348 return r;
1349}
1350
1351static bool_Bool lbm_block_ctx_base(bool_Bool timeout, float t_s) {
1352 mutex_lock(&blocking_extension_mutex);
1353 blocking_extension = true1;
1354 if (timeout) {
1355 blocking_extension_timeout_us = S_TO_US(t_s)(lbm_uint)((t_s) * 1000000);
1356 blocking_extension_timeout = true1;
1357 } else {
1358 blocking_extension_timeout = false0;
1359 }
1360 return true1;
1361}
1362
1363void lbm_block_ctx_from_extension_timeout(float s) {
1364 lbm_block_ctx_base(true1, s);
1365}
1366
1367void lbm_block_ctx_from_extension(void) {
1368 lbm_block_ctx_base(false0, 0);
1369}
1370
1371// todo: May need to pop rmbrs from stack, if present.
1372// Suspect that the letting the discard cont run is really not a problem.
1373// Either way will be quite confusing what happens to allocated things when undoing block.
1374void lbm_undo_block_ctx_from_extension(void) {
1375 blocking_extension = false0;
1376 blocking_extension_timeout_us = 0;
1377 blocking_extension_timeout = false0;
1378 mutex_unlock(&blocking_extension_mutex);
1379}
1380
1381lbm_value lbm_find_receiver_and_send(lbm_cid cid, lbm_value msg) {
1382 mutex_lock(&qmutex);
1383 eval_context_t *found = NULL((void*)0);
1384 bool_Bool found_blocked = false0;
1385
1386 found = lookup_ctx_nm(&blocked, cid);
1387 if (found) found_blocked = true1;
1388
1389 if (found == NULL((void*)0)) {
1390 found = lookup_ctx_nm(&queue, cid);
1391 }
1392
1393 if (found) {
1394 if (!mailbox_add_mail(found, msg)) {
1395 mutex_unlock(&qmutex);
1396 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1397 }
1398
1399 if (found_blocked){
1400 drop_ctx_nm(&blocked,found);
1401 enqueue_ctx_nm(&queue,found);
1402 }
1403 mutex_unlock(&qmutex);
1404 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1405 }
1406
1407 /* check the current context */
1408 if (ctx_running && ctx_running->id == cid) {
1409 if (!mailbox_add_mail(ctx_running, msg)) {
1410 mutex_unlock(&qmutex);
1411 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1412 }
1413 mutex_unlock(&qmutex);
1414 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1415 }
1416 mutex_unlock(&qmutex);
1417 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1418}
1419
1420/* Pattern matching is currently implemented as a recursive
1421 function and make use of stack relative to the size of
1422 expressions that are being matched. */
1423static bool_Bool match(lbm_value p, lbm_value e, lbm_value *env, bool_Bool *gc) {
1424
1425 lbm_value binding;
1426
1427 if (lbm_is_match_binder(p)) {
1428 lbm_value var = get_cadr(p);
1429 lbm_value bindertype = get_car(p);
1430
1431 if (!lbm_is_symbol(var)) return false0;
1432
1433 switch (bindertype) {
1434 case ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u):
1435 if ( var == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) {
1436 return true1;
1437 }
1438 break;
1439 default: /* this should be an error case */
1440 return false0;
1441 }
1442 binding = lbm_cons(var, e);
1443 if ( lbm_type_of(binding) == LBM_TYPE_SYMBOL0x00000000u ) {
1444 *gc = true1;
1445 return false0;
1446 }
1447 *env = lbm_cons(binding, *env);
1448 if ( lbm_type_of(*env) == LBM_TYPE_SYMBOL0x00000000u ) {
1449 *gc = true1;
1450 return false0;
1451 }
1452 return true1;
1453 }
1454
1455 if (lbm_is_symbol(p)) {
1456 if (p == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return true1;
1457 return (p == e);
1458 }
1459 if (lbm_is_cons(p) &&
1460 lbm_is_cons(e) ) {
1461
1462 lbm_value headp, tailp;
1463 lbm_value heade, taile;
1464 get_car_and_cdr(p, &headp, &tailp);
1465 get_car_and_cdr(e, &heade, &taile); // Static analysis warns, but execution does not
1466 // past this point unless head and tail get initialized.
1467 if (!match(headp, heade, env, gc)) {
1468 return false0;
1469 }
1470 return match (tailp, taile, env, gc);
1471 }
1472 return struct_eq(p, e);
1473}
1474
1475// Find match is not very picky about syntax.
1476// A completely malformed recv form is most likely to
1477// just return no_match.
1478static int find_match(lbm_value plist, lbm_value *earr, lbm_uint num, lbm_value *e, lbm_value *env) {
1479
1480 // A pattern list is a list of pattern, expression lists.
1481 // ( (p1 e1) (p2 e2) ... (pn en))
1482 lbm_value curr_p = plist;
1483 int n = 0;
1484 bool_Bool gc = false0;
1485 for (int i = 0; i < (int)num; i ++ ) {
1486 lbm_value curr_e = earr[i];
1487 while (!lbm_is_symbol_nil(curr_p)) {
1488 lbm_value me = get_car(curr_p);
1489 if (match(get_car(me), curr_e, env, &gc)) {
1490 if (gc) return FM_NEED_GC-1;
1491 *e = get_cadr(me);
1492
1493 if (!lbm_is_symbol_nil(get_cadr(get_cdr(me)))) {
1494 return FM_PATTERN_ERROR-3;
1495 }
1496 return n;
1497 }
1498 curr_p = get_cdr(curr_p);
1499 }
1500 curr_p = plist; /* search all patterns against next exp */
1501 n ++;
1502 }
1503
1504 return FM_NO_MATCH-2;
1505}
1506
1507/****************************************************/
1508/* Garbage collection */
1509
1510static void mark_context(eval_context_t *ctx, void *arg1, void *arg2) {
1511 (void) arg1;
1512 (void) arg2;
1513 lbm_value roots[3] = {ctx->curr_exp, ctx->program, ctx->r };
1514 lbm_gc_mark_env(ctx->curr_env);
1515 lbm_gc_mark_roots(roots, 3);
1516 lbm_gc_mark_roots(ctx->mailbox, ctx->num_mail);
1517 lbm_gc_mark_aux(ctx->K.data, ctx->K.sp);
1518}
1519
1520static int gc(void) {
1521 if (ctx_running) {
1522 ctx_running->state = ctx_running->state | LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1523 }
1524
1525 gc_requested = false0;
1526 lbm_gc_state_inc();
1527
1528 // The freelist should generally be NIL when GC runs.
1529 lbm_nil_freelist();
1530 lbm_value *env = lbm_get_global_env();
1531 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
1532 lbm_gc_mark_env(env[i]);
1533 }
1534
1535 mutex_lock(&qmutex); // Lock the queues.
1536 // Any concurrent messing with the queues
1537 // while doing GC cannot possibly be good.
1538 queue_iterator_nm(&queue, mark_context, NULL((void*)0), NULL((void*)0));
1539 queue_iterator_nm(&blocked, mark_context, NULL((void*)0), NULL((void*)0));
1540
1541 if (ctx_running) {
1542 mark_context(ctx_running, NULL((void*)0), NULL((void*)0));
1543 }
1544 mutex_unlock(&qmutex);
1545
1546#ifdef VISUALIZE_HEAP
1547 heap_vis_gen_image();
1548#endif
1549
1550 int r = lbm_gc_sweep_phase();
1551 lbm_heap_new_freelist_length();
1552
1553 if (ctx_running) {
1554 ctx_running->state = ctx_running->state & ~LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1555 }
1556 return r;
1557}
1558
1559int lbm_perform_gc(void) {
1560 return gc();
1561}
1562
1563/****************************************************/
1564/* Evaluation functions */
1565
1566
1567static void eval_symbol(eval_context_t *ctx) {
1568 lbm_uint s = lbm_dec_sym(ctx->curr_exp);
1569 if (s >= RUNTIME_SYMBOLS_START0x40000) {
1570 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1571 if (lbm_env_lookup_b(&res, ctx->curr_exp, ctx->curr_env) ||
1572 lbm_global_env_lookup(&res, ctx->curr_exp)) {
1573 ctx->r = res;
1574 ctx->app_cont = true1;
1575 return;
1576 }
1577 // Dynamic load attempt
1578 // Only symbols of kind RUNTIME can be dynamically loaded.
1579 const char *sym_str = lbm_get_name_by_symbol(s);
1580 const char *code_str = NULL((void*)0);
1581 if (!dynamic_load_callback(sym_str, &code_str)) {
1582 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), ctx->curr_exp);
1583 }
1584 lbm_value *sptr = stack_reserve(ctx, 3);
1585 sptr[0] = ctx->curr_exp;
1586 sptr[1] = ctx->curr_env;
1587 sptr[2] = RESUME(((12) << 2) | 0xF8000001u);
1588
1589 lbm_value chan;
1590 if (!create_string_channel((char *)code_str, &chan)) {
1591 gc();
1592 if (!create_string_channel((char *)code_str, &chan)) {
1593 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1594 }
1595 }
1596
1597 lbm_value loader;
1598 WITH_GC_RMBR_1(loader, lbm_heap_allocate_list_init(2,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1599 ENC_SYM_READ,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1600 chan), chan)(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} };
1601 lbm_value evaluator;
1602 WITH_GC_RMBR_1(evaluator, lbm_heap_allocate_list_init(2,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1603 ENC_SYM_EVAL,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1604 loader), loader)(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } };
1605 ctx->curr_exp = evaluator;
1606 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // dynamics should be evaluable in empty local env
1607 } else {
1608 //special symbols and extensions can be handled the same way.
1609 ctx->r = ctx->curr_exp;
1610 ctx->app_cont = true1;
1611 }
1612}
1613
1614static void eval_quote(eval_context_t *ctx) {
1615 ctx->r = get_cadr(ctx->curr_exp);
1616 ctx->app_cont = true1;
1617}
1618
1619static void eval_selfevaluating(eval_context_t *ctx) {
1620 ctx->r = ctx->curr_exp;
1621 ctx->app_cont = true1;
1622}
1623
1624static void eval_progn(eval_context_t *ctx) {
1625 lbm_value exps = get_cdr(ctx->curr_exp);
1626
1627 if (lbm_is_cons(exps)) {
1628 lbm_uint *sptr = stack_reserve(ctx, 4);
1629 sptr[0] = ctx->curr_env; // env to restore between expressions in progn
1630 sptr[1] = lbm_enc_u(0); // Has env been copied (needed for progn local bindings)
1631 sptr[3] = PROGN_REST(((4) << 2) | 0xF8000001u);
1632 get_car_and_cdr(exps, &ctx->curr_exp, &sptr[2]);
1633 if (lbm_is_symbol(sptr[2])) /* The only symbol it can be is nil */
1634 lbm_stack_drop(&ctx->K, 4);
1635 } else if (lbm_is_symbol_nil(exps)) {
1636 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1637 ctx->app_cont = true1;
1638 } else {
1639 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1640 }
1641}
1642
1643static void eval_atomic(eval_context_t *ctx) {
1644 if (is_atomic) {
1645 lbm_set_error_reason("Atomic blocks cannot be nested!");
1646 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1647 }
1648 stack_reserve(ctx, 1)[0] = EXIT_ATOMIC(((14) << 2) | 0xF8000001u);
1649 is_atomic ++;
1650 eval_progn(ctx);
1651}
1652
1653/* (call-cc (lambda (k) .... )) */
1654static void eval_callcc(eval_context_t *ctx) {
1655 lbm_value cont_array;
1656 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1657 gc();
1658 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1659 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1660 return; // dead return but static analysis doesn't know :)
1661 }
1662 }
1663 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(cont_array);
1664 memcpy(arr->data, ctx->K.data, ctx->K.sp * sizeof(lbm_uint));
1665
1666 lbm_value acont = cons_with_gc(ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u), cont_array, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1667 lbm_value arg_list = cons_with_gc(acont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1668 // Go directly into application evaluation without passing go
1669 lbm_uint *sptr = stack_reserve(ctx, 3);
1670 sptr[0] = ctx->curr_env;
1671 sptr[1] = arg_list;
1672 sptr[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
1673 ctx->curr_exp = get_cadr(ctx->curr_exp);
1674}
1675
1676// (define sym exp)
1677#define KEY1 1
1678#define VAL2 2
1679static void eval_define(eval_context_t *ctx) {
1680 lbm_value parts[3];
1681 lbm_value rest = extract_n(ctx->curr_exp, parts, 3);
1682 lbm_uint *sptr = stack_reserve(ctx, 2);
1683 if (lbm_is_symbol(parts[KEY1]) && lbm_is_symbol_nil(rest)) {
1684 lbm_uint sym_val = lbm_dec_sym(parts[KEY1]);
1685 sptr[0] = parts[KEY1];
1686 if (sym_val >= RUNTIME_SYMBOLS_START0x40000) {
1687 sptr[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
1688 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02) {
1689 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
1690 }
1691 ctx->curr_exp = parts[VAL2];
1692 return;
1693 }
1694 }
1695 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
1696}
1697
1698
1699/* Eval lambda is cheating, a lot! It does this
1700 for performance reasons. The cheats are that
1701 1. When closure is created, a reference to the local env
1702 in which the lambda was evaluated is added to the closure.
1703 Ideally it should have created a list of free variables in the function
1704 and then looked up the values of these creating a new environment.
1705 2. The global env is considered global constant. As there is no copying
1706 of environment bindings into the closure, undefine may break closures.
1707
1708 Correct closure creation is a lot more expensive than what happens here.
1709 However, one can try to write programs in such a way that closures are created
1710 seldomly. If one does that the space-usage benefits of "correct" closures
1711 may outweigh the performance gain of "incorrect" ones.
1712
1713 some obscure programs such as test_setq_local_closure.lisp does not
1714 work properly due to this cheating.
1715 */
1716// (lambda param-list body-exp) -> (closure param-list body-exp env)
1717static void eval_lambda(eval_context_t *ctx) {
1718 lbm_value vals[3];
1719 extract_n(ctx->curr_exp, vals, 3);
1720 ctx->r = allocate_closure(vals[1],vals[2], ctx->curr_env);
1721#ifdef CLEAN_UP_CLOSURES
1722 lbm_uint sym_id = 0;
1723 if (clean_cl_env_symbol) {
1724 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1725 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1726 ctx->curr_exp = app;
1727 } else if (lbm_get_symbol_by_name("clean-cl-env", &sym_id)) {
1728 clean_cl_env_symbol = lbm_enc_sym(sym_id);
1729 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1730 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1731 ctx->curr_exp = app;
1732 } else {
1733 ctx->app_cont = true1;
1734 }
1735#else
1736 ctx->app_cont = true1;
1737#endif
1738}
1739
1740// (if cond-expr then-expr else-expr)
1741static void eval_if(eval_context_t *ctx) {
1742 lbm_value cdr = get_cdr(ctx->curr_exp);
1743 lbm_value *sptr = stack_reserve(ctx, 3);
1744 sptr[0] = get_cdr(cdr);
1745 sptr[1] = ctx->curr_env;
1746 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1747 ctx->curr_exp = get_car(cdr);
1748}
1749
1750// (cond (cond-expr-1 expr-1)
1751// ...
1752// (cond-expr-N expr-N))
1753static void eval_cond(eval_context_t *ctx) {
1754 lbm_value cond1[2];
1755 lbm_value rest_conds = extract_n(ctx->curr_exp, cond1, 2);
1756
1757 // end recursion at (cond )
1758 if (lbm_is_symbol_nil(cond1[1])) {
1759 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1760 ctx->app_cont = true1;
1761 } else {
1762 // Cond is one of the few places where a bit of syntax checking takes place at runtime..
1763 // Maybe dont bother?
1764 lbm_uint len = lbm_list_length(cond1[1]);
1765 if (len != 2) {
1766 lbm_set_error_reason("Incorrect syntax in cond");
1767 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1768 }
1769 lbm_value cond_expr[2];
1770 extract_n(cond1[1], cond_expr, 2);
1771 lbm_value rest;
1772 WITH_GC(rest, lbm_heap_allocate_list_init(2,(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1773 cond_expr[1], // Then branch(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1774 cons_with_gc(ENC_SYM_COND, rest_conds , ENC_SYM_NIL)))(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
1775 lbm_value *sptr = stack_reserve(ctx, 3);
1776 sptr[0] = rest;
1777 sptr[1] = ctx->curr_env;
1778 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1779 ctx->curr_exp = cond_expr[0]; //condition;
1780 }
1781}
1782
1783static void eval_app_cont(eval_context_t *ctx) {
1784 lbm_stack_drop(&ctx->K, 1);
1785 ctx->app_cont = true1;
1786}
1787
1788// Create a named location in an environment to later receive a value.
1789static binding_location_status create_binding_location_internal(lbm_value key, lbm_value *env) {
1790
1791 if (lbm_is_symbol(key) &&
1792 (key == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u) ||
1793 key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)))
1794 return BL_OK;
1795
1796 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) { // default case
1797 lbm_value binding;
1798 lbm_value new_env_tmp;
1799 binding = lbm_cons(key, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1800 new_env_tmp = lbm_cons(binding, *env);
1801 if (lbm_is_symbol(binding) || lbm_is_symbol(new_env_tmp)) {
1802 return BL_NO_MEMORY;
1803 }
1804 *env = new_env_tmp;
1805 } else if (lbm_is_cons(key)) { // deconstruct case
1806 int r = create_binding_location_internal(get_car(key), env);
1807 if (r == BL_OK) {
1808 r = create_binding_location_internal(get_cdr(key), env);
1809 }
1810 return r;
1811 }
1812 return BL_OK;
1813}
1814
1815static void create_binding_location(lbm_value key, lbm_value *env) {
1816
1817 lbm_value env_tmp = *env;
1818 binding_location_status r = create_binding_location_internal(key, &env_tmp);
1819 if (r != BL_OK) {
1820 if (r == BL_NO_MEMORY) {
1821 env_tmp = *env;
1822 lbm_gc_mark_phase(env_tmp);
1823 gc();
1824 r = create_binding_location_internal(key, &env_tmp);
1825 }
1826 switch(r) {
1827 case BL_OK:
1828 break;
1829 case BL_NO_MEMORY:
1830 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1831 break;
1832 case BL_INCORRECT_KEY:
1833 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
1834 break;
1835 }
1836 }
1837 *env = env_tmp;
1838}
1839
1840static void let_bind_values_eval(lbm_value binds, lbm_value exp, lbm_value env, eval_context_t *ctx) {
1841
1842 if (!lbm_is_cons(binds)) {
1843 // binds better be nil or there is a programmer error.
1844 ctx->curr_exp = exp;
1845 return;
1846 }
1847
1848 // Preallocate binding locations.
1849 lbm_value curr = binds;
1850 while (lbm_is_cons(curr)) {
1851 lbm_value new_env_tmp = env;
1852 lbm_value car_curr, cdr_curr;
1853 get_car_and_cdr(curr, &car_curr, &cdr_curr);
1854 lbm_value key = get_car(car_curr);
1855 create_binding_location(key, &new_env_tmp);
1856 env = new_env_tmp;
1857 curr = cdr_curr;
1858 }
1859
1860 lbm_value car_binds;
1861 lbm_value cdr_binds;
1862 get_car_and_cdr(binds, &car_binds, &cdr_binds);
1863 lbm_value key_val[2];
1864 extract_n(car_binds, key_val, 2);
1865
1866 lbm_uint *sptr = stack_reserve(ctx, 5);
1867 sptr[0] = exp;
1868 sptr[1] = cdr_binds;
1869 sptr[2] = env;
1870 sptr[3] = key_val[0];
1871 sptr[4] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
1872 ctx->curr_exp = key_val[1];
1873 ctx->curr_env = env;
1874}
1875
1876// (var x (...)) - local binding inside of an progn
1877// var has to take, place root-level nesting within progn.
1878// (progn ... (var a 10) ...) OK!
1879// (progn ... (something (var a 10)) ... ) NOT OK!
1880/* progn stack
1881 sp-4 : env
1882 sp-3 : 0
1883 sp-2 : rest
1884 sp-1 : PROGN_REST
1885*/
1886static void eval_var(eval_context_t *ctx) {
1887
1888 if (ctx->K.sp >= 4) { // Possibly in progn
1889 lbm_value sv = ctx->K.data[ctx->K.sp - 1];
1890 if (IS_CONTINUATION(sv)(((sv) & 0xF8000001u) == 0xF8000001u) && (sv == PROGN_REST(((4) << 2) | 0xF8000001u))) {
1891 lbm_uint sp = ctx->K.sp;
1892 uint32_t is_copied = lbm_dec_as_u32(ctx->K.data[sp-3]);
1893 if (is_copied == 0) {
1894 lbm_value env;
1895 WITH_GC(env, lbm_env_copy_spine(ctx->K.data[sp-4]))(env) = (lbm_env_copy_spine(ctx->K.data[sp-4])); if (lbm_is_symbol_merror
((env))) { gc(); (env) = (lbm_env_copy_spine(ctx->K.data[sp
-4])); if (lbm_is_symbol_merror((env))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1896 ctx->K.data[sp-3] = lbm_enc_u(1);
1897 ctx->K.data[sp-4] = env;
1898 }
1899 lbm_value new_env = ctx->K.data[sp-4];
1900 lbm_value args = get_cdr(ctx->curr_exp);
1901 lbm_value key = get_car(args);
1902 create_binding_location(key, &new_env);
1903 ctx->K.data[sp-4] = new_env;
1904
1905 lbm_value v_exp = get_cadr(args);
1906 lbm_value *sptr = stack_reserve(ctx, 3);
1907 sptr[0] = new_env;
1908 sptr[1] = key;
1909 sptr[2] = PROGN_VAR(((29) << 2) | 0xF8000001u);
1910 // Activating the new environment before the evaluation of the value to be bound,
1911 // means that other variables with same name will be shadowed already in the value
1912 // body.
1913 // The way closures work, the var-variable needs to be in scope during val evaluation
1914 // for a recursive closure to be possible.
1915 ctx->curr_env = new_env;
1916 ctx->curr_exp = v_exp;
1917 return;
1918 }
1919 }
1920 lbm_set_error_reason((char*)lbm_error_str_var_outside_progn);
1921 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1922}
1923
1924// (setq x (...)) - same as (set 'x (...)) or (setvar 'x (...))
1925static void eval_setq(eval_context_t *ctx) {
1926 lbm_value parts[3];
1927 extract_n(ctx->curr_exp, parts, 3);
1928 lbm_value *sptr = stack_reserve(ctx, 3);
1929 sptr[0] = ctx->curr_env;
1930 sptr[1] = parts[1];
1931 sptr[2] = SETQ(((30) << 2) | 0xF8000001u);
1932 ctx->curr_exp = parts[2];
1933}
1934
1935static void eval_move_to_flash(eval_context_t *ctx) {
1936 lbm_value args = get_cdr(ctx->curr_exp);
1937 lbm_value *sptr = stack_reserve(ctx,2);
1938 sptr[0] = args;
1939 sptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
1940 ctx->app_cont = true1;
1941}
1942
1943// (loop list-of-local-bindings
1944// condition-exp
1945// body-exp)
1946static void eval_loop(eval_context_t *ctx) {
1947 lbm_value env = ctx->curr_env;
1948 lbm_value parts[3];
1949 extract_n(get_cdr(ctx->curr_exp), parts, 3);
1950 lbm_value *sptr = stack_reserve(ctx, 3);
1951 sptr[0] = parts[LOOP_BODY2];
1952 sptr[1] = parts[LOOP_COND1];
1953 sptr[2] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
1954 let_bind_values_eval(parts[LOOP_BINDS0], parts[LOOP_COND1], env, ctx);
1955}
1956
1957/* (trap expression)
1958 *
1959 * suggested use:
1960 * (match (trap expression)
1961 * ((exit-error (? err)) (error-handler err))
1962 * ((exit-ok (? v)) (value-handler v)))
1963 */
1964static void eval_trap(eval_context_t *ctx) {
1965
1966 lbm_value expr = get_cadr(ctx->curr_exp);
1967 lbm_value retval;
1968 WITH_GC(retval, lbm_heap_allocate_list(2))(retval) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((retval))) { gc(); (retval) = (lbm_heap_allocate_list(2)); if
(lbm_is_symbol_merror((retval))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1969 lbm_set_car(retval, ENC_SYM_EXIT_OK(((0x3000B) << 4) | 0x00000000u)); // Assume things will go well.
1970 lbm_uint *sptr = stack_reserve(ctx,3);
1971 sptr[0] = retval;
1972 sptr[1] = ctx->flags;
1973 sptr[2] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1974 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10;
1975 ctx->curr_exp = expr;
1976}
1977
1978// (let list-of-binding s
1979// body-exp)
1980static void eval_let(eval_context_t *ctx) {
1981 lbm_value env = ctx->curr_env;
1982 lbm_value parts[3];
1983 extract_n(ctx->curr_exp, parts, 3);
1984 let_bind_values_eval(parts[1], parts[2], env, ctx);
1985}
1986
1987// (and exp0 ... expN)
1988static void eval_and(eval_context_t *ctx) {
1989 lbm_value rest = get_cdr(ctx->curr_exp);
1990 if (lbm_is_symbol_nil(rest)) {
1991 ctx->app_cont = true1;
1992 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1993 } else {
1994 lbm_value *sptr = stack_reserve(ctx, 3);
1995 sptr[0] = ctx->curr_env;
1996 sptr[1] = get_cdr(rest);
1997 sptr[2] = AND(((6) << 2) | 0xF8000001u);
1998 ctx->curr_exp = get_car(rest);
1999 }
2000}
2001
2002// (or exp0 ... expN)
2003static void eval_or(eval_context_t *ctx) {
2004 lbm_value rest = get_cdr(ctx->curr_exp);
2005 if (lbm_is_symbol_nil(rest)) {
2006 ctx->app_cont = true1;
2007 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2008 } else {
2009 lbm_value *sptr = stack_reserve(ctx, 3);
2010 sptr[0] = ctx->curr_env;
2011 sptr[1] = get_cdr(rest);
2012 sptr[2] = OR(((7) << 2) | 0xF8000001u);
2013 ctx->curr_exp = get_car(rest);
2014 }
2015}
2016
2017// Pattern matching
2018// format:
2019// (match e (pattern body)
2020// (pattern body)
2021// ... )
2022//
2023// There can be an optional pattern guard:
2024// (match e (pattern guard body)
2025// ... )
2026// a guard is a boolean expression.
2027// Guards make match, pattern matching more complicated
2028// than the recv pattern matching and requires staged execution
2029// via the continuation system rather than a while loop over a list.
2030static void eval_match(eval_context_t *ctx) {
2031
2032 lbm_value rest = get_cdr(ctx->curr_exp);
2033 if (lbm_type_of(rest) == LBM_TYPE_SYMBOL0x00000000u &&
2034 rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
2035 // Someone wrote the program (match)
2036 ctx->app_cont = true1;
2037 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2038 } else {
2039 lbm_value cdr_rest;
2040 get_car_and_cdr(rest, &ctx->curr_exp, &cdr_rest);
2041 lbm_value *sptr = stack_reserve(ctx, 3);
2042 sptr[0] = cdr_rest;
2043 sptr[1] = ctx->curr_env;
2044 sptr[2] = MATCH(((9) << 2) | 0xF8000001u);
2045 }
2046}
2047
2048static void receive_base(eval_context_t *ctx, lbm_value pats, float timeout_time, bool_Bool timeout) {
2049 if (ctx->num_mail == 0) {
2050 if (timeout) {
2051 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000), false0);
2052 } else {
2053 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1,0,false0);
2054 }
2055 } else {
2056 lbm_value *msgs = ctx->mailbox;
2057 lbm_uint num = ctx->num_mail;
2058
2059 if (lbm_is_symbol_nil(pats)) {
2060 /* A receive statement without any patterns */
2061 ctx->app_cont = true1;
2062 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2063 } else {
2064 /* The common case */
2065 lbm_value e;
2066 lbm_value new_env = ctx->curr_env;
2067 int n = find_match(pats, msgs, num, &e, &new_env);
2068 if (n == FM_NEED_GC-1) {
2069 gc();
2070 new_env = ctx->curr_env;
2071 n = find_match(pats, msgs, num, &e, &new_env);
2072 if (n == FM_NEED_GC-1) {
2073 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2074 }
2075 }
2076 if (n == FM_PATTERN_ERROR-3) {
2077 lbm_set_error_reason("Incorrect pattern format for recv");
2078 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),pats);
2079 } else if (n >= 0 ) { /* Match */
2080 mailbox_remove_mail(ctx, (lbm_uint)n);
2081 ctx->curr_env = new_env;
2082 ctx->curr_exp = e;
2083 } else { /* No match go back to sleep */
2084 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
2085 if (timeout) {
2086 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2,S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000),false0);
2087 } else {
2088 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,false0);
2089 }
2090 }
2091 }
2092 }
2093 return;
2094}
2095
2096static void eval_receive_timeout(eval_context_t *ctx) {
2097 if (is_atomic) {
2098 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2099 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2100 }
2101 lbm_value timeout_val = get_cadr(ctx->curr_exp);
2102 if (!lbm_is_number(timeout_val)) {
2103 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2104 }
2105 float timeout_time = lbm_dec_as_float(timeout_val);
2106 lbm_value pats = get_cdr(get_cdr(ctx->curr_exp));
2107 receive_base(ctx, pats, timeout_time, true1);
2108}
2109
2110// Receive
2111// (recv (pattern expr)
2112// (pattern expr))
2113static void eval_receive(eval_context_t *ctx) {
2114
2115 if (is_atomic) {
2116 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2117 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
2118 }
2119 lbm_value pats = get_cdr(ctx->curr_exp);
2120 receive_base(ctx, pats, 0, false0);
2121}
2122
2123/*********************************************************/
2124/* Continuation functions */
2125
2126/* cont_set_global_env
2127 sp-1 : Key-symbol
2128 */
2129static void cont_set_global_env(eval_context_t *ctx){
2130
2131 lbm_value key;
2132 lbm_value val = ctx->r;
2133
2134 lbm_pop(&ctx->K, &key);
2135 lbm_uint dec_key = lbm_dec_sym(key);
2136 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
2137 lbm_value *global_env = lbm_get_global_env();
2138 lbm_uint orig_env = global_env[ix_key];
2139 lbm_value new_env;
2140 // A key is a symbol and should not need to be remembered.
2141 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2142
2143 global_env[ix_key] = new_env;
2144 ctx->r = val;
2145
2146 ctx->app_cont = true1;
2147
2148 return;
2149}
2150
2151static void cont_resume(eval_context_t *ctx) {
2152 lbm_pop_2(&ctx->K, &ctx->curr_env, &ctx->curr_exp);
2153}
2154
2155static void cont_progn_rest(eval_context_t *ctx) {
2156 lbm_value *sptr = get_stack_ptr(ctx, 3);
2157
2158 lbm_value rest = sptr[2];
2159 lbm_value env = sptr[0];
2160
2161 lbm_value rest_car, rest_cdr;
2162 get_car_and_cdr(rest, &rest_car, &rest_cdr);
2163 ctx->curr_exp = rest_car;
2164 ctx->curr_env = env;
2165 if (lbm_is_symbol_nil(rest_cdr)) {
2166 // allow for tail recursion
2167 lbm_stack_drop(&ctx->K, 3);
2168 } else {
2169 sptr[2] = rest_cdr;
2170 stack_reserve(ctx, 1)[0] = PROGN_REST(((4) << 2) | 0xF8000001u);
2171 }
2172}
2173
2174static void cont_wait(eval_context_t *ctx) {
2175
2176 lbm_value cid_val;
2177 lbm_pop(&ctx->K, &cid_val);
2178 lbm_cid cid = (lbm_cid)lbm_dec_i(cid_val);
2179
2180 bool_Bool exists = false0;
2181
2182 lbm_blocked_iterator(context_exists, &cid, &exists);
2183 lbm_running_iterator(context_exists, &cid, &exists);
2184
2185 if (ctx_running->id == cid) {
2186 exists = true1;
2187 }
2188
2189 if (exists) {
2190 lbm_value *sptr = stack_reserve(ctx, 2);
2191 sptr[0] = lbm_enc_i(cid);
2192 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2193 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2194 ctx->app_cont = true1;
2195 yield_ctx(50000);
2196 } else {
2197 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2198 ctx->app_cont = true1;
2199 }
2200}
2201
2202static lbm_value perform_setvar(lbm_value key, lbm_value val, lbm_value env) {
2203
2204 lbm_uint s = lbm_dec_sym(key);
2205 if (s >= RUNTIME_SYMBOLS_START0x40000) {
2206 lbm_value new_env = lbm_env_modify_binding(env, key, val);
2207 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2208 lbm_uint ix_key = lbm_dec_sym(key) & GLOBAL_ENV_MASK0x1F;
2209 lbm_value *glob_env = lbm_get_global_env();
2210 new_env = lbm_env_modify_binding(glob_env[ix_key], key, val);
2211 glob_env[ix_key] = new_env;
2212 }
2213 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2214 lbm_set_error_reason((char*)lbm_error_str_variable_not_bound);
2215 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), key);
2216 }
2217 return val;
2218 }
2219 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2220 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // unreachable
2221}
2222
2223static void apply_setvar(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2224 if (nargs == 2 && lbm_is_symbol(args[0])) {
2225 lbm_value res;
2226 WITH_GC(res, perform_setvar(args[0], args[1], ctx->curr_env))(res) = (perform_setvar(args[0], args[1], ctx->curr_env));
if (lbm_is_symbol_merror((res))) { gc(); (res) = (perform_setvar
(args[0], args[1], ctx->curr_env)); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2227 ctx->r = args[1];
2228 lbm_stack_drop(&ctx->K, nargs+1);
2229 ctx->app_cont = true1;
2230 } else {
2231 if (nargs == 2) lbm_set_error_reason((char*)lbm_error_str_incorrect_arg);
2232 else lbm_set_error_reason((char*)lbm_error_str_num_args);
2233 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2234 }
2235}
2236
2237static void apply_read_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, bool_Bool program, bool_Bool incremental) {
2238 if (nargs == 1) {
2239 lbm_value chan = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2240 if (lbm_type_of_functional(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2241 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2242 gc();
2243 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2244 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2245 }
2246 }
2247 } else if (lbm_type_of(args[0]) == LBM_TYPE_CHANNEL0x90000000u) {
2248 chan = args[0];
2249 } else {
2250 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2251 }
2252 lbm_value *sptr = get_stack_ptr(ctx, 2);
2253
2254 // If we are inside a reader, its settings are stored.
2255 sptr[0] = lbm_enc_u(ctx->flags); // flags stored.
2256 sptr[1] = chan;
2257 lbm_value *rptr = stack_reserve(ctx,1);
2258 rptr[0] = READ_DONE(((20) << 2) | 0xF8000001u);
2259
2260 // Each reader starts in a fresh situation
2261 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
2262
2263 if (program) {
2264 if (incremental) {
2265 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2266 lbm_value *rptr1 = stack_reserve(ctx,3);
2267 rptr1[0] = chan;
2268 rptr1[1] = ctx->curr_env;
2269 rptr1[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
2270 } else {
2271 ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2272 lbm_value *rptr1 = stack_reserve(ctx,4);
2273 rptr1[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2274 rptr1[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2275 rptr1[2] = chan;
2276 rptr1[3] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
2277 }
2278 }
2279 rptr = stack_reserve(ctx,3); // reuse of variable rptr
2280 rptr[0] = chan;
2281 rptr[1] = lbm_enc_u(1);
2282 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
2283 ctx->app_cont = true1;
2284 } else {
2285 lbm_set_error_reason((char*)lbm_error_str_num_args);
2286 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2287 }
2288}
2289
2290static void apply_read_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2291 apply_read_base(args,nargs,ctx,true1,false0);
2292}
2293
2294static void apply_read_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2295 apply_read_base(args,nargs,ctx,true1,true1);
2296}
2297
2298static void apply_read(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2299 apply_read_base(args,nargs,ctx,false0,false0);
2300}
2301
2302static void apply_spawn_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, uint32_t context_flags) {
2303
2304 lbm_uint stack_size = EVAL_CPS_DEFAULT_STACK_SIZE256;
2305 lbm_uint closure_pos = 0;
2306 char *name = NULL((void*)0);
2307
2308 if (nargs >= 1 &&
2309 lbm_is_closure(args[0])) {
2310 closure_pos = 0;
2311 } else if (nargs >= 2 &&
2312 lbm_is_number(args[0]) &&
2313 lbm_is_closure(args[1])) {
2314 stack_size = lbm_dec_as_u32(args[0]);
2315 closure_pos = 1;
2316 } else if (nargs >= 2 &&
2317 lbm_is_array_r(args[0]) &&
2318 lbm_is_closure(args[1])) {
2319 name = lbm_dec_str(args[0]);
2320 closure_pos = 1;
2321 }else if (nargs >= 3 &&
2322 lbm_is_array_r(args[0]) &&
2323 lbm_is_number(args[1]) &&
2324 lbm_is_closure(args[2])) {
2325 stack_size = lbm_dec_as_u32(args[1]);
2326 closure_pos = 2;
2327 name = lbm_dec_str(args[0]);
2328 } else {
2329 if (context_flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01)
2330 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN_TRAP(((0x30005) << 4) | 0x00000000u));
2331 else
2332 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN(((0x30004) << 4) | 0x00000000u));
2333 }
2334
2335 lbm_value cl[3];
2336 extract_n(get_cdr(args[closure_pos]), cl, 3);
2337 lbm_value curr_param = cl[CLO_PARAMS0];
2338 lbm_value clo_env = cl[CLO_ENV2];
2339 lbm_uint i = closure_pos + 1;
2340 while (lbm_is_cons(curr_param) && i <= nargs) {
2341 lbm_value entry = cons_with_gc(get_car(curr_param), args[i], clo_env);
2342 lbm_value aug_env = cons_with_gc(entry, clo_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2343 clo_env = aug_env;
2344 curr_param = get_cdr(curr_param);
2345 i ++;
2346 }
2347
2348 lbm_stack_drop(&ctx->K, nargs+1);
2349
2350 lbm_value program = cons_with_gc(cl[CLO_BODY1], ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), clo_env);
2351
2352 lbm_cid cid = lbm_create_ctx_parent(program,
2353 clo_env,
2354 stack_size,
2355 lbm_get_current_cid(),
2356 context_flags,
2357 name);
2358 ctx->r = lbm_enc_i(cid);
2359 ctx->app_cont = true1;
2360}
2361
2362static void apply_spawn(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2363 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00);
2364}
2365
2366static void apply_spawn_trap(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2367 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01);
2368}
2369
2370static void apply_yield(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2371 if (is_atomic) {
2372 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2373 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2374 }
2375 if (nargs == 1 && lbm_is_number(args[0])) {
2376 lbm_uint ts = lbm_dec_as_u32(args[0]);
2377 lbm_stack_drop(&ctx->K, nargs+1);
2378 yield_ctx(ts);
2379 } else {
2380 lbm_set_error_reason((char*)lbm_error_str_no_number);
2381 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2382 }
2383}
2384
2385static void apply_sleep(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2386 if (is_atomic) {
2387 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2388 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2389 }
2390 if (nargs == 1 && lbm_is_number(args[0])) {
2391 lbm_uint ts = (lbm_uint)(1000000.0f * lbm_dec_as_float(args[0]));
2392 lbm_stack_drop(&ctx->K, nargs+1);
2393 yield_ctx(ts);
2394 } else {
2395 lbm_set_error_reason((char*)lbm_error_str_no_number);
2396 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2397 }
2398}
2399
2400static void apply_wait(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2401 if (nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2402 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2403 lbm_value *sptr = get_stack_ptr(ctx, 2);
2404 sptr[0] = lbm_enc_i(cid);
2405 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2406 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2407 ctx->app_cont = true1;
2408 yield_ctx(50000);
2409 } else {
2410 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_WAIT(((0x30007) << 4) | 0x00000000u));
2411 }
2412}
2413
2414/* (eval expr)
2415 (eval env expr) */
2416static void apply_eval(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2417 if ( nargs == 1) {
2418 ctx->curr_exp = args[0];
2419 } else if (nargs == 2) {
2420 ctx->curr_exp = args[1];
2421 ctx->curr_env = args[0];
2422 } else {
2423 lbm_set_error_reason((char*)lbm_error_str_num_args);
2424 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL(((0x30008) << 4) | 0x00000000u));
2425 }
2426 lbm_stack_drop(&ctx->K, nargs+1);
2427}
2428
2429static void apply_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2430 int prg_pos = 0;
2431 if (nargs == 2) {
2432 prg_pos = 1;
2433 ctx->curr_env = args[0];
2434 }
2435 if (nargs == 1 || nargs == 2) {
2436 lbm_value prg = args[prg_pos];
2437 lbm_value app_cont;
2438 lbm_value app_cont_prg;
2439 lbm_value new_prg;
2440 lbm_value prg_copy;
2441
2442 int len = -1;
2443 WITH_GC(prg_copy, lbm_list_copy(&len, prg))(prg_copy) = (lbm_list_copy(&len, prg)); if (lbm_is_symbol_merror
((prg_copy))) { gc(); (prg_copy) = (lbm_list_copy(&len, prg
)); if (lbm_is_symbol_merror((prg_copy))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2444 lbm_stack_drop(&ctx->K, nargs+1);
2445
2446 if (ctx->K.sp > nargs+2) { // if there is a continuation
2447 app_cont = cons_with_gc(ENC_SYM_APP_CONT(((0x111) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2448 app_cont_prg = cons_with_gc(app_cont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2449 new_prg = lbm_list_append(app_cont_prg, ctx->program);
2450 new_prg = lbm_list_append(prg_copy, new_prg);
2451 } else {
2452 new_prg = lbm_list_append(prg_copy, ctx->program);
2453 }
2454 if (!lbm_is_list(new_prg)) {
2455 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2456 }
2457 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);
2458 ctx->program = get_cdr(new_prg);
2459 ctx->curr_exp = get_car(new_prg);
2460 } else {
2461 lbm_set_error_reason((char*)lbm_error_str_num_args);
2462 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2463 }
2464}
2465
2466static void apply_send(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2467 if (nargs == 2) {
2468 if (lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2469 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2470 lbm_value msg = args[1];
2471 lbm_value status = lbm_find_receiver_and_send(cid, msg);
2472 /* return the status */
2473 lbm_stack_drop(&ctx->K, nargs+1);
2474 ctx->r = status;
2475 ctx->app_cont = true1;
2476 } else {
2477 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2478 }
2479 } else {
2480 lbm_set_error_reason((char*)lbm_error_str_num_args);
2481 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2482 }
2483}
2484
2485static void apply_ok(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2486 lbm_value ok_val = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2487 if (nargs >= 1) {
2488 ok_val = args[0];
2489 }
2490 ctx->r = ok_val;
2491 ok_ctx();
2492}
2493
2494static void apply_error(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2495 (void) ctx;
2496 lbm_value err_val = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
2497 if (nargs >= 1) {
2498 err_val = args[0];
2499 }
2500 error_at_ctx(err_val, ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
2501}
2502
2503// (map f arg-list)
2504static void apply_map(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2505 if (nargs == 2 && lbm_is_cons(args[1])) {
2506 lbm_value *sptr = get_stack_ptr(ctx, 3);
2507
2508 lbm_value f = args[0];
2509 lbm_value h = get_car(args[1]);
2510 lbm_value t = get_cdr(args[1]);
2511
2512 lbm_value appli_1;
2513 lbm_value appli;
2514 WITH_GC(appli_1, lbm_heap_allocate_list(2))(appli_1) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli_1))) { gc(); (appli_1) = (lbm_heap_allocate_list(2));
if (lbm_is_symbol_merror((appli_1))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2515 WITH_GC_RMBR_1(appli, lbm_heap_allocate_list(2), appli_1)(appli) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli))) { lbm_gc_mark_phase(appli_1); gc(); (appli) = (lbm_heap_allocate_list
(2)); if (lbm_is_symbol_merror((appli))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2516
2517 lbm_value appli_0 = get_cdr(appli_1);
2518
2519 lbm_set_car_and_cdr(appli_0, h, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2520 lbm_set_car(appli_1, ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u));
2521
2522 lbm_set_car_and_cdr(get_cdr(appli), appli_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2523 lbm_set_car(appli, f);
2524
2525 lbm_value elt = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), appli);
2526 sptr[0] = t; // reuse stack space
2527 sptr[1] = ctx->curr_env;
2528 sptr[2] = elt;
2529 lbm_value *rptr = stack_reserve(ctx,4);
2530 rptr[0] = elt;
2531 rptr[1] = appli;
2532 rptr[2] = appli_0;
2533 rptr[3] = MAP(((26) << 2) | 0xF8000001u);
2534 ctx->curr_exp = appli;
2535 } else if (nargs == 2 && lbm_is_symbol_nil(args[1])) {
2536 lbm_stack_drop(&ctx->K, 3);
2537 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2538 ctx->app_cont = true1;
2539 return;
2540 } else {
2541 lbm_set_error_reason((char*)lbm_error_str_num_args);
2542 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_MAP(((0x3000D) << 4) | 0x00000000u));
2543 }
2544}
2545
2546static void apply_reverse(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2547 if (nargs == 1 && lbm_is_list(args[0])) {
2548 lbm_value curr = args[0];
2549
2550 lbm_value new_list = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2551 while (lbm_is_cons(curr)) {
2552 lbm_value tmp = cons_with_gc(get_car(curr), new_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2553 new_list = tmp;
2554 curr = get_cdr(curr);
2555 }
2556 lbm_stack_drop(&ctx->K, 2);
2557 ctx->r = new_list;
2558 ctx->app_cont = true1;
2559 } else {
2560 lbm_set_error_reason("Reverse requires a list argument");
2561 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_REVERSE(((0x3000E) << 4) | 0x00000000u));
2562 }
2563}
2564
2565static void apply_flatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2566 if (nargs == 1) {
2567
2568 lbm_value v = flatten_value(args[0]);
2569 if ( v == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)) {
2570 gc();
2571 v = flatten_value(args[0]);
2572 }
2573
2574 if (lbm_is_symbol(v)) {
2575 error_at_ctx(v, ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2576 } else {
2577 lbm_stack_drop(&ctx->K, 2);
2578 ctx->r = v;
2579 ctx->app_cont = true1;
2580 }
2581 return;
2582 }
2583 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2584}
2585
2586static void apply_unflatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2587 if(nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2588 lbm_array_header_t *array;
2589 array = (lbm_array_header_t *)get_car(args[0]);
2590
2591 lbm_flat_value_t fv;
2592 fv.buf = (uint8_t*)array->data;
2593 fv.buf_size = array->size;
2594 fv.buf_pos = 0;
2595
2596 lbm_value res;
2597
2598 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2599 if (lbm_unflatten_value(&fv, &res)) {
2600 ctx->r = res;
2601 }
2602 lbm_stack_drop(&ctx->K, 2);
2603 ctx->app_cont = true1;
2604 return;
2605 }
2606 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_UNFLATTEN(((0x30010) << 4) | 0x00000000u));
2607}
2608
2609static void apply_kill(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2610 if (nargs == 2 && lbm_is_number(args[0])) {
2611 lbm_cid cid = lbm_dec_as_i32(args[0]);
2612
2613 if (ctx->id == cid) {
2614 ctx->r = args[1];
2615 finish_ctx();
2616 return;
2617 }
2618 mutex_lock(&qmutex);
2619 eval_context_t *found = NULL((void*)0);
2620 found = lookup_ctx_nm(&blocked, cid);
2621 if (found)
2622 drop_ctx_nm(&blocked, found);
2623 else
2624 found = lookup_ctx_nm(&queue, cid);
2625 if (found)
2626 drop_ctx_nm(&queue, found);
2627
2628 if (found) {
2629 found->K.data[found->K.sp - 1] = KILL(((40) << 2) | 0xF8000001u);
2630 found->r = args[1];
2631 found->app_cont = true1;
2632 enqueue_ctx_nm(&queue,found);
2633 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2634 } else {
2635 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2636 }
2637 lbm_stack_drop(&ctx->K, 3);
2638 ctx->app_cont = true1;
2639 mutex_unlock(&qmutex);
2640 return;
2641 }
2642 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_KILL(((0x30011) << 4) | 0x00000000u));
2643}
2644
2645// (merge comparator list1 list2)
2646static void apply_merge(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2647 if (nargs == 3 && lbm_is_list(args[1]) && lbm_is_list(args[2])) {
2648
2649 if (!lbm_is_closure(args[0])) {
2650 lbm_value closure;
2651 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2652 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2653 lbm_value cl1 = lbm_cdr(closure);
2654 lbm_value par;
2655 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2656 lbm_set_car(cl1, par);
2657 lbm_value cl2 = lbm_cdr(cl1);
2658 lbm_value body;
2659 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2660 lbm_set_car(cl2, body);
2661 lbm_value cl3 = lbm_cdr(cl2);
2662 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2663
2664 // Replace operator on stack with closure and rest of the code is
2665 // compatible.
2666 args[0] = closure;
2667 }
2668
2669 // Copy input lists for functional behaviour at top-level
2670 // merge itself is in-place in the copied lists.
2671 lbm_value a;
2672 lbm_value b;
2673 int len_a = -1;
2674 int len_b = -1;
2675 WITH_GC(a, lbm_list_copy(&len_a, args[1]))(a) = (lbm_list_copy(&len_a, args[1])); if (lbm_is_symbol_merror
((a))) { gc(); (a) = (lbm_list_copy(&len_a, args[1])); if
(lbm_is_symbol_merror((a))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } };
2676 WITH_GC_RMBR_1(b, lbm_list_copy(&len_b, args[2]), a)(b) = (lbm_list_copy(&len_b, args[2])); if (lbm_is_symbol_merror
((b))) { lbm_gc_mark_phase(a); gc(); (b) = (lbm_list_copy(&
len_b, args[2])); if (lbm_is_symbol_merror((b))) { error_ctx(
(((0x23) << 4) | 0x00000000u)); } };
2677
2678 if (len_a == 0) {
2679 ctx->r = b;
2680 lbm_stack_drop(&ctx->K, 4);
2681 ctx->app_cont = true1;
2682 return;
2683 }
2684 if (len_b == 0) {
2685 ctx->r = a;
2686 lbm_stack_drop(&ctx->K, 4);
2687 ctx->app_cont = true1;
2688 return;
2689 }
2690
2691 args[1] = a; // keep safe by replacing the original on stack.
2692 args[2] = b;
2693
2694 lbm_value a_1 = a;
2695 lbm_value a_rest = lbm_cdr(a);
2696 lbm_value b_1 = b;
2697 lbm_value b_rest = lbm_cdr(b);
2698
2699 lbm_value cl[3]; // Comparator closure
2700 extract_n(lbm_cdr(args[0]), cl, 3);
2701 lbm_value cmp_env = cl[CLO_ENV2];
2702 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2703 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2704 lbm_uint len = lbm_list_length(cl[CLO_PARAMS0]);
2705 if (len == 2) {
2706 par1 = get_car(cl[CLO_PARAMS0]);
2707 par2 = get_cadr(cl[CLO_PARAMS0]);
2708 lbm_value new_env0;
2709 lbm_value new_env;
2710 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a_1)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a_1))); if (
lbm_is_symbol_merror((new_env0))) { gc(); (new_env0) = (lbm_env_set
(cmp_env, par1, lbm_car(a_1))); if (lbm_is_symbol_merror((new_env0
))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2711 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b_1)),new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1))); if (
lbm_is_symbol_merror((new_env))) { lbm_gc_mark_phase(new_env0
); gc(); (new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1
))); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2712 cmp_env = new_env;
2713 } else {
2714 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2715 }
2716 lbm_set_cdr(a_1, b_1);
2717 lbm_set_cdr(b_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2718 lbm_value cmp = cl[CLO_BODY1];
2719
2720 lbm_stack_drop(&ctx->K, 4); // TODO: Optimize drop 4 alloc 10 into alloc 6
2721 lbm_uint *sptr = stack_reserve(ctx, 10);
2722 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged list
2723 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged list
2724 sptr[2] = a_1;
2725 sptr[3] = a_rest;
2726 sptr[4] = b_rest;
2727 sptr[5] = cmp;
2728 sptr[6] = cmp_env;
2729 sptr[7] = par1;
2730 sptr[8] = par2;
2731 sptr[9] = MERGE_REST(((43) << 2) | 0xF8000001u);
2732 ctx->curr_exp = cl[CLO_BODY1];
2733 ctx->curr_env = cmp_env;
2734 return;
2735 }
2736 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MERGE(((0x30013) << 4) | 0x00000000u));
2737}
2738
2739// (sort comparator list)
2740static void apply_sort(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2741 if (nargs == 2 && lbm_is_list(args[1])) {
2742
2743 if (!lbm_is_closure(args[0])) {
2744 lbm_value closure;
2745 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2746 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2747 lbm_value cl1 = lbm_cdr(closure);
2748 lbm_value par;
2749 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2750 lbm_set_car(cl1, par);
2751 lbm_value cl2 = lbm_cdr(cl1);
2752 lbm_value body;
2753 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2754 lbm_set_car(cl2, body);
2755 lbm_value cl3 = lbm_cdr(cl2);
2756 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2757
2758 // Replace operator on stack with closure and rest of the code is
2759 // compatible.
2760 args[0] = closure;
2761 }
2762
2763 int len = -1;
2764 lbm_value list_copy;
2765 WITH_GC(list_copy, lbm_list_copy(&len, args[1]))(list_copy) = (lbm_list_copy(&len, args[1])); if (lbm_is_symbol_merror
((list_copy))) { gc(); (list_copy) = (lbm_list_copy(&len,
args[1])); if (lbm_is_symbol_merror((list_copy))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2766 if (len <= 1) {
2767 lbm_stack_drop(&ctx->K, 3);
2768 ctx->r = list_copy;
2769 ctx->app_cont = true1;
2770 return;
2771 }
2772
2773 args[1] = list_copy; // Keep safe, original replaced on stack.
2774
2775 // Take the headmost 2, 1-element sublists.
2776 lbm_value a = list_copy;
2777 lbm_value b = lbm_cdr(a);
2778 lbm_value rest = lbm_cdr(b);
2779 // Do not terminate b. keep rest of list safe from GC in the following
2780 // closure extraction.
2781 //lbm_set_cdr(a, b); // This is void
2782
2783 lbm_value cl[3]; // Comparator closure
2784 extract_n(lbm_cdr(args[0]), cl, 3);
2785 lbm_value cmp_env = cl[CLO_ENV2];
2786 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2787 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2788 lbm_uint cl_len = lbm_list_length(cl[CLO_PARAMS0]);
2789 if (cl_len == 2) {
2790 par1 = get_car(cl[CLO_PARAMS0]);
2791 par2 = get_cadr(cl[CLO_PARAMS0]);
2792 lbm_value new_env0;
2793 lbm_value new_env;
2794 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a))); if (lbm_is_symbol_merror
((new_env0))) { gc(); (new_env0) = (lbm_env_set(cmp_env, par1
, lbm_car(a))); if (lbm_is_symbol_merror((new_env0))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2795 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b)), new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { lbm_gc_mark_phase(new_env0); gc(); (new_env) =
(lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { error_ctx((((0x23) << 4) | 0x00000000u))
; } };
2796 cmp_env = new_env;
2797 } else {
2798 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2799 }
2800 lbm_value cmp = cl[CLO_BODY1];
2801
2802 // Terminate the comparator argument list.
2803 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2804
2805 lbm_stack_drop(&ctx->K, 3); //TODO: optimize drop 3, alloc 20 into alloc 17
2806 lbm_uint *sptr = stack_reserve(ctx, 20);
2807 sptr[0] = cmp;
2808 sptr[1] = cmp_env;
2809 sptr[2] = par1;
2810 sptr[3] = par2;
2811 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged accumulation of sublists
2812 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged accumulation of sublists
2813 sptr[6] = rest;
2814 sptr[7] = lbm_enc_i(1);
2815 sptr[8] = lbm_enc_i(len); //TODO: 28 bit i vs 32 bit i
2816 sptr[9] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
2817 sptr[10] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged sublist
2818 sptr[11] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged sublist
2819 sptr[12] = a;
2820 sptr[13] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no a_rest, 1 element lists in layer 1.
2821 sptr[14] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no b_rest, 1 element lists in layer 1.
2822 sptr[15] = cmp;
2823 sptr[16] = cmp_env;
2824 sptr[17] = par1;
2825 sptr[18] = par2;
2826 sptr[19] = MERGE_REST(((43) << 2) | 0xF8000001u);
2827 ctx->curr_exp = cmp;
2828 ctx->curr_env = cmp_env;
2829 return;
2830 }
2831 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
2832}
2833
2834static void apply_rest_args(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2835 lbm_value res;
2836 if (lbm_env_lookup_b(&res, ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ctx->curr_env)) {
2837 if (nargs == 1 && lbm_is_number(args[0])) {
2838 int32_t ix = lbm_dec_as_i32(args[0]);
2839 res = lbm_index_list(res, ix);
2840 }
2841 ctx->r = res;
2842 } else {
2843 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2844 }
2845 lbm_stack_drop(&ctx->K, nargs+1);
2846 ctx->app_cont = true1;
2847}
2848
2849/* (rotate list-expr dist/dir-expr) */
2850static void apply_rotate(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2851 if (nargs == 2 && lbm_is_list(args[0]) && lbm_is_number(args[1])) {
2852 int len = -1;
2853 lbm_value ls = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2854 WITH_GC(ls, lbm_list_copy(&len, args[0]))(ls) = (lbm_list_copy(&len, args[0])); if (lbm_is_symbol_merror
((ls))) { gc(); (ls) = (lbm_list_copy(&len, args[0])); if
(lbm_is_symbol_merror((ls))) { error_ctx((((0x23) << 4
) | 0x00000000u)); } };
2855 int dist = lbm_dec_as_i32(args[1]);
2856 if (len > 0 && dist != 0) {
2857 int d = dist;
2858 if (dist > 0) {
2859 ls = lbm_list_destructive_reverse(ls);
2860 } else {
2861 d = -dist;
2862 }
2863
2864 lbm_value start = ls;
2865 lbm_value end = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2866 lbm_value curr = start;
2867 while (lbm_is_cons(curr)) {
2868 end = curr;
2869 curr = get_cdr(curr);
2870 }
2871
2872 for (int i = 0; i < d; i ++) {
2873 lbm_value a = start;
2874 start = lbm_cdr(start);
2875 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2876 lbm_set_cdr(end, a);
2877 end = a;
2878 }
2879 ls = start;
2880 if (dist > 0) {
2881 ls = lbm_list_destructive_reverse(ls);
2882 }
2883 }
2884 lbm_stack_drop(&ctx->K, nargs+1);
2885 ctx->app_cont = true1;
2886 ctx->r = ls;
2887 return;
2888 }
2889 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2890}
2891
2892/***************************************************/
2893/* Application lookup table */
2894
2895typedef void (*apply_fun)(lbm_value *, lbm_uint, eval_context_t *);
2896static const apply_fun fun_table[] =
2897 {
2898 apply_setvar,
2899 apply_read,
2900 apply_read_program,
2901 apply_read_eval_program,
2902 apply_spawn,
2903 apply_spawn_trap,
2904 apply_yield,
2905 apply_wait,
2906 apply_eval,
2907 apply_eval_program,
2908 apply_send,
2909 apply_ok,
2910 apply_error,
2911 apply_map,
2912 apply_reverse,
2913 apply_flatten,
2914 apply_unflatten,
2915 apply_kill,
2916 apply_sleep,
2917 apply_merge,
2918 apply_sort,
2919 apply_rest_args,
2920 apply_rotate,
2921 };
2922
2923/***************************************************/
2924/* Application of function that takes arguments */
2925/* passed over the stack. */
2926
2927static void application(eval_context_t *ctx, lbm_value *fun_args, lbm_uint arg_count) {
2928 /* If arriving here, we know that the fun is a symbol.
2929 * and can be a built in operation or an extension.
2930 */
2931 lbm_value fun = fun_args[0];
2932
2933 lbm_uint fun_val = lbm_dec_sym(fun);
2934 lbm_uint fun_kind = SYMBOL_KIND(fun_val)((fun_val) >> 16);
2935
2936 switch (fun_kind) {
2937 case SYMBOL_KIND_EXTENSION1: {
2938 extension_fptr f = extension_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)].fptr;
2939
2940 lbm_value ext_res;
2941 WITH_GC(ext_res, f(&fun_args[1], arg_count))(ext_res) = (f(&fun_args[1], arg_count)); if (lbm_is_symbol_merror
((ext_res))) { gc(); (ext_res) = (f(&fun_args[1], arg_count
)); if (lbm_is_symbol_merror((ext_res))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2942 if (lbm_is_error(ext_res)) { //Error other than merror
2943 error_at_ctx(ext_res, fun);
2944 }
2945 lbm_stack_drop(&ctx->K, arg_count + 1);
2946
2947 ctx->app_cont = true1;
2948 ctx->r = ext_res;
2949
2950 if (blocking_extension) {
2951 blocking_extension = false0;
2952 if (blocking_extension_timeout) {
2953 blocking_extension_timeout = false0;
2954 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, blocking_extension_timeout_us,true1);
2955 } else {
2956 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,true1);
2957 }
2958 mutex_unlock(&blocking_extension_mutex);
2959 }
2960 } break;
2961 case SYMBOL_KIND_FUNDAMENTAL2:
2962 call_fundamental(SYMBOL_IX(fun_val)((fun_val) & 0xFFFF), &fun_args[1], arg_count, ctx);
2963 break;
2964 case SYMBOL_KIND_APPFUN3:
2965 fun_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)](&fun_args[1], arg_count, ctx);
2966 break;
2967 default:
2968 // Symbols that are "special" but not in the way caught above
2969 // ends up here.
2970 lbm_set_error_reason("Symbol does not represent a function");
2971 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),fun_args[0]);
2972 break;
2973 }
2974}
2975
2976static void cont_closure_application_args(eval_context_t *ctx) {
2977 lbm_uint* sptr = get_stack_ptr(ctx, 5);
2978
2979 lbm_value arg_env = (lbm_value)sptr[0];
2980 lbm_value exp = (lbm_value)sptr[1];
2981 lbm_value clo_env = (lbm_value)sptr[2];
2982 lbm_value params = (lbm_value)sptr[3];
2983 lbm_value args = (lbm_value)sptr[4];
2984
2985 lbm_value car_params, cdr_params;
2986 get_car_and_cdr(params, &car_params, &cdr_params);
2987
2988 bool_Bool a_nil = lbm_is_symbol_nil(args);
2989 bool_Bool p_nil = lbm_is_symbol_nil(cdr_params);
2990
2991 lbm_value binder = allocate_binding(car_params, ctx->r, clo_env);
2992
2993 if (!a_nil && !p_nil) {
2994 lbm_value car_args, cdr_args;
2995 get_car_and_cdr(args, &car_args, &cdr_args);
2996 sptr[2] = binder;
2997 sptr[3] = cdr_params;
2998 sptr[4] = cdr_args;
2999 stack_reserve(ctx,1)[0] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
3000 ctx->curr_exp = car_args;
3001 ctx->curr_env = arg_env;
3002 } else if (a_nil && p_nil) {
3003 // Arguments and parameters match up in number
3004 lbm_stack_drop(&ctx->K, 5);
3005 ctx->curr_env = binder;
3006 ctx->curr_exp = exp;
3007 } else if (p_nil) {
3008 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), binder);
3009 sptr[2] = rest_binder;
3010 sptr[3] = get_cdr(args);
3011 sptr[4] = get_car(rest_binder); // last element of rest_args so far
3012 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3013 ctx->curr_exp = get_car(args);
3014 ctx->curr_env = arg_env;
3015 } else {
3016 lbm_set_error_reason((char*)lbm_error_str_num_args);
3017 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
3018 }
3019}
3020
3021
3022static void cont_closure_args_rest(eval_context_t *ctx) {
3023 lbm_uint* sptr = get_stack_ptr(ctx, 5);
3024 lbm_value arg_env = (lbm_value)sptr[0];
3025 lbm_value exp = (lbm_value)sptr[1];
3026 lbm_value clo_env = (lbm_value)sptr[2];
3027 lbm_value args = (lbm_value)sptr[3];
3028 lbm_value last = (lbm_value)sptr[4];
3029 lbm_cons_t* heap = lbm_heap_state.heap;
3030
3031 lbm_value binding = lbm_heap_state.freelist;
3032 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3033 gc();
3034 binding = lbm_heap_state.freelist;
3035 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3036 }
3037 lbm_uint binding_ix = lbm_dec_ptr(binding);
3038 lbm_heap_state.freelist = heap[binding_ix].cdr;
3039 lbm_heap_state.num_alloc += 1;
3040 heap[binding_ix].car = ctx->r;
3041 heap[binding_ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3042
3043
3044 lbm_set_cdr(last, binding);
3045 sptr[4] = binding;
3046
3047 if (args == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3048 lbm_stack_drop(&ctx->K, 5);
3049 ctx->curr_env = clo_env;
3050 ctx->curr_exp = exp;
3051 } else {
3052 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3053 sptr[3] = get_cdr(args);
3054 ctx->curr_exp = get_car(args);
3055 ctx->curr_env = arg_env;
3056 }
3057}
3058
3059static void cont_application_args(eval_context_t *ctx) {
3060 lbm_uint *sptr = get_stack_ptr(ctx, 3);
3061
3062 lbm_value env = sptr[0];
3063 lbm_value rest = sptr[1];
3064 lbm_value count = sptr[2];
3065
3066 ctx->curr_env = env;
3067 sptr[0] = ctx->r; // Function 1st then Arguments
3068 if (lbm_is_cons(rest)) {
3069 lbm_cons_t *cell = lbm_ref_cell(rest);
3070 sptr[1] = env;
3071 sptr[2] = cell->cdr;
3072 lbm_value *rptr = stack_reserve(ctx,2);
3073 rptr[0] = count + (1 << LBM_VAL_SHIFT4);
3074 rptr[1] = APPLICATION_ARGS(((5) << 2) | 0xF8000001u);
3075 ctx->curr_exp = cell->car;
3076 } else {
3077 // No more arguments
3078 lbm_stack_drop(&ctx->K, 2);
3079 lbm_uint nargs = lbm_dec_u(count);
3080 lbm_value *args = get_stack_ptr(ctx, (uint32_t)(nargs + 1));
3081 application(ctx,args, nargs);
3082 }
3083}
3084
3085static void cont_and(eval_context_t *ctx) {
3086 lbm_value env;
3087 lbm_value rest;
3088 lbm_value arg = ctx->r;
3089 lbm_pop_2(&ctx->K, &rest, &env);
3090 if (lbm_is_symbol_nil(arg)) {
3091 ctx->app_cont = true1;
3092 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3093 } else if (lbm_is_symbol_nil(rest)) {
3094 ctx->app_cont = true1;
3095 } else {
3096 lbm_value *sptr = stack_reserve(ctx, 3);
3097 sptr[0] = env;
3098 sptr[1] = get_cdr(rest);
3099 sptr[2] = AND(((6) << 2) | 0xF8000001u);
3100 ctx->curr_env = env;
3101 ctx->curr_exp = get_car(rest);
3102 }
3103}
3104
3105static void cont_or(eval_context_t *ctx) {
3106 lbm_value env;
3107 lbm_value rest;
3108 lbm_value arg = ctx->r;
3109 lbm_pop_2(&ctx->K, &rest, &env);
3110 if (!lbm_is_symbol_nil(arg)) {
3111 ctx->app_cont = true1;
3112 } else if (lbm_is_symbol_nil(rest)) {
3113 ctx->app_cont = true1;
3114 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3115 } else {
3116 lbm_value *sptr = stack_reserve(ctx, 3);
3117 sptr[0] = env;
3118 sptr[1] = get_cdr(rest);
3119 sptr[2] = OR(((7) << 2) | 0xF8000001u);
3120 ctx->curr_exp = get_car(rest);
3121 ctx->curr_env = env;
3122 }
3123}
3124
3125static int fill_binding_location(lbm_value key, lbm_value value, lbm_value env) {
3126 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) {
3127 if (key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return FB_OK0;
3128 lbm_env_modify_binding(env,key,value);
3129 return FB_OK0;
3130 } else if (lbm_is_cons(key) &&
3131 lbm_is_cons(value)) {
3132 int r = fill_binding_location(get_car(key), get_car(value), env);
3133 if (r == FB_OK0) {
3134 r = fill_binding_location(get_cdr(key), get_cdr(value), env);
3135 }
3136 return r;
3137 }
3138 return FB_TYPE_ERROR-1;
3139}
3140
3141static void cont_bind_to_key_rest(eval_context_t *ctx) {
3142
3143 lbm_value *sptr = get_stack_ptr(ctx, 4);
3144
3145 lbm_value rest = sptr[1];
3146 lbm_value env = sptr[2];
3147 lbm_value key = sptr[3];
3148
3149 if (fill_binding_location(key, ctx->r, env) < 0) {
3150 lbm_set_error_reason("Incorrect type of name/key in let-binding");
3151 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
3152 }
3153
3154 if (lbm_is_cons(rest)) {
3155 lbm_value car_rest = get_car(rest);
3156 lbm_value key_val[2];
3157 extract_n(car_rest, key_val, 2);
3158
3159 sptr[1] = get_cdr(rest);
3160 sptr[3] = key_val[0];
3161 stack_reserve(ctx,1)[0] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
3162 ctx->curr_exp = key_val[1];
3163 ctx->curr_env = env;
3164 } else {
3165 // Otherwise evaluate the expression in the populated env
3166 ctx->curr_exp = sptr[0];
3167 ctx->curr_env = env;
3168 lbm_stack_drop(&ctx->K, 4);
3169 }
3170}
3171
3172static void cont_if(eval_context_t *ctx) {
3173
3174 lbm_value arg = ctx->r;
3175
3176 lbm_value *sptr = pop_stack_ptr(ctx, 2);
3177
3178 ctx->curr_env = sptr[1];
3179 if (lbm_is_symbol_nil(arg)) {
3180 ctx->curr_exp = get_cadr(sptr[0]); // else branch
3181 } else {
3182 ctx->curr_exp = get_car(sptr[0]); // then branch
3183 }
3184}
3185
3186static void cont_match(eval_context_t *ctx) {
3187 lbm_value e = ctx->r;
3188 bool_Bool do_gc = false0;
3189
3190 lbm_uint *sptr = get_stack_ptr(ctx, 2);
3191 lbm_value patterns = (lbm_value)sptr[0];
3192 lbm_value orig_env = (lbm_value)sptr[1]; // restore enclosing environment.
3193 lbm_value new_env = orig_env;
3194
3195 if (lbm_is_symbol_nil(patterns)) {
3196 // no more patterns
3197 lbm_stack_drop(&ctx->K, 2);
3198 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
3199 ctx->app_cont = true1;
3200 } else if (lbm_is_cons(patterns)) {
3201 lbm_value match_case = get_car(patterns);
3202 lbm_value pattern = get_car(match_case);
3203 lbm_value n1 = get_cadr(match_case);
3204 lbm_value n2 = get_cadr(get_cdr(match_case));
3205 lbm_value body;
3206 bool_Bool check_guard = false0;
3207 if (lbm_is_symbol_nil(n2)) { // TODO: Not a very robust check.
3208 body = n1;
3209 } else {
3210 body = n2;
3211 check_guard = true1;
3212 }
3213
3214 bool_Bool is_match = match(pattern, e, &new_env, &do_gc);
3215 if (do_gc) {
3216 gc();
3217 do_gc = false0;
3218 new_env = orig_env;
3219 is_match = match(pattern, e, &new_env, &do_gc);
3220 if (do_gc) {
3221 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3222 }
3223 }
3224 if (is_match) {
3225 if (check_guard) {
3226 lbm_value *rptr = stack_reserve(ctx,5);
3227 sptr[0] = get_cdr(patterns);
3228 sptr[1] = ctx->curr_env;
3229 rptr[0] = MATCH(((9) << 2) | 0xF8000001u);
3230 rptr[1] = new_env;
3231 rptr[2] = body;
3232 rptr[3] = e;
3233 rptr[4] = MATCH_GUARD(((27) << 2) | 0xF8000001u);
3234 ctx->curr_env = new_env;
3235 ctx->curr_exp = n1; // The guard
3236 } else {
3237 lbm_stack_drop(&ctx->K, 2);
3238 ctx->curr_env = new_env;
3239 ctx->curr_exp = body;
3240 }
3241 } else {
3242 // set up for checking of next pattern
3243 sptr[0] = get_cdr(patterns);
3244 sptr[1] = orig_env;
3245 stack_reserve(ctx,1)[0] = MATCH(((9) << 2) | 0xF8000001u);
3246 // leave r unaltered
3247 ctx->app_cont = true1;
3248 }
3249 } else {
3250 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MATCH(((0x108) << 4) | 0x00000000u));
3251 }
3252}
3253
3254static void cont_exit_atomic(eval_context_t *ctx) {
3255 is_atomic --;
3256 ctx->app_cont = true1;
3257}
3258
3259static void cont_map(eval_context_t *ctx) {
3260 lbm_value *sptr = get_stack_ptr(ctx, 6);
3261
3262 lbm_value ls = sptr[0];
3263 lbm_value env = sptr[1];
3264 lbm_value t = sptr[3];
3265 lbm_set_car(t, ctx->r); // update car field tailmost position.
3266 if (lbm_is_cons(ls)) {
3267 lbm_value next, rest;
3268 get_car_and_cdr(ls, &next, &rest);
3269 sptr[0] = rest;
3270 stack_reserve(ctx,1)[0] = MAP(((26) << 2) | 0xF8000001u);
3271 lbm_set_car(sptr[5], next); // new arguments
3272
3273 lbm_value elt = cons_with_gc(ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3274 lbm_set_cdr(t, elt);
3275 sptr[3] = elt; // (r1 ... rN . (nil . nil))
3276 ctx->curr_exp = sptr[4];
3277 ctx->curr_env = env;
3278 } else {
3279 ctx->r = sptr[2]; //head of result list
3280 ctx->curr_env = env;
3281 lbm_stack_drop(&ctx->K, 6);
3282 ctx->app_cont = true1;
3283 }
3284}
3285
3286static void cont_match_guard(eval_context_t *ctx) {
3287 if (lbm_is_symbol_nil(ctx->r)) {
3288 lbm_value e;
3289 lbm_pop(&ctx->K, &e);
3290 lbm_stack_drop(&ctx->K, 2);
3291 ctx->r = e;
3292 ctx->app_cont = true1;
3293 } else {
3294 lbm_value body;
3295 lbm_value env;
3296 lbm_stack_drop(&ctx->K, 1);
3297 lbm_pop_2(&ctx->K, &body, &env);
3298 lbm_stack_drop(&ctx->K, 3);
3299 ctx->curr_env = env;
3300 ctx->curr_exp = body;
3301 }
3302}
3303
3304static void cont_terminate(eval_context_t *ctx) {
3305 error_ctx(ctx->r);
3306}
3307
3308static void cont_loop(eval_context_t *ctx) {
3309 lbm_value *sptr = get_stack_ptr(ctx, 2);
3310 stack_reserve(ctx,1)[0] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
3311 ctx->curr_exp = sptr[1];
3312}
3313
3314static void cont_loop_condition(eval_context_t *ctx) {
3315 if (lbm_is_symbol_nil(ctx->r)) {
3316 lbm_stack_drop(&ctx->K, 2);
3317 ctx->app_cont = true1; // A loop returns nil? Makes sense to me... but in general?
3318 return;
3319 }
3320 lbm_value *sptr = get_stack_ptr(ctx, 2);
3321 stack_reserve(ctx,1)[0] = LOOP(((41) << 2) | 0xF8000001u);
3322 ctx->curr_exp = sptr[0];
3323}
3324
3325static void cont_merge_rest(eval_context_t *ctx) {
3326 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3327
3328 // If comparator returns true (result is in ctx->r):
3329 // "a" should be moved to the last element position in merged list.
3330 // A new element from "a_rest" should be moved into comparator argument 1 pos.
3331 // else
3332 // "b" should be moved to last element position in merged list.
3333 // A new element from "b_rest" should be moved into comparator argument 2 pos.
3334 //
3335 // If a_rest or b_rest is NIL:
3336 // we are done, the remaining elements of
3337 // non_nil list should be appended to merged list.
3338 // else
3339 // Set up for a new comparator evaluation and recurse.
3340 lbm_value a = sptr[2];
3341 lbm_value b = lbm_cdr(a);
3342 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate 1 element list
3343
3344 if (ctx->r == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) { // Comparison false
3345
3346 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3347 sptr[0] = b;
3348 sptr[1] = b;
3349 } else {
3350 lbm_set_cdr(sptr[1], b);
3351 sptr[1] = b;
3352 }
3353 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3354 lbm_set_cdr(a, sptr[3]);
3355 lbm_set_cdr(sptr[1], a);
3356 ctx->r = sptr[0];
3357 lbm_stack_drop(&ctx->K, 9);
3358 ctx->app_cont = true1;
3359 return;
3360 } else {
3361 b = sptr[4];
3362 sptr[4] = lbm_cdr(sptr[4]);
3363 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3364 }
3365 } else {
3366 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3367 sptr[0] = a;
3368 sptr[1] = a;
3369 } else {
3370 lbm_set_cdr(sptr[1], a);
3371 sptr[1] = a;
3372 }
3373
3374 if (sptr[3] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3375 lbm_set_cdr(b, sptr[4]);
3376 lbm_set_cdr(sptr[1], b);
3377 ctx->r = sptr[0];
3378 lbm_stack_drop(&ctx->K, 9);
3379 ctx->app_cont = true1;
3380 return;
3381 } else {
3382 a = sptr[3];
3383 sptr[3] = lbm_cdr(sptr[3]);
3384 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3385 }
3386 }
3387 lbm_set_cdr(a, b);
3388 sptr[2] = a;
3389
3390 lbm_value par1 = sptr[7];
3391 lbm_value par2 = sptr[8];
3392 lbm_value cmp_body = sptr[5];
3393 lbm_value cmp_env = sptr[6];
3394 // Environment should be preallocated already at this point
3395 // and the operations below should never need GC.
3396 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3397 lbm_value new_env = lbm_env_set(new_env0, par2, lbm_car(b));
3398 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3399 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3400 }
3401 cmp_env = new_env;
3402
3403 stack_reserve(ctx,1)[0] = MERGE_REST(((43) << 2) | 0xF8000001u);
3404 ctx->curr_exp = cmp_body;
3405 ctx->curr_env = cmp_env;
3406}
3407
3408// merge_layer stack contents
3409// s[sp-9] = cmp
3410// s[sp-8] = cmp_env
3411// s[sp-7] = par1
3412// s[sp-6] = par2
3413// s[sp-5] = acc - first cell
3414// s[sp-4] = acc - last cell
3415// s[sp-3] = rest;
3416// s[sp-2] = layer
3417// s[sp-1] = length or original list
3418//
3419// ctx->r merged sublist
3420static void cont_merge_layer(eval_context_t *ctx) {
3421 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3422 lbm_int layer = lbm_dec_i(sptr[7]);
3423 lbm_int len = lbm_dec_i(sptr[8]);
3424
3425 lbm_value r_curr = ctx->r;
3426 while (lbm_is_cons(r_curr)) {
3427 lbm_value next = lbm_cdr(r_curr);
3428 if (next == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3429 break;
3430 }
3431 r_curr = next;
3432 }
3433
3434 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3435 sptr[4] = ctx->r;
3436 sptr[5] = r_curr;
3437 } else {
3438 lbm_set_cdr(sptr[5], ctx->r); // accumulate merged sublists.
3439 sptr[5] = r_curr;
3440 }
3441
3442 lbm_value layer_rest = sptr[6];
3443 // switch layer or done ?
3444 if (layer_rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3445 if (layer * 2 >= len) {
3446 ctx->r = sptr[4];
3447 ctx->app_cont = true1;
3448 lbm_stack_drop(&ctx->K, 9);
3449 return;
3450 } else {
3451 // Setup for merges of the next layer
3452 layer = layer * 2;
3453 sptr[7] = lbm_enc_i(layer);
3454 layer_rest = sptr[4]; // continue on the accumulation of all sublists.
3455 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3456 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3457 }
3458 }
3459 // merge another sublist based on current layer.
3460 lbm_value a_list = layer_rest;
3461 // build sublist a
3462 lbm_value curr = layer_rest;
3463 for (int i = 0; i < layer-1; i ++) {
3464 if (lbm_is_cons(curr)) {
3465 curr = lbm_cdr(curr);
3466 } else {
3467 break;
3468 }
3469 }
3470 layer_rest = lbm_cdr(curr);
3471 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3472
3473 lbm_value b_list = layer_rest;
3474 // build sublist b
3475 curr = layer_rest;
3476 for (int i = 0; i < layer-1; i ++) {
3477 if (lbm_is_cons(curr)) {
3478 curr = lbm_cdr(curr);
3479 } else {
3480 break;
3481 }
3482 }
3483 layer_rest = lbm_cdr(curr);
3484 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3485
3486 sptr[6] = layer_rest;
3487
3488 if (b_list == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3489 stack_reserve(ctx,1)[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3490 ctx->r = a_list;
3491 ctx->app_cont = true1;
3492 return;
3493 }
3494 // Set up for a merge of sublists.
3495
3496 lbm_value a_rest = lbm_cdr(a_list);
3497 lbm_value b_rest = lbm_cdr(b_list);
3498 lbm_value a = a_list;
3499 lbm_value b = b_list;
3500 lbm_set_cdr(a, b);
3501 // Terminating the b list would be incorrect here
3502 // if there was any chance that the environment update below
3503 // performs GC.
3504 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3505
3506 lbm_value cmp_body = sptr[0];
3507 lbm_value cmp_env = sptr[1];
3508 lbm_value par1 = sptr[2];
3509 lbm_value par2 = sptr[3];
3510 // Environment should be preallocated already at this point
3511 // and the operations below should never need GC.
3512 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3513 lbm_value new_env = lbm_env_set(cmp_env, par2, lbm_car(b));
3514 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3515 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3516 }
3517 cmp_env = new_env;
3518
3519 lbm_uint *merge_cont = stack_reserve(ctx, 11);
3520 merge_cont[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3521 merge_cont[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3522 merge_cont[2] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3523 merge_cont[3] = a;
3524 merge_cont[4] = a_rest;
3525 merge_cont[5] = b_rest;
3526 merge_cont[6] = cmp_body;
3527 merge_cont[7] = cmp_env;
3528 merge_cont[8] = par1;
3529 merge_cont[9] = par2;
3530 merge_cont[10] = MERGE_REST(((43) << 2) | 0xF8000001u);
3531 ctx->curr_exp = cmp_body;
3532 ctx->curr_env = cmp_env;
3533 return;
3534}
3535
3536/****************************************************/
3537/* READER */
3538
3539static void read_finish(lbm_char_channel_t *str, eval_context_t *ctx) {
3540
3541 /* Tokenizer reached "end of file"
3542 The parser could be in a state where it needs
3543 more tokens to correctly finish an expression.
3544
3545 Three cases
3546 1. The program / expression is malformed and the context should die.
3547 2. We are finished reading a program and should close off the
3548 internal representation with a closing parenthesis. Then
3549 apply continuation.
3550 3. We are finished reading an expression and should
3551 apply the continuation.
3552
3553 In case 3, we should find the READ_DONE at sp - 1.
3554 In case 2, we should find the READ_DONE at sp - 5.
3555
3556 */
3557
3558 if (lbm_is_symbol(ctx->r)) {
3559 lbm_uint sym_val = lbm_dec_sym(ctx->r);
3560 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
3561 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
3562 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3563 }
3564 }
3565
3566 if (ctx->K.data[ctx->K.sp-1] == READ_DONE(((20) << 2) | 0xF8000001u) &&
3567 lbm_dec_u(ctx->K.data[ctx->K.sp-3]) == 0) {
3568 /* successfully finished reading an expression (CASE 3) */
3569 ctx->app_cont = true1;
3570 } else if (ctx->K.sp > 4 && ctx->K.data[ctx->K.sp - 4] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3571 lbm_value env;
3572 lbm_value s;
3573 lbm_value sym;
3574 lbm_pop_3(&ctx->K, &sym, &env, &s);
3575 ctx->curr_env = env;
3576 ctx->app_cont = true1; // Program evaluated and result is in ctx->r.
3577 } else if (ctx->K.sp > 5 && ctx->K.data[ctx->K.sp - 5] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3578 /* successfully finished reading a program (CASE 2) */
3579 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3580 ctx->app_cont = true1;
3581 } else {
3582 /* Parsing failed */
3583 if (lbm_channel_row(str) == 1 &&
3584 lbm_channel_column(str) == 1 ){
3585 // eof at empty stream.
3586 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3587 ctx->app_cont = true1;
3588 } else {
3589 lbm_set_error_reason((char*)lbm_error_str_parse_eof);
3590 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3591 }
3592 lbm_channel_reader_close(str);
3593 }
3594}
3595
3596/* cont_read_next_token
3597 sp-2 : Stream
3598 sp-1 : Grab row
3599*/
3600static void cont_read_next_token(eval_context_t *ctx) {
3601 lbm_value *sptr = get_stack_ptr(ctx, 2);
3602 lbm_value stream = sptr[0];
3603 lbm_value grab_row0 = sptr[1];
3604
3605 lbm_char_channel_t *chan = lbm_dec_channel(stream);
3606 if (chan == NULL((void*)0) || chan->state == NULL((void*)0)) {
3607 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3608 }
3609
3610 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3611 lbm_stack_drop(&ctx->K, 2);
3612 read_finish(chan, ctx);
3613 return;
3614 }
3615 /* Eat whitespace and comments */
3616 if (!tok_clean_whitespace(chan)) {
3617 sptr[0] = stream;
3618 sptr[1] = lbm_enc_u(0);
3619 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3620 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3621 return;
3622 }
3623 /* After eating whitespace we may be at end of file/stream */
3624 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3625 lbm_stack_drop(&ctx->K, 2);
3626 read_finish(chan, ctx);
3627 return;
3628 }
3629
3630 if (lbm_dec_u(grab_row0)) {
3631 ctx->row0 = (int32_t)lbm_channel_row(chan);
3632 }
3633
3634 /* Attempt to extract tokens from the character stream */
3635 int n = 0;
3636 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3637 unsigned int string_len = 0;
3638
3639 /*
3640 * SYNTAX
3641 */
3642 uint32_t match;
3643 n = tok_syntax(chan, &match);
3644 if (n > 0) {
3645 if (!lbm_channel_drop(chan, (unsigned int)n)) {
3646 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3647 }
3648 ctx->app_cont = true1;
3649 lbm_uint do_next = 0;
3650 switch(match) {
3651 case TOKOPENPAR1u: {
3652 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3653 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3654 lbm_value *rptr = stack_reserve(ctx,5);
3655 rptr[0] = stream;
3656 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3657 rptr[2] = stream;
3658 rptr[3] = lbm_enc_u(0);
3659 rptr[4] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3660 ctx->r = ENC_SYM_OPENPAR(((0x70) << 4) | 0x00000000u);
3661 } return;
3662 case TOKCLOSEPAR2u: {
3663 lbm_stack_drop(&ctx->K, 2);
3664 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3665 } return;
3666 case TOKOPENBRACK3u: {
3667 sptr[0] = stream;
3668 sptr[1] = READ_START_ARRAY(((24) << 2) | 0xF8000001u);
3669 lbm_value *rptr = stack_reserve(ctx, 3);
3670 rptr[0] = stream;
3671 rptr[1] = lbm_enc_u(0);
3672 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3673 ctx->r = ENC_SYM_OPENBRACK(((0x80) << 4) | 0x00000000u);
3674 } return;
3675 case TOKCLOSEBRACK4u:
3676 lbm_stack_drop(&ctx->K, 2);
3677 ctx->r = ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u);
3678 return;
3679 case TOKDOT5u:
3680 lbm_stack_drop(&ctx->K, 2);
3681 ctx->r = ENC_SYM_DOT(((0x76) << 4) | 0x00000000u);
3682 return;
3683 case TOKDONTCARE6u:
3684 lbm_stack_drop(&ctx->K, 2);
3685 ctx->r = ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u);
3686 return;
3687 case TOKQUOTE7u:
3688 do_next = READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u);
3689 break;
3690 case TOKBACKQUOTE8u: {
3691 sptr[0] = QQ_EXPAND_START(((35) << 2) | 0xF8000001u);
3692 sptr[1] = stream;
3693 lbm_value *rptr = stack_reserve(ctx, 2);
3694 rptr[0] = lbm_enc_u(0);
3695 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3696 ctx->app_cont = true1;
3697 } return;
3698 case TOKCOMMAAT9u:
3699 do_next = READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u);
3700 break;
3701 case TOKCOMMA10u:
3702 do_next = READ_COMMA_RESULT(((23) << 2) | 0xF8000001u);
3703 break;
3704 case TOKMATCHANY11u:
3705 lbm_stack_drop(&ctx->K, 2);
3706 ctx->r = ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u);
3707 return;
3708 case TOKOPENCURL12u: {
3709 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3710 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3711 lbm_value *rptr = stack_reserve(ctx,2);
3712 rptr[0] = stream;
3713 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3714 ctx->r = ENC_SYM_PROGN(((0x102) << 4) | 0x00000000u);
3715 } return;
3716 case TOKCLOSECURL13u:
3717 lbm_stack_drop(&ctx->K, 2);
3718 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3719 return;
3720 case TOKCONSTSTART14u: /* fall through */
3721 case TOKCONSTEND15u:
3722 case TOKCONSTSYMSTR16u: {
3723 if (match == TOKCONSTSTART14u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3724 if (match == TOKCONSTEND15u) ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3725 if (match == TOKCONSTSYMSTR16u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04;
3726 sptr[0] = stream;
3727 sptr[1] = lbm_enc_u(0);
3728 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3729 ctx->app_cont = true1;
3730 } return;
3731 default:
3732 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3733 }
3734 sptr[0] = do_next;
3735 sptr[1] = stream;
3736 lbm_value *rptr = stack_reserve(ctx, 2);
3737 rptr[0] = lbm_enc_u(0);
3738 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3739 ctx->app_cont = true1;
3740 return;
3741 } else if (n < 0) goto retry_token;
3742
3743 /*
3744 * STRING
3745 */
3746 n = tok_string(chan, &string_len);
3747 if (n >= 2) {
3748 lbm_channel_drop(chan, (unsigned int)n);
3749 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3750 gc();
3751 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3752 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3753 return; // dead return but static analysis does not know that.
3754 }
3755 }
3756 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(res);
3757 char *data = (char*)arr->data;
3758 memset(data,0, string_len + 1);
3759 memcpy(data, tokpar_sym_str, string_len);
3760 lbm_stack_drop(&ctx->K, 2);
3761 ctx->r = res;
3762 ctx->app_cont = true1;
3763 return;
3764 } else if (n < 0) goto retry_token;
3765
3766 /*
3767 * FLOAT
3768 */
3769 token_float f_val;
3770 n = tok_double(chan, &f_val);
3771 if (n > 0) {
3772 lbm_channel_drop(chan, (unsigned int) n);
3773 switch(f_val.type) {
3774 case TOKTYPEF32107u:
3775 WITH_GC(res, lbm_enc_float((float)f_val.value))(res) = (lbm_enc_float((float)f_val.value)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (lbm_enc_float((float)f_val.value));
if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
3776 break;
3777 case TOKTYPEF64108u:
3778 res = lbm_enc_double(f_val.value);
3779 break;
3780 default:
3781 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3782 }
3783 lbm_stack_drop(&ctx->K, 2);
3784 ctx->r = res;
3785 ctx->app_cont = true1;
3786 return;
3787 } else if (n < 0) goto retry_token;
3788
3789 /*
3790 * INTEGER
3791 */
3792 token_int int_result;
3793 n = tok_integer(chan, &int_result);
3794 if (n > 0) {
3795 lbm_channel_drop(chan, (unsigned int)n);
3796 switch(int_result.type) {
3797 case TOKTYPEBYTE100u:
3798 res = lbm_enc_char((uint8_t)(int_result.negative ? -int_result.value : int_result.value));
3799 break;
3800 case TOKTYPEI101u:
3801 res = lbm_enc_i((lbm_int)(int_result.negative ? -int_result.value : int_result.value));
3802 break;
3803 case TOKTYPEU102u:
3804 res = lbm_enc_u((lbm_uint)(int_result.negative ? -int_result.value : int_result.value));
3805 break;
3806 case TOKTYPEI32103u:
3807 WITH_GC(res, lbm_enc_i32((int32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i32((int32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i32((int32_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3808 break;
3809 case TOKTYPEU32104u:
3810 WITH_GC(res,lbm_enc_u32((uint32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u32((uint32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u32((uint32_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3811 break;
3812 case TOKTYPEI64105u:
3813 WITH_GC(res,lbm_enc_i64((int64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i64((int64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i64((int64_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3814 break;
3815 case TOKTYPEU64106u:
3816 WITH_GC(res,lbm_enc_u64((uint64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u64((uint64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u64((uint64_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3817 break;
3818 default:
3819 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3820 }
3821 lbm_stack_drop(&ctx->K, 2);
3822 ctx->r = res;
3823 ctx->app_cont = true1;
3824 return;
3825 } else if (n < 0) goto retry_token;
3826
3827 /*
3828 * SYMBOL
3829 */
3830 n = tok_symbol(chan);
3831 if (n > 0) {
3832 lbm_channel_drop(chan, (unsigned int) n);
3833 lbm_uint symbol_id;
3834 if (lbm_get_symbol_by_name(tokpar_sym_str, &symbol_id)) {
3835 res = lbm_enc_sym(symbol_id);
3836 } else {
3837 int r = 0;
3838 if (n > 4 &&
3839 tokpar_sym_str[0] == 'e' &&
3840 tokpar_sym_str[1] == 'x' &&
3841 tokpar_sym_str[2] == 't' &&
3842 tokpar_sym_str[3] == '-') {
3843 lbm_uint ext_id;
3844 lbm_uint ext_name_len = (lbm_uint)n + 1;
3845 char *ext_name = lbm_malloc(ext_name_len);
3846 if (!ext_name) {
3847 gc();
3848 ext_name = lbm_malloc(ext_name_len);
3849 }
3850 if (ext_name) {
3851 memcpy(ext_name, tokpar_sym_str, ext_name_len);
3852 r = lbm_add_extension(ext_name, lbm_extensions_default);
3853 if (!lbm_lookup_extension_id(ext_name, &ext_id)) {
3854 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3855 }
3856 symbol_id = ext_id;
3857 } else {
3858 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3859 }
3860 } else {
3861 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04 &&
3862 ctx->flags & EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08) {
3863 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id, true1); //flash
3864 if (!r) {
3865 lbm_set_error_reason((char*)lbm_error_str_flash_error);
3866 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3867 }
3868 } else {
3869 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3870 if (!r) {
3871 gc();
3872 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3873 }
3874 }
3875 }
3876 if (r) {
3877 res = lbm_enc_sym(symbol_id);
3878 } else {
3879 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3880 }
3881 }
3882 lbm_stack_drop(&ctx->K, 2);
3883 ctx->r = res;
3884 ctx->app_cont = true1;
3885 return;
3886 } else if (n == TOKENIZER_NEED_MORE-1) {
3887 goto retry_token;
3888 } else if (n <= TOKENIZER_STRING_ERROR-2) {
3889 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3890 }
3891
3892 /*
3893 * CHAR
3894 */
3895 char c_val;
3896 n = tok_char(chan, &c_val);
3897 if(n > 0) {
3898 lbm_channel_drop(chan,(unsigned int) n);
3899 lbm_stack_drop(&ctx->K, 2);
3900 ctx->r = lbm_enc_char((uint8_t)c_val);
3901 ctx->app_cont = true1;
3902 return;
3903 }else if (n < 0) goto retry_token;
3904
3905 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3906
3907 retry_token:
3908 if (n == TOKENIZER_NEED_MORE-1) {
3909 sptr[0] = stream;
3910 sptr[1] = lbm_enc_u(0);
3911 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3912 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3913 return;
3914 }
3915 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3916}
3917
3918static void cont_read_start_array(eval_context_t *ctx) {
3919 lbm_value *sptr = get_stack_ptr(ctx, 1);
3920 lbm_value stream = sptr[0];
3921
3922 lbm_char_channel_t *str = lbm_dec_channel(stream);
3923 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
3924 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3925 }
3926
3927 lbm_uint num_free = lbm_memory_longest_free();
3928 lbm_uint initial_size = (lbm_uint)((float)num_free * 0.9);
3929 if (initial_size == 0) {
3930 gc();
3931 num_free = lbm_memory_longest_free();
3932 initial_size = (lbm_uint)((float)num_free * 0.9);
3933 if (initial_size == 0) {
3934 lbm_channel_reader_close(str);
3935 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3936 }
3937 }
3938
3939 if (lbm_is_number(ctx->r)) {
3940 lbm_value array;
3941 initial_size = sizeof(lbm_uint) * initial_size;
3942
3943 if (!lbm_heap_allocate_array(&array, initial_size)) {
3944 lbm_set_error_reason("Out of memory while reading.");
3945 lbm_channel_reader_close(str);
3946 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3947 // NOTE: If array is not created evaluation ends here.
3948 // Static analysis seems unaware.
3949 }
3950
3951 sptr[0] = array;
3952 lbm_value *rptr = stack_reserve(ctx, 4);
3953 rptr[0] = lbm_enc_u(initial_size);
3954 rptr[1] = lbm_enc_u(0);
3955 rptr[2] = stream;
3956 rptr[3] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3957 ctx->app_cont = true1;
3958 } else {
3959 lbm_channel_reader_close(str);
3960 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3961 }
3962}
3963
3964static void cont_read_append_array(eval_context_t *ctx) {
3965 lbm_uint *sptr = get_stack_ptr(ctx, 4);
3966
3967 lbm_value array = sptr[0];
3968 lbm_value size = lbm_dec_as_u32(sptr[1]);
3969 lbm_value ix = lbm_dec_as_u32(sptr[2]);
3970 lbm_value stream = sptr[3];
3971
3972 if (ix >= (size - 1)) {
3973 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3974 }
3975
3976 // get_car can return nil. Whose value is 0!
3977 // So static Analysis is right about this being a potential NULL pointer.
3978 // However, if the array was created correcly to begin with, it should be fine.
3979 lbm_value arr_car = get_car(array);
3980 lbm_array_header_t *arr = (lbm_array_header_t*)arr_car;
3981
3982 if (lbm_is_number(ctx->r)) {
3983 ((uint8_t*)arr->data)[ix] = (uint8_t)lbm_dec_as_u32(ctx->r);
3984
3985 sptr[2] = lbm_enc_u(ix + 1);
3986 lbm_value *rptr = stack_reserve(ctx, 4);
3987 rptr[0] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3988 rptr[1] = stream;
3989 rptr[2] = lbm_enc_u(0);
3990 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3991 ctx->app_cont = true1;
3992 } else if (lbm_is_symbol(ctx->r) && ctx->r == ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u)) {
3993 lbm_uint array_size = ix / sizeof(lbm_uint);
3994
3995 if (ix % sizeof(lbm_uint) != 0) {
3996 array_size = array_size + 1;
3997 }
3998 lbm_memory_shrink((lbm_uint*)arr->data, array_size);
3999 arr->size = ix;
4000 lbm_stack_drop(&ctx->K, 4);
4001 ctx->r = array;
4002 ctx->app_cont = true1;
4003 } else {
4004 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
4005 }
4006}
4007
4008static void cont_read_append_continue(eval_context_t *ctx) {
4009 lbm_value *sptr = get_stack_ptr(ctx, 3);
4010
4011 lbm_value first_cell = sptr[0];
4012 lbm_value last_cell = sptr[1];
4013 lbm_value stream = sptr[2];
4014
4015 lbm_char_channel_t *str = lbm_dec_channel(stream);
4016 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4017 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4018 }
4019
4020 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4021
4022 switch(ctx->r) {
4023 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4024 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4025 lbm_set_cdr(last_cell, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate the list
4026 ctx->r = first_cell;
4027 } else {
4028 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4029 }
4030 lbm_stack_drop(&ctx->K, 3);
4031 /* Skip reading another token and apply the continuation */
4032 ctx->app_cont = true1;
4033 return;
4034 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4035 lbm_value *rptr = stack_reserve(ctx, 4);
4036 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4037 rptr[1] = stream;
4038 rptr[2] = lbm_enc_u(0);
4039 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4040 ctx->app_cont = true1;
4041 } return;
4042 }
4043 }
4044 lbm_value new_cell = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4045 if (lbm_is_symbol_merror(new_cell)) {
4046 lbm_channel_reader_close(str);
4047 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4048 return;
4049 }
4050 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4051 lbm_set_cdr(last_cell, new_cell);
4052 last_cell = new_cell;
4053 } else {
4054 first_cell = last_cell = new_cell;
4055 }
4056 sptr[0] = first_cell;
4057 sptr[1] = last_cell;
4058 sptr[2] = stream; // unchanged.
4059 lbm_value *rptr = stack_reserve(ctx, 4);
4060 rptr[0] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
4061 rptr[1] = stream;
4062 rptr[2] = lbm_enc_u(0);
4063 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4064 ctx->app_cont = true1;
4065}
4066
4067static void cont_read_eval_continue(eval_context_t *ctx) {
4068 lbm_value env;
4069 lbm_value stream;
4070 lbm_pop_2(&ctx->K, &env, &stream);
4071
4072 lbm_char_channel_t *str = lbm_dec_channel(stream);
4073 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4074 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4075 }
4076
4077 ctx->row1 = (lbm_int)str->row(str);
4078
4079 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4080
4081 switch(ctx->r) {
4082 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4083 ctx->app_cont = true1;
4084 return;
4085 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4086 // This case is a bit mysterious.
4087 // A dot, may in reality be an error in this location.
4088 lbm_value *rptr = stack_reserve(ctx, 4);
4089 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4090 rptr[1] = stream;
4091 rptr[2] = lbm_enc_u(0);
4092 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4093 ctx->app_cont = true1;
4094 } return;
4095 }
4096 }
4097
4098 lbm_value *rptr = stack_reserve(ctx, 6);
4099 rptr[0] = stream;
4100 rptr[1] = env;
4101 rptr[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
4102 rptr[3] = stream;
4103 rptr[4] = lbm_enc_u(1);
4104 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4105 rptr[6] = lbm_enc_u(ctx->flags);
4106 rptr[7] = POP_READER_FLAGS(((47) << 2) | 0xF8000001u);
4107 ctx->curr_env = env;
4108 ctx->curr_exp = ctx->r;
4109}
4110
4111static void cont_read_expect_closepar(eval_context_t *ctx) {
4112 lbm_value res;
4113 lbm_value stream;
4114
4115 lbm_pop_2(&ctx->K, &res, &stream);
4116
4117 lbm_char_channel_t *str = lbm_dec_channel(stream);
4118 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4119 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4120 }
4121
4122 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4123 ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u)) {
4124 ctx->r = res;
4125 ctx->app_cont = true1;
4126 } else {
4127 lbm_channel_reader_close(str);
4128 lbm_set_error_reason((char*)lbm_error_str_parse_close);
4129 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4130 }
4131}
4132
4133static void cont_read_dot_terminate(eval_context_t *ctx) {
4134 lbm_value *sptr = get_stack_ptr(ctx, 3);
4135
4136 lbm_value first_cell = sptr[0];
4137 lbm_value last_cell = sptr[1];
4138 lbm_value stream = sptr[2];
4139
4140 lbm_char_channel_t *str = lbm_dec_channel(stream);
4141 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4142 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4143 }
4144
4145 lbm_stack_drop(&ctx->K ,3);
4146
4147 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4148 (ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u) ||
4149 ctx->r == ENC_SYM_DOT(((0x76) << 4) | 0x00000000u))) {
4150 lbm_channel_reader_close(str);
4151 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4152 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4153 } else {
4154 if (lbm_is_cons(last_cell)) {
4155 lbm_set_cdr(last_cell, ctx->r);
4156 ctx->r = first_cell;
4157 lbm_value *rptr = stack_reserve(ctx, 6);
4158 rptr[0] = stream;
4159 rptr[1] = ctx->r;
4160 rptr[2] = READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u);
4161 rptr[3] = stream;
4162 rptr[4] = lbm_enc_u(0);
4163 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4164 ctx->app_cont = true1;
4165 } else {
4166 lbm_channel_reader_close(str);
4167 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4168 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4169 }
4170 }
4171}
4172
4173static void cont_read_done(eval_context_t *ctx) {
4174 lbm_value stream;
4175 lbm_value f_val;
4176 lbm_pop_2(&ctx->K, &stream ,&f_val);
4177
4178 uint32_t flags = lbm_dec_as_u32(f_val);
4179 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4180 ctx->flags |= (flags & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4181
4182 lbm_char_channel_t *str = lbm_dec_channel(stream);
4183 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4184 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4185 }
4186
4187 lbm_channel_reader_close(str);
4188 if (lbm_is_symbol(ctx->r)) {
4189 lbm_uint sym_val = lbm_dec_sym(ctx->r);
4190 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
4191 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
4192 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4193 }
4194 }
4195
4196 ctx->row0 = -1;
4197 ctx->row1 = -1;
4198 ctx->app_cont = true1;
4199}
4200
4201static void cont_read_quote_result(eval_context_t *ctx) {
4202 lbm_value cell;
4203 WITH_GC(cell, lbm_heap_allocate_list_init(2,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4204 ENC_SYM_QUOTE,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4205 ctx->r))(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
};
4206 ctx->r = cell;
4207 ctx->app_cont = true1;
4208}
4209
4210static void cont_read_commaat_result(eval_context_t *ctx) {
4211 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4212 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4213 ctx->r = cell1;
4214 ctx->app_cont = true1;
4215}
4216
4217static void cont_read_comma_result(eval_context_t *ctx) {
4218 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u),ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4219 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4220 ctx->r = cell1;
4221 ctx->app_cont = true1;
4222}
4223
4224static void cont_application_start(eval_context_t *ctx) {
4225
4226 /* sptr[0] = env
4227 * sptr[1] = args
4228 * ctx->r = function
4229 */
4230
4231 if (lbm_is_symbol(ctx->r)) {
4232 stack_reserve(ctx,1)[0] = lbm_enc_u(0);
4233 cont_application_args(ctx);
4234 } else if (lbm_is_cons(ctx->r)) {
4235 lbm_uint *sptr = get_stack_ptr(ctx, 2);
4236 lbm_value args = (lbm_value)sptr[1];
4237 switch (get_car(ctx->r)) {
4238 case ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u): {
4239 lbm_value cl[3];
4240 extract_n(get_cdr(ctx->r), cl, 3);
4241 lbm_value arg_env = (lbm_value)sptr[0];
4242 lbm_value arg0, arg_rest;
4243 get_car_and_cdr(args, &arg0, &arg_rest);
4244 sptr[1] = cl[CLO_BODY1];
4245 bool_Bool a_nil = lbm_is_symbol_nil(args);
4246 bool_Bool p_nil = lbm_is_symbol_nil(cl[CLO_PARAMS0]);
4247 lbm_value *reserved = stack_reserve(ctx, 4);
4248
4249 if (!a_nil && !p_nil) {
4250 reserved[0] = cl[CLO_ENV2];
4251 reserved[1] = cl[CLO_PARAMS0];
4252 reserved[2] = arg_rest;
4253 reserved[3] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
4254 ctx->curr_exp = arg0;
4255 ctx->curr_env = arg_env;
4256 } else if (a_nil && p_nil) {
4257 // No params, No args
4258 lbm_stack_drop(&ctx->K, 6);
4259 ctx->curr_exp = cl[CLO_BODY1];
4260 ctx->curr_env = cl[CLO_ENV2];
4261 } else if (p_nil) {
4262 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), cl[CLO_ENV2]);
4263 reserved[0] = rest_binder;
4264 reserved[1] = get_cdr(args);
4265 reserved[2] = get_car(rest_binder);
4266 reserved[3] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
4267 ctx->curr_exp = get_car(args);
4268 ctx->curr_env = arg_env;
4269 } else {
4270 lbm_set_error_reason((char*)lbm_error_str_num_args);
4271 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->r);
4272 }
4273 } break;
4274 case ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u):{
4275 /* Continuation created using call-cc.
4276 * ((SYM_CONT . cont-array) arg0 )
4277 */
4278 lbm_value c = get_cdr(ctx->r); /* should be the continuation array*/
4279
4280 if (!lbm_is_lisp_array_r(c)) {
4281 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4282 }
4283
4284 lbm_uint arg_count = lbm_list_length(args);
4285 lbm_value arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4286 switch (arg_count) {
4287 case 0:
4288 arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4289 break;
4290 case 1:
4291 arg = get_car(args);
4292 break;
4293 default:
4294 lbm_set_error_reason((char*)lbm_error_str_num_args);
4295 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4296 }
4297 lbm_stack_clear(&ctx->K);
4298
4299 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(c);
4300
4301 ctx->K.sp = arr->size / sizeof(lbm_uint);
4302 memcpy(ctx->K.data, arr->data, arr->size);
4303
4304 ctx->curr_exp = arg;
4305 break;
4306 }
4307 case ENC_SYM_MACRO(((0x10D) << 4) | 0x00000000u):{
4308 /*
4309 * Perform macro expansion.
4310 * Macro expansion is really just evaluation in an
4311 * environment augmented with the unevaluated expressions passed
4312 * as arguments.
4313 */
4314 lbm_value env = (lbm_value)sptr[0];
4315
4316 lbm_value curr_param = get_cadr(ctx->r);
4317 lbm_value curr_arg = args;
4318 lbm_value expand_env = env;
4319 while (lbm_is_cons(curr_param) &&
4320 lbm_is_cons(curr_arg)) {
4321 lbm_value car_curr_param, cdr_curr_param;
4322 lbm_value car_curr_arg, cdr_curr_arg;
4323 get_car_and_cdr(curr_param, &car_curr_param, &cdr_curr_param);
4324 get_car_and_cdr(curr_arg, &car_curr_arg, &cdr_curr_arg);
4325
4326 lbm_value entry = cons_with_gc(car_curr_param, car_curr_arg, expand_env);
4327 lbm_value aug_env = cons_with_gc(entry, expand_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4328 expand_env = aug_env;
4329
4330 curr_param = cdr_curr_param;
4331 curr_arg = cdr_curr_arg;
4332 }
4333 /* Two rounds of evaluation is performed.
4334 * First to instantiate the arguments into the macro body.
4335 * Second to evaluate the resulting program.
4336 */
4337 sptr[1] = EVAL_R(((11) << 2) | 0xF8000001u);
4338 lbm_value exp = get_cadr(get_cdr(ctx->r));
4339 ctx->curr_exp = exp;
4340 ctx->curr_env = expand_env;
4341 } break;
4342 default:
4343 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4344 }
4345 } else {
4346 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4347 }
4348}
4349
4350static void cont_eval_r(eval_context_t* ctx) {
4351 lbm_value env;
4352 lbm_pop(&ctx->K, &env);
4353 ctx->curr_exp = ctx->r;
4354 ctx->curr_env = env;
4355}
4356
4357static void cont_progn_var(eval_context_t* ctx) {
4358
4359 lbm_value key;
4360 lbm_value env;
4361
4362 lbm_pop_2(&ctx->K, &key, &env);
4363
4364 if (fill_binding_location(key, ctx->r, env) < 0) {
4365 lbm_set_error_reason("Incorrect type of name/key in let-binding");
4366 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
4367 }
4368
4369 ctx->app_cont = true1;
4370}
4371
4372static void cont_setq(eval_context_t *ctx) {
4373 lbm_value sym;
4374 lbm_value env;
4375 lbm_pop_2(&ctx->K, &sym, &env);
4376 lbm_value res;
4377 WITH_GC(res, perform_setvar(sym, ctx->r, env))(res) = (perform_setvar(sym, ctx->r, env)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (perform_setvar(sym, ctx->r, env)
); if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
4378 ctx->r = res;
4379 ctx->app_cont = true1;
4380}
4381
4382lbm_flash_status request_flash_storage_cell(lbm_value val, lbm_value *res) {
4383
4384 lbm_value flash_cell;
4385 lbm_flash_status s = lbm_allocate_const_cell(&flash_cell);
4386 if (s != LBM_FLASH_WRITE_OK)
4387 return s;
4388 lbm_value new_val = val;
4389 new_val &= ~LBM_PTR_VAL_MASK0x03FFFFFCu; // clear the value part of the ptr
4390 new_val |= (flash_cell & LBM_PTR_VAL_MASK0x03FFFFFCu);
4391 new_val |= LBM_PTR_TO_CONSTANT_BIT0x04000000u;
4392 *res = new_val;
4393 return s;
4394}
4395
4396static void cont_move_to_flash(eval_context_t *ctx) {
4397
4398 lbm_value args;
4399 lbm_pop(&ctx->K, &args);
4400
4401 if (lbm_is_symbol_nil(args)) {
4402 // Done looping over arguments. return true.
4403 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
4404 ctx->app_cont = true1;
4405 return;
4406 }
4407
4408 lbm_value first_arg, rest;
4409 get_car_and_cdr(args, &first_arg, &rest);
4410
4411 lbm_value val;
4412 if (lbm_is_symbol(first_arg) && lbm_global_env_lookup(&val, first_arg)) {
4413 // Prepare to copy the rest of the arguments when done with first.
4414 lbm_value *rptr = stack_reserve(ctx, 2);
4415 rptr[0] = rest;
4416 rptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
4417 if (lbm_is_ptr(val) &&
4418 (!(val & LBM_PTR_TO_CONSTANT_BIT0x04000000u))) {
4419 lbm_value * rptr1 = stack_reserve(ctx, 3);
4420 rptr1[0] = first_arg;
4421 rptr1[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
4422 rptr1[2] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4423 ctx->r = val;
4424 }
4425 ctx->app_cont = true1;
4426 return;
4427 }
4428 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4429}
4430
4431static void cont_move_val_to_flash_dispatch(eval_context_t *ctx) {
4432
4433 lbm_value val = ctx->r;
4434
4435 if (lbm_is_cons(val)) {
4436 lbm_value *rptr = stack_reserve(ctx, 5);
4437 rptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // fst cell of list
4438 rptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last cell of list
4439 rptr[2] = get_cdr(val);
4440 rptr[3] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4441 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4442 ctx->r = get_car(val);
4443 ctx->app_cont = true1;
4444 return;
4445 }
4446
4447 if (lbm_is_ptr(val) && (val & LBM_PTR_TO_CONSTANT_BIT0x04000000u)) {
4448 ctx->r = val;
4449 ctx->app_cont = true1;
4450 return;
4451 }
4452
4453 if (lbm_is_ptr(val)) {
4454 lbm_cons_t *ref = lbm_ref_cell(val);
4455 if (lbm_type_of(ref->cdr) == LBM_TYPE_SYMBOL0x00000000u) {
4456 switch (ref->cdr) {
4457 case ENC_SYM_RAW_I_TYPE(((0x31) << 4) | 0x00000000u): /* fall through */
4458 case ENC_SYM_RAW_U_TYPE(((0x32) << 4) | 0x00000000u):
4459 case ENC_SYM_RAW_F_TYPE(((0x33) << 4) | 0x00000000u): {
4460 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4461 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4462 handle_flash_status(write_const_car(flash_cell, ref->car));
4463 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4464 ctx->r = flash_cell;
4465 } break;
4466 case ENC_SYM_IND_I_TYPE(((0x34) << 4) | 0x00000000u): /* fall through */
4467 case ENC_SYM_IND_U_TYPE(((0x35) << 4) | 0x00000000u):
4468 case ENC_SYM_IND_F_TYPE(((0x36) << 4) | 0x00000000u): {
4469#ifndef LBM64
4470 /* 64 bit values are in lbm mem on 32bit platforms. */
4471 lbm_uint *lbm_mem_ptr = (lbm_uint*)ref->car;
4472 lbm_uint flash_ptr;
4473
4474 handle_flash_status(lbm_write_const_raw(lbm_mem_ptr, 2, &flash_ptr));
4475 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4476 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4477 handle_flash_status(write_const_car(flash_cell, flash_ptr));
4478 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4479 ctx->r = flash_cell;
4480#else
4481 // There are no indirect types in LBM64
4482 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4483#endif
4484 } break;
4485 case ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u): {
4486 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4487 lbm_uint size = arr->size / sizeof(lbm_uint);
4488 lbm_uint flash_addr;
4489 lbm_value *arrdata = (lbm_value *)arr->data;
4490 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4491 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4492 handle_flash_status(lbm_allocate_const_raw(size, &flash_addr));
4493 lift_array_flash(flash_cell,
4494 false0,
4495 (char *)flash_addr,
4496 arr->size);
4497 // Move array contents to flash recursively
4498 lbm_value *rptr = stack_reserve(ctx, 5);
4499 rptr[0] = flash_cell;
4500 rptr[1] = lbm_enc_u(0);
4501 rptr[2] = val;
4502 rptr[3] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4503 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4504 ctx->r = arrdata[0];
4505 ctx->app_cont = true1;
4506 return;
4507 }
4508 case ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u): {
4509 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4510 // arbitrary address: flash_arr.
4511 lbm_uint flash_arr;
4512 handle_flash_status(lbm_write_const_array_padded((uint8_t*)arr->data, arr->size, &flash_arr));
4513 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4514 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4515 lift_array_flash(flash_cell,
4516 true1,
4517 (char *)flash_arr,
4518 arr->size);
4519 ctx->r = flash_cell;
4520 } break;
4521 case ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u): /* fall through */
4522 case ENC_SYM_CUSTOM_TYPE(((0x38) << 4) | 0x00000000u):
4523 lbm_set_error_reason((char *)lbm_error_str_flash_not_possible);
4524 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4525 }
4526 } else {
4527 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4528 }
4529 ctx->app_cont = true1;
4530 return;
4531 }
4532 ctx->r = val;
4533 ctx->app_cont = true1;
4534}
4535
4536static void cont_move_list_to_flash(eval_context_t *ctx) {
4537
4538 // ctx->r holds the value that should go in car
4539
4540 lbm_value *sptr = get_stack_ptr(ctx, 3);
4541
4542 lbm_value fst = sptr[0];
4543 lbm_value lst = sptr[1];
4544 lbm_value val = sptr[2];
4545
4546
4547 lbm_value new_lst = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4548 // Allocate element ptr storage after storing the element to flash.
4549 handle_flash_status(request_flash_storage_cell(lbm_enc_cons_ptr(LBM_PTR_NULL(0x03FFFFFCu >> 2)), &new_lst));
4550
4551 if (lbm_is_symbol_nil(fst)) {
4552 lst = new_lst;
4553 fst = new_lst;
4554 handle_flash_status(write_const_car(lst, ctx->r));
4555 } else {
4556 handle_flash_status(write_const_cdr(lst, new_lst)); // low before high
4557 handle_flash_status(write_const_car(new_lst, ctx->r));
4558 lst = new_lst;
4559 }
4560
4561 if (lbm_is_cons(val)) {
4562 sptr[0] = fst;
4563 sptr[1] = lst;//rest_cell;
4564 sptr[2] = get_cdr(val);
4565 lbm_value *rptr = stack_reserve(ctx, 2);
4566 rptr[0] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4567 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4568 ctx->r = get_car(val);
4569 } else {
4570 sptr[0] = fst;
4571 sptr[1] = lst;
4572 sptr[2] = CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u);
4573 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4574 ctx->r = val;
4575 }
4576 ctx->app_cont = true1;
4577}
4578
4579static void cont_close_list_in_flash(eval_context_t *ctx) {
4580 lbm_value fst;
4581 lbm_value lst;
4582 lbm_pop_2(&ctx->K, &lst, &fst);
4583 lbm_value val = ctx->r;
4584 handle_flash_status(write_const_cdr(lst, val));
4585 ctx->r = fst;
4586 ctx->app_cont = true1;
4587}
4588
4589static void cont_move_array_elts_to_flash(eval_context_t *ctx) {
4590 lbm_value *sptr = get_stack_ptr(ctx, 3);
4591 // sptr[2] = source array in RAM
4592 // sptr[1] = current index
4593 // sptr[0] = target array in flash
4594 lbm_array_header_t *src_arr = (lbm_array_header_t*)get_car(sptr[2]);
1
Calling 'get_car'
→
10
←
Returning from 'get_car'
→
11
←
'src_arr' initialized to a null pointer value
→
4595 lbm_uint size = src_arr->size / sizeof(lbm_uint);
12
←
Access to field 'size' results in a dereference of a null pointer (loaded from variable 'src_arr')
4596 lbm_value *srcdata = (lbm_value *)src_arr->data;
4597
4598 lbm_array_header_t *tgt_arr = (lbm_array_header_t*)get_car(sptr[0]);
4599 lbm_uint *tgtdata = (lbm_value *)tgt_arr->data;
4600 lbm_uint ix = lbm_dec_as_u32(sptr[1]);
4601 handle_flash_status(lbm_const_write(&tgtdata[ix], ctx->r));
4602 if (ix >= size-1) {
4603 ctx->r = sptr[0];
4604 lbm_stack_drop(&ctx->K, 3);
4605 ctx->app_cont = true1;
4606 return;
4607 }
4608 sptr[1] = lbm_enc_u(ix + 1);
4609 lbm_value *rptr = stack_reserve(ctx, 2);
4610 rptr[0] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4611 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4612 ctx->r = srcdata[ix+1];
4613 ctx->app_cont = true1;
4614 return;
4615}
4616
4617static void cont_qq_expand_start(eval_context_t *ctx) {
4618 lbm_value *rptr = stack_reserve(ctx, 2);
4619 rptr[0] = ctx->r;
4620 rptr[1] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4621 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4622 ctx->app_cont = true1;
4623}
4624
4625lbm_value quote_it(lbm_value qquoted) {
4626 if (lbm_is_symbol(qquoted) &&
4627 lbm_is_special(qquoted)) return qquoted;
4628
4629 lbm_value val = cons_with_gc(qquoted, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4630 return cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4631}
4632
4633bool_Bool is_append(lbm_value a) {
4634 return (lbm_is_cons(a) &&
4635 lbm_is_symbol(get_car(a)) &&
4636 (get_car(a) == ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u)));
4637}
4638
4639lbm_value append(lbm_value front, lbm_value back) {
4640 if (lbm_is_symbol_nil(front)) return back;
4641 if (lbm_is_symbol_nil(back)) return front;
4642
4643 if (lbm_is_quoted_list(front) &&
4644 lbm_is_quoted_list(back)) {
4645 lbm_value f = get_cadr(front);
4646 lbm_value b = get_cadr(back);
4647 return quote_it(lbm_list_append(f, b));
4648 }
4649
4650 if (is_append(back) &&
4651 lbm_is_quoted_list(get_cadr(back)) &&
4652 lbm_is_quoted_list(front)) {
4653 lbm_value ql = get_cadr(back);
4654 lbm_value f = get_cadr(front);
4655 lbm_value b = get_cadr(ql);
4656
4657 lbm_value v = lbm_list_append(f, b);
4658 lbm_set_car(get_cdr(ql), v);
4659 return back;
4660 }
4661
4662 if (is_append(back)) {
4663 back = get_cdr(back);
4664 lbm_value new = cons_with_gc(front, back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4665 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), new, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4666 }
4667
4668 lbm_value t0, t1;
4669
4670 t0 = cons_with_gc(back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), front);
4671 t1 = cons_with_gc(front, t0, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4672 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), t1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4673}
4674
4675/* Bawden's qq-expand implementation
4676(define (qq-expand x)
4677 (cond ((tag-comma? x)
4678 (tag-data x))
4679 ((tag-comma-atsign? x)
4680 (error "Illegal"))
4681 ((tag-backquote? x)
4682 (qq-expand
4683 (qq-expand (tag-data x))))
4684 ((pair? x)
4685 `(append
4686 ,(qq-expand-list (car x))
4687 ,(qq-expand (cdr x))))
4688 (else `',x)))
4689 */
4690static void cont_qq_expand(eval_context_t *ctx) {
4691 lbm_value qquoted;
4692 lbm_pop(&ctx->K, &qquoted);
4693
4694 switch(lbm_type_of(qquoted)) {
4695 case LBM_TYPE_CONS0x10000000u: {
4696 lbm_value car_val = get_car(qquoted);
4697 lbm_value cdr_val = get_cdr(qquoted);
4698 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4699 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4700 ctx->r = append(ctx->r, get_car(cdr_val));
4701 ctx->app_cont = true1;
4702 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4703 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4704 error_ctx(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u));
4705 } else {
4706 lbm_value *rptr = stack_reserve(ctx, 6);
4707 rptr[0] = ctx->r;
4708 rptr[1] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4709 rptr[2] = cdr_val;
4710 rptr[3] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4711 rptr[4] = car_val;
4712 rptr[5] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4713 ctx->app_cont = true1;
4714 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4715 }
4716
4717 } break;
4718 default: {
4719 lbm_value res = quote_it(qquoted);
4720 ctx->r = append(ctx->r, res);
4721 ctx->app_cont = true1;
4722 }
4723 }
4724}
4725
4726static void cont_qq_append(eval_context_t *ctx) {
4727 lbm_value head;
4728 lbm_pop(&ctx->K, &head);
4729 ctx->r = append(head, ctx->r);
4730 ctx->app_cont = true1;
4731}
4732
4733/* Bawden's qq-expand-list implementation
4734(define (qq-expand-list x)
4735 (cond ((tag-comma? x)
4736 `(list ,(tag-data x)))
4737 ((tag-comma-atsign? x)
4738 (tag-data x))
4739 ((tag-backquote? x)
4740 (qq-expand-list
4741 (qq-expand (tag-data x))))
4742 ((pair? x)
4743 `(list
4744 (append
4745 ,(qq-expand-list (car x))
4746 ,(qq-expand (cdr x)))))
4747 (else `'(,x))))
4748*/
4749
4750static void cont_qq_expand_list(eval_context_t* ctx) {
4751 lbm_value l;
4752 lbm_pop(&ctx->K, &l);
4753
4754 ctx->app_cont = true1;
4755 switch(lbm_type_of(l)) {
4756 case LBM_TYPE_CONS0x10000000u: {
4757 lbm_value car_val = get_car(l);
4758 lbm_value cdr_val = get_cdr(l);
4759 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4760 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4761 lbm_value tl = cons_with_gc(get_car(cdr_val), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4762 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4763 ctx->r = append(ctx->r, tmp);
4764 return;
4765 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4766 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4767 ctx->r = get_car(cdr_val);
4768 return;
4769 } else {
4770 lbm_value *rptr = stack_reserve(ctx, 7);
4771 rptr[0] = QQ_LIST(((39) << 2) | 0xF8000001u);
4772 rptr[1] = ctx->r;
4773 rptr[2] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4774 rptr[3] = cdr_val;
4775 rptr[4] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4776 rptr[5] = car_val;
4777 rptr[6] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4778 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4779 }
4780
4781 } break;
4782 default: {
4783 lbm_value a_list = cons_with_gc(l, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4784 lbm_value tl = cons_with_gc(a_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4785 lbm_value tmp = cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4786 ctx->r = append(ctx->r, tmp);
4787 }
4788 }
4789}
4790
4791static void cont_qq_list(eval_context_t *ctx) {
4792 lbm_value val = ctx->r;
4793 lbm_value apnd_app = cons_with_gc(val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4794 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), apnd_app, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4795 ctx->r = tmp;
4796 ctx->app_cont = true1;
4797}
4798
4799static void cont_kill(eval_context_t *ctx) {
4800 (void) ctx;
4801 finish_ctx();
4802}
4803
4804static void cont_pop_reader_flags(eval_context_t *ctx) {
4805 lbm_value flags;
4806 lbm_pop(&ctx->K, &flags);
4807 ctx->flags = ctx->flags & ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4808 ctx->flags |= (lbm_dec_as_u32(flags) & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4809 // r is unchanged.
4810 ctx->app_cont = true1;
4811}
4812
4813static void cont_exception_handler(eval_context_t *ctx) {
4814 lbm_value *sptr = pop_stack_ptr(ctx, 2);
4815 lbm_value retval = sptr[0];
4816 lbm_value flags = sptr[1];
4817 lbm_set_car(get_cdr(retval), ctx->r);
4818 ctx->flags = flags;
4819 ctx->r = retval;
4820 ctx->app_cont = true1;
4821}
4822
4823/*********************************************************/
4824/* Continuations table */
4825typedef void (*cont_fun)(eval_context_t *);
4826
4827static const cont_fun continuations[NUM_CONTINUATIONS49] =
4828 { advance_ctx, // CONT_DONE
4829 cont_set_global_env,
4830 cont_bind_to_key_rest,
4831 cont_if,
4832 cont_progn_rest,
4833 cont_application_args,
4834 cont_and,
4835 cont_or,
4836 cont_wait,
4837 cont_match,
4838 cont_application_start,
4839 cont_eval_r,
4840 cont_resume,
4841 cont_closure_application_args,
4842 cont_exit_atomic,
4843 cont_read_next_token,
4844 cont_read_append_continue,
4845 cont_read_eval_continue,
4846 cont_read_expect_closepar,
4847 cont_read_dot_terminate,
4848 cont_read_done,
4849 cont_read_quote_result,
4850 cont_read_commaat_result,
4851 cont_read_comma_result,
4852 cont_read_start_array,
4853 cont_read_append_array,
4854 cont_map,
4855 cont_match_guard,
4856 cont_terminate,
4857 cont_progn_var,
4858 cont_setq,
4859 cont_move_to_flash,
4860 cont_move_val_to_flash_dispatch,
4861 cont_move_list_to_flash,
4862 cont_close_list_in_flash,
4863 cont_qq_expand_start,
4864 cont_qq_expand,
4865 cont_qq_append,
4866 cont_qq_expand_list,
4867 cont_qq_list,
4868 cont_kill,
4869 cont_loop,
4870 cont_loop_condition,
4871 cont_merge_rest,
4872 cont_merge_layer,
4873 cont_closure_args_rest,
4874 cont_move_array_elts_to_flash,
4875 cont_pop_reader_flags,
4876 cont_exception_handler
4877 };
4878
4879/*********************************************************/
4880/* Evaluators lookup table (special forms) */
4881typedef void (*evaluator_fun)(eval_context_t *);
4882
4883static const evaluator_fun evaluators[] =
4884 {
4885 eval_quote,
4886 eval_define,
4887 eval_progn,
4888 eval_lambda,
4889 eval_if,
4890 eval_let,
4891 eval_and,
4892 eval_or,
4893 eval_match,
4894 eval_receive,
4895 eval_receive_timeout,
4896 eval_callcc,
4897 eval_atomic,
4898 eval_selfevaluating, // macro
4899 eval_selfevaluating, // cont
4900 eval_selfevaluating, // closure
4901 eval_cond,
4902 eval_app_cont,
4903 eval_var,
4904 eval_setq,
4905 eval_move_to_flash,
4906 eval_loop,
4907 eval_trap
4908 };
4909
4910
4911/*********************************************************/
4912/* Evaluator step function */
4913
4914static void evaluation_step(void){
4915 eval_context_t *ctx = ctx_running;
4916#ifdef VISUALIZE_HEAP
4917 heap_vis_gen_image();
4918#endif
4919
4920 if (ctx->app_cont) {
4921 lbm_value k;
4922 lbm_pop(&ctx->K, &k);
4923 ctx->app_cont = false0;
4924
4925 lbm_uint decoded_k = DEC_CONTINUATION(k)(((k) & ~0xF8000001u) >> 2);
4926
4927 if (decoded_k < NUM_CONTINUATIONS49) {
4928 continuations[decoded_k](ctx);
4929 } else {
4930 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4931 }
4932 return;
4933 }
4934
4935 if (lbm_is_symbol(ctx->curr_exp)) {
4936 eval_symbol(ctx);
4937 return;
4938 }
4939 if (lbm_is_cons(ctx->curr_exp)) {
4940 lbm_cons_t *cell = lbm_ref_cell(ctx->curr_exp);
4941 lbm_value h = cell->car;
4942 if (lbm_is_symbol(h) && ((h & ENC_SPECIAL_FORMS_MASK0xFFFFF000) == ENC_SPECIAL_FORMS_BIT0x00001000)) {
4943 lbm_uint eval_index = lbm_dec_sym(h) & SPECIAL_FORMS_INDEX_MASK0x000000FF;
4944 evaluators[eval_index](ctx);
4945 return;
4946 }
4947 /*
4948 * At this point head can be anything. It should evaluate
4949 * into a form that can be applied (closure, symbol, ...) though.
4950 */
4951 lbm_value *reserved = stack_reserve(ctx, 3);
4952 reserved[0] = ctx->curr_env;
4953 reserved[1] = cell->cdr;
4954 reserved[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
4955 ctx->curr_exp = h; // evaluate the function
4956 return;
4957 }
4958
4959 eval_selfevaluating(ctx);
4960 return;
4961}
4962
4963void lbm_pause_eval(void ) {
4964 eval_cps_next_state_arg = 0;
4965 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4966 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4967}
4968
4969void lbm_pause_eval_with_gc(uint32_t num_free) {
4970 eval_cps_next_state_arg = num_free;
4971 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4972 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4973}
4974
4975void lbm_continue_eval(void) {
4976 eval_cps_next_state = EVAL_CPS_STATE_RUNNING2;
4977 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4978}
4979
4980void lbm_kill_eval(void) {
4981 eval_cps_next_state = EVAL_CPS_STATE_KILL4;
4982 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4983}
4984
4985uint32_t lbm_get_eval_state(void) {
4986 return eval_cps_run_state;
4987}
4988
4989// Will wake up thread that is sleeping as well.
4990// Not sure this is good behavior.
4991static void handle_event_unblock_ctx(lbm_cid cid, lbm_value v) {
4992 eval_context_t *found = NULL((void*)0);
4993 mutex_lock(&qmutex);
4994
4995 found = lookup_ctx_nm(&blocked, cid);
4996 if (found) {
4997 drop_ctx_nm(&blocked,found);
4998 if (lbm_is_error(v)) {
4999 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
5000 found->app_cont = true1;
5001 }
5002 found->r = v;
5003 enqueue_ctx_nm(&queue,found);
5004 }
5005 mutex_unlock(&qmutex);
5006}
5007
5008static void handle_event_define(lbm_value key, lbm_value val) {
5009 lbm_uint dec_key = lbm_dec_sym(key);
5010 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
5011 lbm_value *global_env = lbm_get_global_env();
5012 lbm_uint orig_env = global_env[ix_key];
5013 lbm_value new_env;
5014 // A key is a symbol and should not need to be remembered.
5015 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
5016
5017 global_env[ix_key] = new_env;
5018}
5019
5020static lbm_value get_event_value(lbm_event_t *e) {
5021 lbm_value v;
5022 if (e->buf_len > 0) {
5023 lbm_flat_value_t fv;
5024 fv.buf = (uint8_t*)e->buf_ptr;
5025 fv.buf_size = e->buf_len;
5026 fv.buf_pos = 0;
5027 if (!lbm_unflatten_value(&fv, &v)) {
5028 lbm_set_flags(LBM_FLAG_HANDLER_EVENT_DELIVERY_FAILED(1 << 1));
5029 v = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
5030 }
5031 // Free the flat value buffer. GC is unaware of its existence.
5032 lbm_free(fv.buf);
5033 } else {
5034 v = (lbm_value)e->buf_ptr;
5035 }
5036 return v;
5037}
5038
5039static void process_events(void) {
5040
5041 if (!lbm_events) return;
5042 lbm_event_t e;
5043
5044 while (lbm_event_pop(&e)) {
5045
5046 lbm_value event_val = get_event_value(&e);
5047 switch(e.type) {
5048 case LBM_EVENT_UNBLOCK_CTX:
5049 handle_event_unblock_ctx((lbm_cid)e.parameter, event_val);
5050 break;
5051 case LBM_EVENT_DEFINE:
5052 handle_event_define((lbm_value)e.parameter, event_val);
5053 break;
5054 case LBM_EVENT_FOR_HANDLER:
5055 if (lbm_event_handler_pid >= 0) {
5056 lbm_find_receiver_and_send(lbm_event_handler_pid, event_val);
5057 }
5058 break;
5059 }
5060 }
5061}
5062
5063/* eval_cps_run can be paused
5064 I think it would be better use a mailbox for
5065 communication between other threads and the run_eval
5066 but for now a set of variables will be used. */
5067void lbm_run_eval(void){
5068
5069 if (setjmp(critical_error_jmp_buf)_setjmp (critical_error_jmp_buf) > 0) {
5070 printf_callback("GC stack overflow!\n");
5071 critical_error_callback();
5072 // terminate evaluation thread.
5073 return;
5074 }
5075
5076 setjmp(error_jmp_buf)_setjmp (error_jmp_buf);
5077
5078 while (eval_running) {
5079 if (eval_cps_state_changed || eval_cps_run_state == EVAL_CPS_STATE_PAUSED1) {
5080 eval_cps_state_changed = false0;
5081 switch (eval_cps_next_state) {
5082 case EVAL_CPS_STATE_PAUSED1:
5083 if (eval_cps_run_state != EVAL_CPS_STATE_PAUSED1) {
5084 if (lbm_heap_num_free() < eval_cps_next_state_arg) {
5085 gc();
5086 }
5087 eval_cps_next_state_arg = 0;
5088 }
5089 eval_cps_run_state = EVAL_CPS_STATE_PAUSED1;
5090 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5091 continue; /* jump back to start of eval_running loop */
5092 case EVAL_CPS_STATE_KILL4:
5093 eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
5094 eval_running = false0;
5095 continue;
5096 default: // running state
5097 eval_cps_run_state = eval_cps_next_state;
5098 break;
5099 }
5100 }
5101 while (true1) {
5102 if (eval_steps_quota && ctx_running) {
5103 eval_steps_quota--;
5104 evaluation_step();
5105 } else {
5106 if (eval_cps_state_changed) break;
5107 eval_steps_quota = eval_steps_refill;
5108 if (is_atomic) {
5109 if (!ctx_running) {
5110 lbm_set_flags(LBM_FLAG_ATOMIC_MALFUNCTION(1 << 0));
5111 is_atomic = 0;
5112 }
5113 } else {
5114 if (gc_requested) {
5115 gc();
5116 }
5117 process_events();
5118 mutex_lock(&qmutex);
5119 if (ctx_running) {
5120 enqueue_ctx_nm(&queue, ctx_running);
5121 ctx_running = NULL((void*)0);
5122 }
5123 wake_up_ctxs_nm();
5124 ctx_running = dequeue_ctx_nm(&queue);
5125 mutex_unlock(&qmutex);
5126 if (!ctx_running) {
5127 lbm_system_sleeping = true1;
5128 //Fixed sleep interval to poll events regularly.
5129 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5130 lbm_system_sleeping = false0;
5131 }
5132 }
5133 }
5134 }
5135 }
5136}
5137
5138lbm_cid lbm_eval_program(lbm_value lisp) {
5139 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), 256, NULL((void*)0));
5140}
5141
5142lbm_cid lbm_eval_program_ext(lbm_value lisp, unsigned int stack_size) {
5143 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), stack_size, NULL((void*)0));
5144}
5145
5146int lbm_eval_init() {
5147 if (!qmutex_initialized) {
5148 mutex_init(&qmutex);
5149 qmutex_initialized = true1;
5150 }
5151 if (!lbm_events_mutex_initialized) {
5152 mutex_init(&lbm_events_mutex);
5153 lbm_events_mutex_initialized = true1;
5154 }
5155 if (!blocking_extension_mutex_initialized) {
5156 mutex_init(&blocking_extension_mutex);
5157 blocking_extension_mutex_initialized = true1;
5158 }
5159
5160 mutex_lock(&qmutex);
5161 mutex_lock(&lbm_events_mutex);
5162
5163 blocked.first = NULL((void*)0);
5164 blocked.last = NULL((void*)0);
5165 queue.first = NULL((void*)0);
5166 queue.last = NULL((void*)0);
5167 ctx_running = NULL((void*)0);
5168
5169 eval_cps_run_state = EVAL_CPS_STATE_RUNNING2;
5170
5171 mutex_unlock(&lbm_events_mutex);
5172 mutex_unlock(&qmutex);
5173
5174 if (!lbm_init_env()) return 0;
5175 eval_running = true1;
5176 return 1;
5177}
5178
5179bool_Bool lbm_eval_init_events(unsigned int num_events) {
5180
5181 mutex_lock(&lbm_events_mutex);
5182 lbm_events = (lbm_event_t*)lbm_malloc(num_events * sizeof(lbm_event_t));
5183 bool_Bool r = false0;
5184 if (lbm_events) {
5185 lbm_events_max = num_events;
5186 lbm_events_head = 0;
5187 lbm_events_tail = 0;
5188 lbm_events_full = false0;
5189 lbm_event_handler_pid = -1;
5190 r = true1;
5191 }
5192 mutex_unlock(&lbm_events_mutex);
5193 return r;
5194}
+
+
←

./include/heap.h

+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1
2/*
3 Copyright 2018, 2024 Joel Svensson svenssonjoel@yahoo.se
4
5 This program is free software: you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation, either version 3 of the License, or
8 (at your option) any later version.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
14
15 You should have received a copy of the GNU General Public License
16 along with this program. If not, see <http://www.gnu.org/licenses/>.
17*/
18/** \file heap.h */
19
20#ifndef HEAP_H_
21#define HEAP_H_
22
23#include <string.h>
24#include <stdarg.h>
25
26#include "lbm_types.h"
27#include "symrepr.h"
28#include "stack.h"
29#include "lbm_memory.h"
30#include "lbm_defines.h"
31#include "lbm_channel.h"
32
33#ifdef __cplusplus
34extern "C" {
35#endif
36
37/*
38Planning for a more space efficient heap representation.
39TODO: Need to find a good reference to read up on this.
40 - List based heap
41 - Easy to implement and somewhat efficient
42
430000 0000 Size Free bits
44003F FFFF 4MB 10
45007F FFFF 8MB 9
4600FF FFFF 16MB 8
4701FF FFFF 32MB 7
4803FF FFFF 64MB 6 * Kind of heap size I am looking for
4907FF FFFF 128MB 5
500FFF FFFF 256MB 4
511FFF FFFF 512MB 3
52
53
54--- May 9 2021 ---
55Actually now I am much more interested in way smaller memories ;)
56
570000 0000 Size Free bits
580000 0FFF 4KB 20 |
590000 1FFF 8KB 19 |
600000 3FFF 16KB 18 |
610000 7FFF 32KB 17 |
620000 FFFF 64KB 16 |
630001 FFFF 128KB 15 |
640003 FFFF 256KB 14 | - This range is very interesting.
650007 FFFF 512KB 13
66000F FFFF 1MB 12
67001F FFFF 2MB 11
68003F FFFF 4MB 10
69007F FFFF 8MB 9
7000FF FFFF 16MB 8
7101FF FFFF 32MB 7
7203FF FFFF 64MB 6
7307FF FFFF 128MB 5
740FFF FFFF 256MB 4
751FFF FFFF 512MB 3
76
77Those are the kind of platforms that are fun... so a bunch of
78wasted bits in heap pointers if we run on small MCUs.
79
80-----------------
81
82it is also the case that not all addresses will be used if all "cells" are
83of the same size, 8 bytes...
84
85value 0: 0000 0000
86value 1: 0000 0008
87value 3: 0000 0010
88value 4: 0000 0018
89
90Means bits 0,1,2 will always be empty in a valid address.
91
92Cons cells also need to be have room for 2 pointers. So each ted cell from
93memory should be 8bytes.
94
95Things that needs to be represented within these bits:
96
97 - GC MARK one per cell
98 - TYPE: type of CAR and type of cons
99
100Types I would want:
101 - Full 32bit integer. Does not leave room for identification of type
102 - Float values. Same problem
103
104
105Free bits in pointers 64MB heap:
10631 30 29 28 27 26 2 1 0
1070 0 0 0 0 0 XX XXXX XXXX XXXX XXXX XXXX X 0 0 0
108
109
110Information needed for each cell:
111 Meaning | bits total | bits per car | bits per cdr
112 GC mark | 2 | 1 | 1 - only one of them will be used (the other is wasted)
113 Type | 2x | x | x
114 Ptr/!ptr | 2 | 1 | 1
115
116
117Types (unboxed):
118 - Symbols
119 - 28bit integer ( will need signed shift right functionality )
120 - 28bit unsigned integer
121 - Character
122
123If four types is all that should be possible (unboxed). then 2 bits are needed to differentiate.
1242 + 1 + 1 = 4 => 28bits for data.
125
126bit 0: ptr/!ptr
127bit 1: gc
128bit 2-3: type (if not ptr)
129bit 3 - 24 ptr (if ptr)
130bit 4 - 31 value (if value)
131
132An unboxed value can occupy a car or cdr field in a cons cell.
133
134types (boxed) extra information in pointer to cell can contain information
135 - 32 bit integer
136 - 32 bit unsigned integer
137 - 32 bit float
138
139boxed representation:
140 [ptr| cdr]
141 |
142 [Value | Aux + GC_MARK]
143
144Kinds of pointers:
145 - Pointer to cons cell.
146 - Pointer to unboxed value (fixnums not in a list, I hope this is so rare that it can be removed )
147 - integer
148 - unsigned integer
149 - symbol
150 - float
151 - Pointer to boxed value.
152 - 32 bit integer
153 - 32 bit unsigned integer
154 - 32 bit float
155 - (Maybe something else ? Vectors/strings allocated in memory not occupied by heap?)
156 - vector of int
157 - vector of uint
158 - vector of float
159 - vector of double
160 - String
161
16213 pointer"types" -> needs 4 bits
163for 64MB heap there are 6 free bits. So with this scheme going to 128MB or 256MB heap
164is also possible
165
166 a pointer to some off heap vector/string could be represented by
167
168 [ptr | cdr]
169 |
170 [full pointer | Aux + GC_MARK]
171 |
172 [VECTOR]
173
174Aux bits could be used for storing vector size. Up to 30bits should be available there
175>> This is problematic. Now the information that something is a vector is split up
176>> between 2 cons cells. This means GC needs both of these intact to be able to make
177>> proper decision.
178>> Will try to resolve this by adding some special symbols. But these must be symbols
179>> that cannot occur normally in programs. Then an array could be:
180
181 [Full pointer | ARRAY_SYM + GC_MARK]
182 |
183 [VECTOR]
184
185>> Boxed values same treatment as above.
186>> TODO: Could this be simpler?
187
188[ VALUE | TYPE_SYM + GC_MARK]
189
190
1910000 00XX XXXX XXXX XXXX XXXX XXXX X000 : 0x03FF FFF8
1921111 AA00 0000 0000 0000 0000 0000 0000 : 0xFC00 0000 (AA bits left unused for now, future heap growth?)
193 */
194
195typedef enum {
196 LBM_FLASH_WRITE_OK,
197 LBM_FLASH_FULL,
198 LBM_FLASH_WRITE_ERROR
199} lbm_flash_status;
200
201/** Struct representing a heap cons-cell.
202 *
203 */
204typedef struct {
205 lbm_value car;
206 lbm_value cdr;
207} lbm_cons_t;
208
209/**
210 * Heap state
211 */
212typedef struct {
213 lbm_cons_t *heap;
214 lbm_value freelist; // list of free cons cells.
215 lbm_stack_t gc_stack;
216
217 lbm_uint heap_size; // In number of cells.
218 lbm_uint heap_bytes; // In bytes.
219
220 lbm_uint num_alloc; // Number of cells allocated.
221 lbm_uint num_alloc_arrays; // Number of arrays allocated.
222
223 lbm_uint gc_num; // Number of times gc has been performed.
224 lbm_uint gc_marked; // Number of cells marked by mark phase.
225 lbm_uint gc_recovered; // Number of cells recovered by sweep phase.
226 lbm_uint gc_recovered_arrays;// Number of arrays recovered by sweep.
227 lbm_uint gc_least_free; // The smallest length of the freelist.
228 lbm_uint gc_last_free; // Number of elements on the freelist
229 // after most recent GC.
230} lbm_heap_state_t;
231
232extern lbm_heap_state_t lbm_heap_state;
233
234typedef bool_Bool (*const_heap_write_fun)(lbm_uint ix, lbm_uint w);
235
236typedef struct {
237 lbm_uint *heap;
238 lbm_uint next; // next free index.
239 lbm_uint size; // in lbm_uint words. (cons-cells = words / 2)
240} lbm_const_heap_t;
241
242/**
243 * The header portion of an array stored in array and symbol memory.
244 * An array is always a byte array. use the array-extensions for
245 * storing and reading larger values from arrays.
246 */
247typedef struct {
248 lbm_uint size; /// Number of elements
249 lbm_uint *data; /// pointer to lbm_memory array or C array.
250} lbm_array_header_t;
251
252typedef struct {
253 lbm_uint size;
254 lbm_uint *data;
255 uint32_t index; // Limits arrays to max 2^32-1 elements.
256} lbm_array_header_extended_t;
257
258/** Lock GC mutex
259 * Locks a mutex during GC marking when using the pointer reversal algorithm.
260 * Does nothing when using stack based GC mark.
261 */
262void lbm_gc_lock(void);
263/* Unlock GC mutex
264 */
265void lbm_gc_unlock(void);
266
267/** Initialize heap storage.
268 * \param addr Pointer to an array of lbm_cons_t elements. This array must at least be aligned 4.
269 * \param num_cells Number of lbm_cons_t elements in the array.
270 * \param gc_stack_size Size of the gc_stack in number of words.
271 * \return 1 on success or 0 for failure.
272 */
273int lbm_heap_init(lbm_cons_t *addr, lbm_uint num_cells,
274 lbm_uint gc_stack_size);
275
276/** Add GC time statistics to heap_stats
277 *
278 * \param dur Duration as reported by the timestamp callback.
279 */
280void lbm_heap_new_gc_time(lbm_uint dur);
281/** Add a new free_list length to the heap_stats.
282 * Calculates a new freelist length and updates
283 * the GC statistics.
284 */
285void lbm_heap_new_freelist_length(void);
286/** Check how many lbm_cons_t cells are on the free-list
287 *
288 * \return Number of free lbm_cons_t cells.
289 */
290lbm_uint lbm_heap_num_free(void);
291/** Check how many lbm_cons_t cells are allocated.
292 *
293 * \return Number of lbm_cons_t cells that are currently allocated.
294 */
295lbm_uint lbm_heap_num_allocated(void);
296/** Size of the heap in number of lbm_cons_t cells.
297 *
298 * \return Size of the heap in number of lbm_cons_t cells.
299 */
300lbm_uint lbm_heap_size(void);
301/** Size of the heap in bytes.
302 *
303 * \return Size of heap in bytes.
304 */
305lbm_uint lbm_heap_size_bytes(void);
306/** Allocate an lbm_cons_t cell from the heap.
307 *
308 * \param type A type that can be encoded onto the cell (most often LBM_PTR_TYPE_CONS).
309 * \param car Value to write into car position of allocated cell.
310 * \param cdr Value to write into cdr position of allocated cell.
311 * \return An lbm_value referring to a cons_cell or enc_sym(SYM_MERROR) in case the heap is full.
312 */
313lbm_value lbm_heap_allocate_cell(lbm_type type, lbm_value car, lbm_value cdr);
314/** Allocate a list of n heap-cells.
315 * \param n The number of heap-cells to allocate.
316 * \return A list of heap-cells of Memory error if unable to allocate.
317 */
318lbm_value lbm_heap_allocate_list(lbm_uint n);
319/** Allocate a list of n heap-cells and initialize the values.
320 * \pram ls The result list is passed through this ptr.
321 * \param n The length of list to allocate.
322 * \param valist The values in a va_list to initialize the list with.
323 * \return True of False depending on success of allocation.
324 */
325lbm_value lbm_heap_allocate_list_init_va(unsigned int n, va_list valist);
326/** Allocate a list of n heap-cells and initialize the values.
327 * \param n The length of list to allocate.
328 * \param ... The values to initialize the list with.
329 * \return allocated list or error symbol.
330 */
331lbm_value lbm_heap_allocate_list_init(unsigned int n, ...);
332/** Decode an lbm_value representing a string into a C string
333 *
334 * \param val Value
335 * \return allocated list or error symbol
336 */
337char *lbm_dec_str(lbm_value val);
338/** Decode an lbm_value representing a char channel into an lbm_char_channel_t pointer.
339 *
340 * \param val Value
341 * \return A pointer to an lbm_char_channel_t or NULL if the value does not encode a channel.
342 */
343lbm_char_channel_t *lbm_dec_channel(lbm_value val);
344/** Decode an lbm_value representing a custom type into a lbm_uint value.
345 *
346 * \param val Value.
347 * \return The custom type payload.
348 */
349lbm_uint lbm_dec_custom(lbm_value val);
350/** Decode a numerical value as if it is char
351 *
352 * \param val Value to decode
353 * \return The value encoded in val casted to a char. Returns 0 if val does not encode a number.
354 */
355uint8_t lbm_dec_as_char(lbm_value a);
356/** Decode a numerical value as if it is unsigned
357 *
358 * \param val Value to decode
359 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
360 */
361uint32_t lbm_dec_as_u32(lbm_value val);
362/** Decode a numerical value as a signed integer.
363 *
364 * \param val Value to decode
365 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
366 */
367int32_t lbm_dec_as_i32(lbm_value val);
368/** Decode a numerical value as a float.
369 *
370 * \param val Value to decode.
371 * \return The value encoded in val casted to a float. Returns 0 if val does not encode a number.
372 */
373float lbm_dec_as_float(lbm_value val);
374/** Decode a numerical value as if it is a 64bit unsigned
375 *
376 * \param val Value to decode
377 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
378 */
379uint64_t lbm_dec_as_u64(lbm_value val);
380/** Decode a numerical value as a 64bit signed integer.
381 *
382 * \param val Value to decode
383 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
384 */
385int64_t lbm_dec_as_i64(lbm_value val);
386/** Decode a numerical value as a float.
387 *
388 * \param val Value to decode.
389 * \return The value encoded in val casted to a float. Returns 0 if val does not encode a number.
390 */
391double lbm_dec_as_double(lbm_value val);
392
393/** Decode a numerical value into the architecture defined unsigned integer type.
394 *
395 * \param val Value to decode
396 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
397 */
398lbm_uint lbm_dec_as_uint(lbm_value val);
399
400/** Decode a numerical value into the architecture defined signed integer type.
401 *
402 * \param val Value to decode
403 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
404 */
405lbm_int lbm_dec_as_int(lbm_value val);
406
407lbm_uint lbm_dec_raw(lbm_value v);
408/** Allocates an lbm_cons_t cell from the heap and populates it.
409 *
410 * \param car The value to put in the car field of the allocated lbm_cons_t.
411 * \param cdr The value to put in the cdr field of the allocated lbm_cons_t.
412 * \return A value referencing the lbm_cons_t or enc_sym(SYM_MERROR) if heap is full.
413 */
414lbm_value lbm_cons(lbm_value car, lbm_value cdr);
415
416/** Accesses the car field of an lbm_cons_t.
417 *
418 * \param cons Value
419 * \return The car field of the lbm_cons_t if cons is a reference to a heap cell.
420 * If cons is nil, the return value is nil. If the value
421 * is not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
422 */
423lbm_value lbm_car(lbm_value cons);
424/** Accesses the car field the car field of an lbm_cons_t.
425 *
426 * \param cons Value
427 * \return The car of car field or nil.
428 */
429lbm_value lbm_caar(lbm_value c);
430/** Accesses the car of the cdr of an cons cell
431 *
432 * \param c Value
433 * \return the cdr field or type error.
434 */
435lbm_value lbm_cadr(lbm_value c);
436/** Accesses the cdr field of an lbm_cons_t.
437 *
438 * \param cons Value
439 * \return The cdr field of the lbm_cons_t if cons is a reference to a heap cell.
440 * If cons is nil, the return value is nil. If the value
441 * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
442 */
443lbm_value lbm_cdr(lbm_value cons);
444/** Accesses the cdr of an cdr field of an lbm_cons_t.
445 *
446 * \param cons Value
447 * \return The cdr of the cdr field of the lbm_cons_t if cons is a reference to a heap cell.
448 * If cons is nil, the return value is nil. If the value
449 * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
450 */
451lbm_value lbm_cddr(lbm_value c);
452/** Update the value stored in the car field of a heap cell.
453 *
454 * \param c Value referring to a heap cell.
455 * \param v Value to replace the car field with.
456 * \return 1 on success and 0 if the c value does not refer to a heap cell.
457 */
458int lbm_set_car(lbm_value c, lbm_value v);
459/** Update the value stored in the cdr field of a heap cell.
460 *
461 * \param c Value referring to a heap cell.
462 * \param v Value to replace the cdr field with.
463 * \return 1 on success and 0 if the c value does not refer to a heap cell.
464 */
465int lbm_set_cdr(lbm_value c, lbm_value v);
466/** Update the value stored in the car and cdr fields of a heap cell.
467 *
468 * \param c Value referring to a heap cell.
469 * \param car_val Value to replace the car field with.
470 * \param cdr_val Value to replace the cdr field with.
471 * \return 1 on success and 0 if the c value does not refer to a heap cell.
472 */
473int lbm_set_car_and_cdr(lbm_value c, lbm_value car_val, lbm_value cdr_val);
474// List functions
475/** Calculate the length of a proper list
476 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
477 * may lead to the function not terminating.
478 *
479 * \param c A list
480 * \return The length of the list. Unless the value is a cyclic structure on the heap, this function will terminate.
481 */
482lbm_uint lbm_list_length(lbm_value c);
483
484/** Calculate the length of a proper list and evaluate a predicate for each element.
485 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
486 * may lead to the function not terminating.
487 *
488 * \param c A list
489 * \param pres Boolean result of predicate, false if predicate is false for any of the elements in the list, otherwise true.
490 * \param pred Predicate to evaluate for each element of the list.
491 */
492unsigned int lbm_list_length_pred(lbm_value c, bool_Bool *pres, bool_Bool (*pred)(lbm_value));
493/** Reverse a proper list
494 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
495 * may lead to the function not terminating.
496 *
497 * \param list A list
498 * \return The list reversed or enc_sym(SYM_MERROR) if heap is full.
499 */
500lbm_value lbm_list_reverse(lbm_value list);
501/** Reverse a proper list destroying the original.
502 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
503 * may lead to the function not terminating.
504 *
505 * \param list A list
506 * \return The list reversed
507 */
508lbm_value lbm_list_destructive_reverse(lbm_value list);
509/** Copy a list
510 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
511 * may lead to the function not terminating.
512 *
513 * \param m Number of elements to copy or -1 for all. If 1, m will be updated with the length of the list
514 * \param list A list.
515 * \return Reversed list or enc_sym(SYM_MERROR) if heap is full.
516 */
517lbm_value lbm_list_copy(int *m, lbm_value list);
518
519/** A destructive append of two lists
520 *
521 * \param list1 A list
522 * \param list2 A list
523 * \return list1 with list2 appended at the end.
524 */
525lbm_value lbm_list_append(lbm_value list1, lbm_value list2);
526
527/** Drop values from the head of a list.
528 * \param n Number of values to drop.
529 * \param ls List to drop values from.
530 * \return The list with the n first elements removed.
531 */
532lbm_value lbm_list_drop(unsigned int n, lbm_value ls);
533/** Index into a list.
534 * \param l List to index into.
535 * \param n Position to read out of the list.
536 * \return Value at position n of l or nil if out of bounds.
537 */
538lbm_value lbm_index_list(lbm_value l, int32_t n);
539
540// State and statistics
541/** Get a copy of the heap statistics structure.
542 *
543 * \param A pointer to an lbm_heap_state_t to populate
544 * with the current statistics.
545 */
546void lbm_get_heap_state(lbm_heap_state_t *);
547/** Get the maximum stack level of the GC stack
548 * \return maximum value the gc stack sp reached so far.
549 */
550lbm_uint lbm_get_gc_stack_max(void);
551/** Get the size of the GC stack.
552 * \return the size of the gc stack.
553 */
554lbm_uint lbm_get_gc_stack_size(void);
555// Garbage collection
556/** Increment the counter that is counting the number of times GC ran
557 *
558 */
559void lbm_gc_state_inc(void);
560/** Set the freelist to NIL. Means that no memory will be available
561 * until after a garbage collection.
562 */
563void lbm_nil_freelist(void);
564/** Mark all heap cells reachable from an environment.
565 * \param environment.
566 */
567void lbm_gc_mark_env(lbm_value);
568/** Mark heap cells reachable from the lbm_value v.
569 * \param root
570 */
571void lbm_gc_mark_phase(lbm_value root);
572/** Performs lbm_gc_mark_phase on all the values of an array.
573 * This function is similar to lbm_gc_mark_roots but performs
574 * extra checks to not traverse into non-standard values.
575 * TODO: Check if this function is really needed.
576 * \param data Array of roots to traverse from.
577 * \param n Number of elements in roots-array.
578 */
579void lbm_gc_mark_aux(lbm_uint *data, lbm_uint n);
580/** Performs lbm_gc_mark_phase on all the values in the roots array.
581 * \param roots pointer to array of roots.
582 * \param num_roots size of array of roots.
583 */
584void lbm_gc_mark_roots(lbm_uint *roots, lbm_uint num_roots);
585/** Sweep up all non marked heap cells and place them on the free list.
586 *
587 * \return 1
588 */
589int lbm_gc_sweep_phase(void);
590
591// Array functionality
592/** Allocate an bytearray in symbols and arrays memory (lispbm_memory.h)
593 * and create a heap cell that refers to this bytearray.
594 * \param res The resulting lbm_value is returned through this argument.
595 * \param size Array size in number of 32 bit words.
596 * \return 1 for success of 0 for failure.
597 */
598int lbm_heap_allocate_array(lbm_value *res, lbm_uint size);
599/** Allocate an array in symbols and arrays memory (lispbm_memory.h)
600 * and create a heap cell that refers to this array.
601 * \param res The resulting lbm_value is returned through this argument.
602 * \param size Array size in number of 32 bit words.
603 * \return 1 for success of 0 for failure.
604 */
605int lbm_heap_allocate_lisp_array(lbm_value *res, lbm_uint size);
606/** Convert a C array into an lbm array. If the C array is allocated in LBM MEMORY
607 * the lifetime of the array will be managed by GC.
608 * \param res lbm_value result pointer for storage of the result array.
609 * \param data C array.
610 * \param type The type tag to assign to the resulting LBM array.
611 * \param num_elt Number of elements in the array.
612 * \return 1 for success and 0 for failure.
613 */
614int lbm_lift_array(lbm_value *value, char *data, lbm_uint num_elt);
615/** Get the size of an array value.
616 * \param arr lbm_value array to get size of.
617 * \return -1 for failure or length of array.
618 */
619lbm_int lbm_heap_array_get_size(lbm_value arr);
620/** Get a pointer to the data of an array for read only purposes.
621 * \param arr lbm_value array to get pointer from.
622 * \return NULL or valid pointer.
623 */
624const uint8_t *lbm_heap_array_get_data_ro(lbm_value arr);
625/** Get a pointer to the data of an array for read/write purposes.
626 * \param arr lbm_value array to get pointer from.
627 * \return NULL or valid pointer.
628 */
629uint8_t *lbm_heap_array_get_data_rw(lbm_value arr);
630/** Explicitly free an array.
631 * This function needs to be used with care and knowledge.
632 * \param arr Array value.
633 */
634int lbm_heap_explicit_free_array(lbm_value arr);
635/** Query the size in bytes of an lbm_type.
636 * \param t Type
637 * \return Size in bytes of type or 0 if the type represents a composite.
638 */
639lbm_uint lbm_size_of(lbm_type t);
640
641int lbm_const_heap_init(const_heap_write_fun w_fun,
642 lbm_const_heap_t *heap,
643 lbm_uint *addr,
644 lbm_uint num_words);
645
646lbm_flash_status lbm_allocate_const_cell(lbm_value *res);
647lbm_flash_status lbm_write_const_raw(lbm_uint *data, lbm_uint n, lbm_uint *res);
648lbm_flash_status lbm_allocate_const_raw(lbm_uint nwords, lbm_uint *res);
649lbm_flash_status write_const_cdr(lbm_value cell, lbm_value val);
650lbm_flash_status write_const_car(lbm_value cell, lbm_value val);
651lbm_flash_status lbm_const_write(lbm_uint *tgt, lbm_uint val);
652lbm_uint lbm_flash_memory_usage(void);
653
654/** Query the type information of a value.
655 *
656 * \param x Value to check the type of.
657 * \return The type information.
658 */
659static inline lbm_type lbm_type_of(lbm_value x) {
660 return (x & LBM_PTR_BIT0x00000001u) ? (x & LBM_PTR_TYPE_MASK0xFC000000u) : (x & LBM_VAL_TYPE_MASK0x0000000Cu);
661}
662
663// type-of check that is safe in functional code
664static inline lbm_type lbm_type_of_functional(lbm_value x) {
665 return (x & LBM_PTR_BIT0x00000001u) ?
666 (x & (LBM_PTR_TO_CONSTANT_MASK~0x04000000u & LBM_PTR_TYPE_MASK0xFC000000u)) :
667 (x & LBM_VAL_TYPE_MASK0x0000000Cu);
668}
669
670static inline lbm_value lbm_enc_cons_ptr(lbm_uint x) {
671 return ((x << LBM_ADDRESS_SHIFT2) | LBM_TYPE_CONS0x10000000u | LBM_PTR_BIT0x00000001u);
672}
673
674static inline lbm_uint lbm_dec_ptr(lbm_value p) {
675 return ((LBM_PTR_VAL_MASK0x03FFFFFCu & p) >> LBM_ADDRESS_SHIFT2);
676}
677
678extern lbm_cons_t *lbm_heaps[2];
679
680static inline lbm_uint lbm_dec_cons_cell_ptr(lbm_value p) {
681 lbm_uint h = (p & LBM_PTR_TO_CONSTANT_BIT0x04000000u) >> LBM_PTR_TO_CONSTANT_SHIFT26;
682 return lbm_dec_ptr(p) >> h;
683}
684
685static inline lbm_cons_t *lbm_dec_heap(lbm_value p) {
686 lbm_uint h = (p & LBM_PTR_TO_CONSTANT_BIT0x04000000u) >> LBM_PTR_TO_CONSTANT_SHIFT26;
687 return lbm_heaps[h];
688}
689
690static inline lbm_value lbm_set_ptr_type(lbm_value p, lbm_type t) {
691 return ((LBM_PTR_VAL_MASK0x03FFFFFCu & p) | t | LBM_PTR_BIT0x00000001u);
692}
693
694static inline lbm_value lbm_enc_sym(lbm_uint s) {
695 return (s << LBM_VAL_SHIFT4) | LBM_TYPE_SYMBOL0x00000000u;
696}
697
698static inline lbm_value lbm_enc_i(lbm_int x) {
699 return ((lbm_uint)x << LBM_VAL_SHIFT4) | LBM_TYPE_I0x00000008u;
700}
701
702static inline lbm_value lbm_enc_u(lbm_uint x) {
703 return (x << LBM_VAL_SHIFT4) | LBM_TYPE_U0x0000000Cu;
704}
705
706/** Encode 32 bit integer into an lbm_value.
707 * \param x Value to encode.
708 * \return result encoded value.
709 */
710extern lbm_value lbm_enc_i32(int32_t x);
711
712/** Encode 32 bit unsigned integer into an lbm_value.
713 * \param x Value to encode.
714 * \return result encoded value.
715 */
716extern lbm_value lbm_enc_u32(uint32_t x);
717
718/** Encode a float into an lbm_value.
719 * \param x float value to encode.
720 * \return result encoded value.
721 */
722extern lbm_value lbm_enc_float(float x);
723
724/** Encode a 64 bit integer into an lbm_value.
725 * \param x 64 bit integer to encode.
726 * \return result encoded value.
727 */
728extern lbm_value lbm_enc_i64(int64_t x);
729
730/** Encode a 64 bit unsigned integer into an lbm_value.
731 * \param x 64 bit unsigned integer to encode.
732 * \return result encoded value.
733 */
734extern lbm_value lbm_enc_u64(uint64_t x);
735
736/** Encode a double into an lbm_value.
737 * \param x double to encode.
738 * \return result encoded value.
739 */
740extern lbm_value lbm_enc_double(double x);
741
742static inline lbm_value lbm_enc_char(uint8_t x) {
743 return ((lbm_uint)x << LBM_VAL_SHIFT4) | LBM_TYPE_CHAR0x00000004u;
744}
745
746static inline lbm_int lbm_dec_i(lbm_value x) {
747 return (lbm_int)x >> LBM_VAL_SHIFT4;
748}
749
750static inline lbm_uint lbm_dec_u(lbm_value x) {
751 return x >> LBM_VAL_SHIFT4;
752}
753
754static inline uint8_t lbm_dec_char(lbm_value x) {
755 return (uint8_t)(x >> LBM_VAL_SHIFT4);
756}
757
758static inline lbm_uint lbm_dec_sym(lbm_value x) {
759 return x >> LBM_VAL_SHIFT4;
760}
761
762/** Decode an lbm_value representing a float.
763 * \param x Value to decode.
764 * \return decoded float.
765 */
766extern float lbm_dec_float(lbm_value x);
767
768/** Decode an lbm_value representing a double.
769 * \param x Value to decode.
770 * \return decoded float.
771 */
772extern double lbm_dec_double(lbm_value x);
773
774
775static inline uint32_t lbm_dec_u32(lbm_value x) {
776#ifndef LBM64
777 return (uint32_t)lbm_car(x);
778#else
779 return (uint32_t)(x >> LBM_VAL_SHIFT4);
780#endif
781}
782
783/** Decode an lbm_value representing a 64 bit unsigned integer.
784 * \param x Value to decode.
785 * \return decoded uint64_t.
786 */
787extern uint64_t lbm_dec_u64(lbm_value x);
788
789static inline int32_t lbm_dec_i32(lbm_value x) {
790#ifndef LBM64
791 return (int32_t)lbm_car(x);
792#else
793 return (int32_t)(x >> LBM_VAL_SHIFT4);
794#endif
795}
796
797/** Decode an lbm_value representing a 64 bit integer.
798 * \param x Value to decode.
799 * \return decoded int64_t.
800 */
801extern int64_t lbm_dec_i64(lbm_value x);
802
803/**
804 * Check if a value is a heap pointer
805 * \param x Value to check
806 * \return true if x is a pointer to a heap cell, false otherwise.
807 */
808static inline bool_Bool lbm_is_ptr(lbm_value x) {
809 return (x & LBM_PTR_BIT0x00000001u);
810}
811
812/**
813 * Check if a value is a Read/Writeable cons cell
814 * \param x Value to check
815 * \return true if x is a Read/Writeable cons cell, false otherwise.
816 */
817static inline bool_Bool lbm_is_cons_rw(lbm_value x) {
818 return (lbm_type_of(x) == LBM_TYPE_CONS0x10000000u);
819}
820
821/**
822 * Check if a value is a Readable cons cell
823 * \param x Value to check
824 * \return true if x is a readable cons cell, false otherwise.
825 */
826static inline bool_Bool lbm_is_cons(lbm_value x) {
827 return lbm_is_ptr(x) && ((x & LBM_CONS_TYPE_MASK0xF0000000u) == LBM_TYPE_CONS0x10000000u);
828}
829
830/** Check if a value represents a number
831 * \param x Value to check.
832 * \return true is x represents a number and false otherwise.
833 */
834static inline bool_Bool lbm_is_number(lbm_value x) {
835 return
836 (x & LBM_PTR_BIT0x00000001u) ?
837 ((x & LBM_NUMBER_MASK0x08000000u) == LBM_NUMBER_MASK0x08000000u) :
838 (x & LBM_VAL_TYPE_MASK0x0000000Cu);
839}
840
841/** Check if value is an array that can be READ
842 * \param x Value to check.
843 * \return true if x represents a readable array and false otherwise.
844 */
845static inline bool_Bool lbm_is_array_r(lbm_value x) {
846 lbm_type t = lbm_type_of(x);
847 return ((t & LBM_PTR_TO_CONSTANT_MASK~0x04000000u) == LBM_TYPE_ARRAY0x80000000u);
848}
849
850static inline bool_Bool lbm_is_array_rw(lbm_value x) {
851 return( (lbm_type_of(x) == LBM_TYPE_ARRAY0x80000000u) && !(x & LBM_PTR_TO_CONSTANT_BIT0x04000000u));
852}
853
854static inline bool_Bool lbm_is_lisp_array_r(lbm_value x) {
855 lbm_type t = lbm_type_of(x);
856 return ((t & LBM_PTR_TO_CONSTANT_MASK~0x04000000u) == LBM_TYPE_LISPARRAY0xB0000000u);
857}
858
859static inline bool_Bool lbm_is_lisp_array_rw(lbm_value x) {
860 return( (lbm_type_of(x) == LBM_TYPE_LISPARRAY0xB0000000u) && !(x & LBM_PTR_TO_CONSTANT_BIT0x04000000u));
861}
862
863
864static inline bool_Bool lbm_is_channel(lbm_value x) {
865 return (lbm_type_of(x) == LBM_TYPE_CHANNEL0x90000000u &&
866 lbm_type_of(lbm_cdr(x)) == LBM_TYPE_SYMBOL0x00000000u &&
867 lbm_cdr(x) == ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
868}
869static inline bool_Bool lbm_is_char(lbm_value x) {
870 return (lbm_type_of(x) == LBM_TYPE_CHAR0x00000004u);
871}
872
873static inline bool_Bool lbm_is_special(lbm_value symrep) {
874 return ((lbm_type_of(symrep) == LBM_TYPE_SYMBOL0x00000000u) &&
875 (lbm_dec_sym(symrep) < SPECIAL_SYMBOLS_END0xFFFF));
876}
877
878static inline bool_Bool lbm_is_closure(lbm_value exp) {
879 return ((lbm_is_cons(exp)) &&
880 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
881 (lbm_car(exp) == ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u)));
882}
883
884static inline bool_Bool lbm_is_continuation(lbm_value exp) {
885 return ((lbm_type_of(exp) == LBM_TYPE_CONS0x10000000u) &&
886 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
887 (lbm_car(exp) == ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u)));
888}
889
890static inline bool_Bool lbm_is_macro(lbm_value exp) {
891 return ((lbm_type_of(exp) == LBM_TYPE_CONS0x10000000u) &&
892 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
893 (lbm_car(exp) == ENC_SYM_MACRO(((0x10D) << 4) | 0x00000000u)));
894}
895
896static inline bool_Bool lbm_is_match_binder(lbm_value exp) {
897 return (lbm_is_cons(exp) &&
898 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
899 (lbm_car(exp) == ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u)));
900}
901
902static inline bool_Bool lbm_is_comma_qualified_symbol(lbm_value exp) {
903 return (lbm_is_cons(exp) &&
904 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
905 (lbm_car(exp) == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) &&
906 (lbm_type_of(lbm_cadr(exp)) == LBM_TYPE_SYMBOL0x00000000u));
907}
908
909static inline bool_Bool lbm_is_symbol(lbm_value exp) {
910 return !(exp & LBM_LOW_RESERVED_BITS0x0000000Fu);
911}
912
913static inline bool_Bool lbm_is_symbol_nil(lbm_value exp) {
914 return !exp;
5
←
Assuming 'exp' is 0
→
6
←
Returning the value 1, which participates in a condition later
→
915}
916
917static inline bool_Bool lbm_is_symbol_true(lbm_value exp) {
918 return (lbm_is_symbol(exp) && exp == ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u));
919}
920
921static inline bool_Bool lbm_is_symbol_eval(lbm_value exp) {
922 return (lbm_is_symbol(exp) && exp == ENC_SYM_EVAL(((0x30008) << 4) | 0x00000000u));
923}
924
925static inline bool_Bool lbm_is_symbol_merror(lbm_value exp) {
926 return lbm_is_symbol(exp) && (exp == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
927}
928
929static inline bool_Bool lbm_is_list(lbm_value x) {
930 return (lbm_is_cons(x) || lbm_is_symbol_nil(x));
931}
932
933static inline bool_Bool lbm_is_list_rw(lbm_value x) {
934 return (lbm_is_cons_rw(x) || lbm_is_symbol_nil(x));
935}
936
937static inline bool_Bool lbm_is_quoted_list(lbm_value x) {
938 return (lbm_is_cons(x) &&
939 lbm_is_symbol(lbm_car(x)) &&
940 (lbm_car(x) == ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u)) &&
941 lbm_is_cons(lbm_cdr(x)) &&
942 lbm_is_cons(lbm_cadr(x)));
943}
944
945#ifndef LBM64
946#define ERROR_SYMBOL_MASK0xFFFFFFF0 0xFFFFFFF0
947#else
948#define ERROR_SYMBOL_MASK0xFFFFFFF0 0xFFFFFFFFFFFFFFF0
949#endif
950
951/* all error signaling symbols are in the range 0x20 - 0x2F */
952static inline bool_Bool lbm_is_error(lbm_value v){
953 return (lbm_is_symbol(v) &&
954 ((lbm_dec_sym(v) & ERROR_SYMBOL_MASK0xFFFFFFF0) == 0x20));
955}
956
957// ref_cell: returns a reference to the cell addressed by bits 3 - 26
958// Assumes user has checked that is_ptr was set
959static inline lbm_cons_t* lbm_ref_cell(lbm_value addr) {
960 return &lbm_dec_heap(addr)[lbm_dec_cons_cell_ptr(addr)];
961 //return &lbm_heap_state.heap[lbm_dec_ptr(addr)];
962}
963
964
965// lbm_uint a = lbm_heaps[0];
966// lbm_uint b = lbm_heaps[1];
967// lbm_uint i = (addr & LBM_PTR_TO_CONSTANT_BIT) >> LBM_PTR_TO_CONSTANT_SHIFT) - 1;
968// lbm_uint h = (a & i) | (b & ~i);
969
970#ifdef __cplusplus
971}
972#endif
973#endif
diff --git a/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-fac31c.html b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-fac31c.html new file mode 100644 index 00000000..c9ed610d --- /dev/null +++ b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/report-fac31c.html @@ -0,0 +1,5548 @@ + + + +src/eval_cps.c + + + + + + + + + + + + + + + + + + + + + + + + + + +

Bug Summary

+ + + + +
File:eval_cps.c
Warning:line 2042, column 13
Assigned value is garbage or undefined
+ +

Annotated Source Code

+

Press '?' + to see keyboard shortcuts

+ + +
clang -cc1 -triple i386-pc-linux-gnu -analyze -disable-free -disable-llvm-verifier -discard-value-names -main-file-name eval_cps.c -analyzer-store=region -analyzer-opt-analyze-nested-blocks -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -mrelocation-model static -mthread-model posix -mframe-pointer=none -fmath-errno -fno-rounding-math -masm-verbose -mconstructor-aliases -target-cpu i686 -dwarf-column-info -fno-split-dwarf-inlining -debugger-tuning=gdb -resource-dir /usr/lib/llvm-10/lib/clang/10.0.0 -I ./include -I ./include/extensions -I platform/linux/include -D _PRELUDE -internal-isystem /usr/local/include -internal-isystem /usr/lib/llvm-10/lib/clang/10.0.0/include -internal-externc-isystem /usr/include/i386-linux-gnu -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -std=c99 -fdebug-compilation-dir /home/joels/Current/lispbm -ferror-limit 19 -fmessage-length 0 -fgnuc-version=4.2.1 -fobjc-runtime=gcc -fdiagnostics-show-option -vectorize-loops -vectorize-slp -analyzer-output=html -faddrsig -o /home/joels/Current/lispbm/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1 -x c src/eval_cps.c +
+ + + +
+ + +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1/*
2 Copyright 2018, 2020 - 2024 Joel Svensson svenssonjoel@yahoo.se
3
4 This program is free software: you can redistribute it and/or modify
5 it under the terms of the GNU General Public License as published by
6 the Free Software Foundation, either version 3 of the License, or
7 (at your option) any later version.
8
9 This program is distributed in the hope that it will be useful,
10 but WITHOUT ANY WARRANTY; without even the implied warranty of
11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 GNU General Public License for more details.
13
14 You should have received a copy of the GNU General Public License
15 along with this program. If not, see <http://www.gnu.org/licenses/>.
16*/
17
18#include <lbm_memory.h>
19#include <lbm_types.h>
20#include "symrepr.h"
21#include "heap.h"
22#include "env.h"
23#include "eval_cps.h"
24#include "stack.h"
25#include "fundamental.h"
26#include "extensions.h"
27#include "tokpar.h"
28#include "lbm_channel.h"
29#include "print.h"
30#include "platform_mutex.h"
31#include "lbm_flat_value.h"
32#include "lbm_flags.h"
33
34#ifdef VISUALIZE_HEAP
35#include "heap_vis.h"
36#endif
37
38#include <setjmp.h>
39#include <stdarg.h>
40
41static jmp_buf error_jmp_buf;
42static jmp_buf critical_error_jmp_buf;
43
44#define S_TO_US(X)(lbm_uint)((X) * 1000000) (lbm_uint)((X) * 1000000)
45
46#define DEC_CONTINUATION(x)(((x) & ~0xF8000001u) >> 2) (((x) & ~LBM_CONTINUATION_INTERNAL0xF8000001u) >> LBM_ADDRESS_SHIFT2)
47#define IS_CONTINUATION(x)(((x) & 0xF8000001u) == 0xF8000001u) (((x) & LBM_CONTINUATION_INTERNAL0xF8000001u) == LBM_CONTINUATION_INTERNAL0xF8000001u)
48#define CONTINUATION(x)(((x) << 2) | 0xF8000001u) (((x) << LBM_ADDRESS_SHIFT2) | LBM_CONTINUATION_INTERNAL0xF8000001u)
49
50#define DONE(((0) << 2) | 0xF8000001u) CONTINUATION(0)(((0) << 2) | 0xF8000001u)
51#define SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u) CONTINUATION(1)(((1) << 2) | 0xF8000001u)
52#define BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u) CONTINUATION(2)(((2) << 2) | 0xF8000001u)
53#define IF(((3) << 2) | 0xF8000001u) CONTINUATION(3)(((3) << 2) | 0xF8000001u)
54#define PROGN_REST(((4) << 2) | 0xF8000001u) CONTINUATION(4)(((4) << 2) | 0xF8000001u)
55#define APPLICATION_ARGS(((5) << 2) | 0xF8000001u) CONTINUATION(5)(((5) << 2) | 0xF8000001u)
56#define AND(((6) << 2) | 0xF8000001u) CONTINUATION(6)(((6) << 2) | 0xF8000001u)
57#define OR(((7) << 2) | 0xF8000001u) CONTINUATION(7)(((7) << 2) | 0xF8000001u)
58#define WAIT(((8) << 2) | 0xF8000001u) CONTINUATION(8)(((8) << 2) | 0xF8000001u)
59#define MATCH(((9) << 2) | 0xF8000001u) CONTINUATION(9)(((9) << 2) | 0xF8000001u)
60#define APPLICATION_START(((10) << 2) | 0xF8000001u) CONTINUATION(10)(((10) << 2) | 0xF8000001u)
61#define EVAL_R(((11) << 2) | 0xF8000001u) CONTINUATION(11)(((11) << 2) | 0xF8000001u)
62#define RESUME(((12) << 2) | 0xF8000001u) CONTINUATION(12)(((12) << 2) | 0xF8000001u)
63#define CLOSURE_ARGS(((13) << 2) | 0xF8000001u) CONTINUATION(13)(((13) << 2) | 0xF8000001u)
64#define EXIT_ATOMIC(((14) << 2) | 0xF8000001u) CONTINUATION(14)(((14) << 2) | 0xF8000001u)
65#define READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u) CONTINUATION(15)(((15) << 2) | 0xF8000001u)
66#define READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u) CONTINUATION(16)(((16) << 2) | 0xF8000001u)
67#define READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u) CONTINUATION(17)(((17) << 2) | 0xF8000001u)
68#define READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u) CONTINUATION(18)(((18) << 2) | 0xF8000001u)
69#define READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u) CONTINUATION(19)(((19) << 2) | 0xF8000001u)
70#define READ_DONE(((20) << 2) | 0xF8000001u) CONTINUATION(20)(((20) << 2) | 0xF8000001u)
71#define READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u) CONTINUATION(21)(((21) << 2) | 0xF8000001u)
72#define READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u) CONTINUATION(22)(((22) << 2) | 0xF8000001u)
73#define READ_COMMA_RESULT(((23) << 2) | 0xF8000001u) CONTINUATION(23)(((23) << 2) | 0xF8000001u)
74#define READ_START_ARRAY(((24) << 2) | 0xF8000001u) CONTINUATION(24)(((24) << 2) | 0xF8000001u)
75#define READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u) CONTINUATION(25)(((25) << 2) | 0xF8000001u)
76#define MAP(((26) << 2) | 0xF8000001u) CONTINUATION(26)(((26) << 2) | 0xF8000001u)
77#define MATCH_GUARD(((27) << 2) | 0xF8000001u) CONTINUATION(27)(((27) << 2) | 0xF8000001u)
78#define TERMINATE(((28) << 2) | 0xF8000001u) CONTINUATION(28)(((28) << 2) | 0xF8000001u)
79#define PROGN_VAR(((29) << 2) | 0xF8000001u) CONTINUATION(29)(((29) << 2) | 0xF8000001u)
80#define SETQ(((30) << 2) | 0xF8000001u) CONTINUATION(30)(((30) << 2) | 0xF8000001u)
81#define MOVE_TO_FLASH(((31) << 2) | 0xF8000001u) CONTINUATION(31)(((31) << 2) | 0xF8000001u)
82#define MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u) CONTINUATION(32)(((32) << 2) | 0xF8000001u)
83#define MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u) CONTINUATION(33)(((33) << 2) | 0xF8000001u)
84#define CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u) CONTINUATION(34)(((34) << 2) | 0xF8000001u)
85#define QQ_EXPAND_START(((35) << 2) | 0xF8000001u) CONTINUATION(35)(((35) << 2) | 0xF8000001u)
86#define QQ_EXPAND(((36) << 2) | 0xF8000001u) CONTINUATION(36)(((36) << 2) | 0xF8000001u)
87#define QQ_APPEND(((37) << 2) | 0xF8000001u) CONTINUATION(37)(((37) << 2) | 0xF8000001u)
88#define QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u) CONTINUATION(38)(((38) << 2) | 0xF8000001u)
89#define QQ_LIST(((39) << 2) | 0xF8000001u) CONTINUATION(39)(((39) << 2) | 0xF8000001u)
90#define KILL(((40) << 2) | 0xF8000001u) CONTINUATION(40)(((40) << 2) | 0xF8000001u)
91#define LOOP(((41) << 2) | 0xF8000001u) CONTINUATION(41)(((41) << 2) | 0xF8000001u)
92#define LOOP_CONDITION(((42) << 2) | 0xF8000001u) CONTINUATION(42)(((42) << 2) | 0xF8000001u)
93#define MERGE_REST(((43) << 2) | 0xF8000001u) CONTINUATION(43)(((43) << 2) | 0xF8000001u)
94#define MERGE_LAYER(((44) << 2) | 0xF8000001u) CONTINUATION(44)(((44) << 2) | 0xF8000001u)
95#define CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u) CONTINUATION(45)(((45) << 2) | 0xF8000001u)
96#define MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u) CONTINUATION(46)(((46) << 2) | 0xF8000001u)
97#define POP_READER_FLAGS(((47) << 2) | 0xF8000001u) CONTINUATION(47)(((47) << 2) | 0xF8000001u)
98#define EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u) CONTINUATION(48)(((48) << 2) | 0xF8000001u)
99#define NUM_CONTINUATIONS49 49
100
101#define FM_NEED_GC-1 -1
102#define FM_NO_MATCH-2 -2
103#define FM_PATTERN_ERROR-3 -3
104
105typedef enum {
106 BL_OK = 0,
107 BL_NO_MEMORY,
108 BL_INCORRECT_KEY
109} binding_location_status;
110
111#define FB_OK0 0
112#define FB_TYPE_ERROR-1 -1
113
114const char* lbm_error_str_parse_eof = "End of parse stream.";
115const char* lbm_error_str_parse_dot = "Incorrect usage of '.'.";
116const char* lbm_error_str_parse_close = "Expected closing parenthesis.";
117const char* lbm_error_str_num_args = "Incorrect number of arguments.";
118const char* lbm_error_str_forbidden_in_atomic = "Operation is forbidden in an atomic block.";
119const char* lbm_error_str_no_number = "Argument(s) must be a number.";
120const char* lbm_error_str_not_a_boolean = "Argument must be t or nil (true or false).";
121const char* lbm_error_str_incorrect_arg = "Incorrect argument.";
122const char* lbm_error_str_var_outside_progn = "Usage of var outside of progn.";
123const char* lbm_error_str_flash_not_possible = "Value cannot be written to flash.";
124const char* lbm_error_str_flash_error = "Error writing to flash.";
125const char* lbm_error_str_flash_full = "Flash memory is full.";
126const char* lbm_error_str_variable_not_bound = "Variable not bound.";
127
128static lbm_value lbm_error_suspect;
129static bool_Bool lbm_error_has_suspect = false0;
130#ifdef LBM_ALWAYS_GC
131
132#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
133 gc(); \
134 (y) = (x); \
135 if (lbm_is_symbol_merror((y))) { \
136 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
137 }
138
139#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
140 lbm_gc_mark_phase(r); \
141 gc(); \
142 (y) = (x); \
143 if (lbm_is_symbol_merror((y))) { \
144 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
145 }
146
147#else
148
149#define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if
(lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } } \
150 (y) = (x); \
151 if (lbm_is_symbol_merror((y))) { \
152 gc(); \
153 (y) = (x); \
154 if (lbm_is_symbol_merror((y))) { \
155 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
156 } \
157 /* continue executing statements below */ \
158 }
159#define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase
(r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } } \
160 (y) = (x); \
161 if (lbm_is_symbol_merror((y))) { \
162 lbm_gc_mark_phase(r); \
163 gc(); \
164 (y) = (x); \
165 if (lbm_is_symbol_merror((y))) { \
166 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \
167 } \
168 /* continue executing statements below */ \
169 }
170
171#endif
172
173typedef struct {
174 eval_context_t *first;
175 eval_context_t *last;
176} eval_context_queue_t;
177
178#ifdef CLEAN_UP_CLOSURES
179static lbm_value clean_cl_env_symbol = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
180#endif
181
182static int gc(void);
183static void error_ctx(lbm_value);
184static void error_at_ctx(lbm_value err_val, lbm_value at);
185static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx);
186static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail);
187
188// The currently executing context.
189eval_context_t *ctx_running = NULL((void*)0);
190volatile bool_Bool lbm_system_sleeping = false0;
191
192static volatile bool_Bool gc_requested = false0;
193void lbm_request_gc(void) {
194 gc_requested = true1;
195}
196
197/*
198 On ChibiOs the CH_CFG_ST_FREQUENCY setting in chconf.h sets the
199 resolution of the timer used for sleep operations. If this is set
200 to 10KHz the resolution is 100us.
201
202 The CH_CFG_ST_TIMEDELTA specifies the minimum number of ticks that
203 can be safely specified in a timeout directive (wonder if that
204 means sleep-period). The timedelta is set to 2.
205
206 If I have understood these correctly it means that the minimum
207 sleep duration possible is 2 * 100us = 200us.
208*/
209
210#define EVAL_CPS_DEFAULT_STACK_SIZE256 256
211#define EVAL_CPS_MIN_SLEEP200 200
212#define EVAL_STEPS_QUOTA10 10
213
214static volatile uint32_t eval_steps_refill = EVAL_STEPS_QUOTA10;
215static uint32_t eval_steps_quota = EVAL_STEPS_QUOTA10;
216
217void lbm_set_eval_step_quota(uint32_t quota) {
218 eval_steps_refill = quota;
219}
220
221static uint32_t eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
222static volatile uint32_t eval_cps_next_state = EVAL_CPS_STATE_NONE0;
223static volatile uint32_t eval_cps_next_state_arg = 0;
224static volatile bool_Bool eval_cps_state_changed = false0;
225
226static void usleep_nonsense(uint32_t us) {
227 (void) us;
228}
229
230static bool_Bool dynamic_load_nonsense(const char *sym, const char **code) {
231 (void) sym;
232 (void) code;
233 return false0;
234}
235
236static uint32_t timestamp_nonsense(void) {
237 return 0;
238}
239
240static int printf_nonsense(const char *fmt, ...) {
241 (void) fmt;
242 return 0;
243}
244
245static void ctx_done_nonsense(eval_context_t *ctx) {
246 (void) ctx;
247}
248
249static void critical_nonsense(void) {
250 return;
251}
252
253static void (*critical_error_callback)(void) = critical_nonsense;
254static void (*usleep_callback)(uint32_t) = usleep_nonsense;
255static uint32_t (*timestamp_us_callback)(void) = timestamp_nonsense;
256static void (*ctx_done_callback)(eval_context_t *) = ctx_done_nonsense;
257static int (*printf_callback)(const char *, ...) = printf_nonsense;
258static bool_Bool (*dynamic_load_callback)(const char *, const char **) = dynamic_load_nonsense;
259
260void lbm_set_critical_error_callback(void (*fptr)(void)) {
261 if (fptr == NULL((void*)0)) critical_error_callback = critical_nonsense;
262 else critical_error_callback = fptr;
263}
264
265void lbm_set_usleep_callback(void (*fptr)(uint32_t)) {
266 if (fptr == NULL((void*)0)) usleep_callback = usleep_nonsense;
267 else usleep_callback = fptr;
268}
269
270void lbm_set_timestamp_us_callback(uint32_t (*fptr)(void)) {
271 if (fptr == NULL((void*)0)) timestamp_us_callback = timestamp_nonsense;
272 else timestamp_us_callback = fptr;
273}
274
275void lbm_set_ctx_done_callback(void (*fptr)(eval_context_t *)) {
276 if (fptr == NULL((void*)0)) ctx_done_callback = ctx_done_nonsense;
277 else ctx_done_callback = fptr;
278}
279
280void lbm_set_printf_callback(int (*fptr)(const char*, ...)){
281 if (fptr == NULL((void*)0)) printf_callback = printf_nonsense;
282 else printf_callback = fptr;
283}
284
285void lbm_set_dynamic_load_callback(bool_Bool (*fptr)(const char *, const char **)) {
286 if (fptr == NULL((void*)0)) dynamic_load_callback = dynamic_load_nonsense;
287 else dynamic_load_callback = fptr;
288}
289
290static volatile lbm_event_t *lbm_events = NULL((void*)0);
291static unsigned int lbm_events_head = 0;
292static unsigned int lbm_events_tail = 0;
293static unsigned int lbm_events_max = 0;
294static bool_Bool lbm_events_full = false0;
295static mutex_t lbm_events_mutex;
296static bool_Bool lbm_events_mutex_initialized = false0;
297static volatile lbm_cid lbm_event_handler_pid = -1;
298
299lbm_cid lbm_get_event_handler_pid(void) {
300 return lbm_event_handler_pid;
301}
302
303void lbm_set_event_handler_pid(lbm_cid pid) {
304 lbm_event_handler_pid = pid;
305}
306
307bool_Bool lbm_event_handler_exists(void) {
308 return(lbm_event_handler_pid > 0);
309}
310
311
312static bool_Bool event_internal(lbm_event_type_t event_type, lbm_uint parameter, lbm_uint buf_ptr, lbm_uint buf_len) {
313 bool_Bool r = false0;
314 if (lbm_events) {
315 mutex_lock(&lbm_events_mutex);
316 if (!lbm_events_full) {
317 lbm_event_t event;
318 event.type = event_type;
319 event.parameter = parameter;
320 event.buf_ptr = buf_ptr;
321 event.buf_len = buf_len;
322 lbm_events[lbm_events_head] = event;
323 lbm_events_head = (lbm_events_head + 1) % lbm_events_max;
324 lbm_events_full = lbm_events_head == lbm_events_tail;
325 r = true1;
326 }
327 mutex_unlock(&lbm_events_mutex);
328 }
329 return r;
330}
331
332bool_Bool lbm_event_define(lbm_value key, lbm_flat_value_t *fv) {
333 return event_internal(LBM_EVENT_DEFINE, key, (lbm_uint)fv->buf, fv->buf_size);
334}
335
336bool_Bool lbm_event_unboxed(lbm_value unboxed) {
337 lbm_uint t = lbm_type_of(unboxed);
338 if (t == LBM_TYPE_SYMBOL0x00000000u ||
339 t == LBM_TYPE_I0x00000008u ||
340 t == LBM_TYPE_U0x0000000Cu ||
341 t == LBM_TYPE_CHAR0x00000004u) {
342 if (lbm_event_handler_pid > 0) {
343 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)unboxed, 0);
344 }
345 }
346 return false0;
347}
348
349bool_Bool lbm_event(lbm_flat_value_t *fv) {
350 if (lbm_event_handler_pid > 0) {
351 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)fv->buf, fv->buf_size);
352 }
353 return false0;
354}
355
356static bool_Bool lbm_event_pop(lbm_event_t *event) {
357 mutex_lock(&lbm_events_mutex);
358 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
359 mutex_unlock(&lbm_events_mutex);
360 return false0;
361 }
362 *event = lbm_events[lbm_events_tail];
363 lbm_events_tail = (lbm_events_tail + 1) % lbm_events_max;
364 lbm_events_full = false0;
365 mutex_unlock(&lbm_events_mutex);
366 return true1;
367}
368
369bool_Bool lbm_event_queue_is_empty(void) {
370 mutex_lock(&lbm_events_mutex);
371 bool_Bool empty = false0;
372 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
373 empty = true1;
374 }
375 mutex_unlock(&lbm_events_mutex);
376 return empty;
377}
378
379static bool_Bool eval_running = false0;
380static volatile bool_Bool blocking_extension = false0;
381static mutex_t blocking_extension_mutex;
382static bool_Bool blocking_extension_mutex_initialized = false0;
383static lbm_uint blocking_extension_timeout_us = 0;
384static bool_Bool blocking_extension_timeout = false0;
385
386static uint32_t is_atomic = 0;
387
388/* Process queues */
389static eval_context_queue_t blocked = {NULL((void*)0), NULL((void*)0)};
390static eval_context_queue_t queue = {NULL((void*)0), NULL((void*)0)};
391
392/* one mutex for all queue operations */
393mutex_t qmutex;
394bool_Bool qmutex_initialized = false0;
395
396
397// MODES
398static volatile bool_Bool lbm_verbose = false0;
399
400void lbm_toggle_verbose(void) {
401 lbm_verbose = !lbm_verbose;
402}
403
404void lbm_set_verbose(bool_Bool verbose) {
405 lbm_verbose = verbose;
406}
407
408lbm_cid lbm_get_current_cid(void) {
409 if (ctx_running)
410 return ctx_running->id;
411 else
412 return -1;
413}
414
415eval_context_t *lbm_get_current_context(void) {
416 return ctx_running;
417}
418
419/****************************************************/
420/* Utilities used locally in this file */
421
422static lbm_value cons_with_gc(lbm_value head, lbm_value tail, lbm_value remember) {
423#ifdef LBM_ALWAYS_GC
424 lbm_value roots[3] = {head, tail, remember};
425 lbm_gc_mark_roots(roots, 3);
426 gc();
427 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
428 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
429 if (lbm_is_symbol_merror(res)) {
430 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
431 }
432 return res;
433#else
434 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
435 if (lbm_is_symbol_merror(res)) {
436 lbm_value roots[3] = {head, tail, remember};
437 lbm_gc_mark_roots(roots,3);
438 gc();
439 res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail);
440 if (lbm_is_symbol_merror(res)) {
441 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
442 }
443 }
444 return res;
445#endif
446}
447
448static lbm_uint *get_stack_ptr(eval_context_t *ctx, unsigned int n) {
449 if (n <= ctx->K.sp) {
450 lbm_uint index = ctx->K.sp - n;
451 return &ctx->K.data[index];
452 }
453 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
454 return 0; // dead code cannot be reached, but C compiler doesn't realise.
455}
456
457// pop_stack_ptr is safe when no GC is performed and
458// the values of the stack will be dropped.
459static lbm_uint *pop_stack_ptr(eval_context_t *ctx, unsigned int n) {
460 if (n <= ctx->K.sp) {
461 ctx->K.sp -= n;
462 return &ctx->K.data[ctx->K.sp];
463 }
464 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
465 return 0; // dead code cannot be reached, but C compiler doesn't realise.
466}
467
468static inline lbm_uint *stack_reserve(eval_context_t *ctx, unsigned int n) {
469 if (ctx->K.sp + n < ctx->K.size) {
470 lbm_uint *ptr = &ctx->K.data[ctx->K.sp];
471 ctx->K.sp += n;
472 return ptr;
473 }
474 error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u));
475 return 0; // dead code cannot be reached, but C compiler doesn't realise.
476}
477
478static void handle_flash_status(lbm_flash_status s) {
479 if ( s == LBM_FLASH_FULL) {
480 lbm_set_error_reason((char*)lbm_error_str_flash_full);
481 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
482 }
483 if (s == LBM_FLASH_WRITE_ERROR) {
484 lbm_set_error_reason((char*)lbm_error_str_flash_error);
485 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
486 }
487}
488
489static void lift_array_flash(lbm_value flash_cell, bool_Bool bytearray, char *data, lbm_uint num_elt) {
490
491 lbm_array_header_t flash_array_header;
492 flash_array_header.size = num_elt;
493 flash_array_header.data = (lbm_uint*)data;
494 lbm_uint flash_array_header_ptr;
495 handle_flash_status(lbm_write_const_raw((lbm_uint*)&flash_array_header,
496 sizeof(lbm_array_header_t) / sizeof(lbm_uint),
497 &flash_array_header_ptr));
498 handle_flash_status(write_const_car(flash_cell, flash_array_header_ptr));
499 lbm_uint t = bytearray ? ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u) : ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u);
500 handle_flash_status(write_const_cdr(flash_cell, t));
501}
502
503static void get_car_and_cdr(lbm_value a, lbm_value *a_car, lbm_value *a_cdr) {
504 if (lbm_is_ptr(a)) {
4
←
Taking false branch
→
505 lbm_cons_t *cell = lbm_ref_cell(a);
506 *a_car = cell->car;
507 *a_cdr = cell->cdr;
508 } else if (lbm_is_symbol_nil(a)) {
5
←
Taking false branch
→
509 *a_car = *a_cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
510 } else {
511 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
512 }
513}
6
←
Returning without writing to '*a_cdr'
→
514
515/* car cdr caar cadr replacements that are evaluator safe. */
516static lbm_value get_car(lbm_value a) {
517 if (lbm_is_ptr(a)) {
518 lbm_cons_t *cell = lbm_ref_cell(a);
519 return cell->car;
520 } else if (lbm_is_symbol_nil(a)) {
521 return a;
522 }
523 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
524 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
525}
526
527static lbm_value get_cdr(lbm_value a) {
528 if (lbm_is_ptr(a)) {
529 lbm_cons_t *cell = lbm_ref_cell(a);
530 return cell->cdr;
531 } else if (lbm_is_symbol_nil(a)) {
532 return a;
533 }
534 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
535 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
536}
537
538static lbm_value get_cadr(lbm_value a) {
539 if (lbm_is_ptr(a)) {
540 lbm_cons_t *cell = lbm_ref_cell(a);
541 lbm_value tmp = cell->cdr;
542 if (lbm_is_ptr(tmp)) {
543 return lbm_ref_cell(tmp)->car;
544 } else if (lbm_is_symbol_nil(tmp)) {
545 return tmp;
546 }
547 } else if (lbm_is_symbol_nil(a)) {
548 return a;
549 }
550 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
551 return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
552}
553
554static lbm_value allocate_closure(lbm_value params, lbm_value body, lbm_value env) {
555
556#ifdef LBM_ALWAYS_GC
557 gc();
558 if (lbm_heap_num_free() < 4) {
559 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
560 }
561#else
562 if (lbm_heap_num_free() < 4) {
563 gc();
564 if (lbm_heap_num_free() < 4) {
565 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
566 }
567 }
568#endif
569 // The freelist will always contain just plain heap-cells.
570 // So dec_ptr is sufficient.
571 lbm_value res = lbm_heap_state.freelist;
572 if (lbm_type_of(res) == LBM_TYPE_CONS0x10000000u) {
573 lbm_cons_t *heap = lbm_heap_state.heap;
574 lbm_uint ix = lbm_dec_ptr(res);
575 heap[ix].car = ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u);
576 ix = lbm_dec_ptr(heap[ix].cdr);
577 heap[ix].car = params;
578 ix = lbm_dec_ptr(heap[ix].cdr);
579 heap[ix].car = body;
580 ix = lbm_dec_ptr(heap[ix].cdr);
581 heap[ix].car = env;
582 lbm_heap_state.freelist = heap[ix].cdr;
583 heap[ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
584 lbm_heap_state.num_alloc+=4;
585 } else {
586 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
587 }
588 return res;
589}
590
591// Allocate a binding and attach it to a list (if so desired)
592static lbm_value allocate_binding(lbm_value key, lbm_value val, lbm_value the_cdr) {
593 if (lbm_heap_num_free() < 2) {
594 gc();
595 if (lbm_heap_num_free() < 2) {
596 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
597 }
598 }
599 lbm_cons_t* heap = lbm_heap_state.heap;
600 lbm_value binding_cell = lbm_heap_state.freelist;
601 lbm_uint binding_cell_ix = lbm_dec_ptr(binding_cell);
602 lbm_value list_cell = heap[binding_cell_ix].cdr;
603 lbm_uint list_cell_ix = lbm_dec_ptr(list_cell);
604 lbm_heap_state.freelist = heap[list_cell_ix].cdr;
605 lbm_heap_state.num_alloc += 2;
606 heap[binding_cell_ix].car = key;
607 heap[binding_cell_ix].cdr = val;
608 heap[list_cell_ix].car = binding_cell;
609 heap[list_cell_ix].cdr = the_cdr;
610 return list_cell;
611}
612
613#define CLO_PARAMS0 0
614#define CLO_BODY1 1
615#define CLO_ENV2 2
616#define LOOP_BINDS0 0
617#define LOOP_COND1 1
618#define LOOP_BODY2 2
619
620// (a b c) -> [a b c]
621static lbm_value extract_n(lbm_value curr, lbm_value *res, unsigned int n) {
622 for (unsigned int i = 0; i < n; i ++) {
623 if (lbm_is_ptr(curr)) {
624 lbm_cons_t *cell = lbm_ref_cell(curr);
625 res[i] = cell->car;
626 curr = cell->cdr;
627 } else {
628 res[i] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
629 }
630 }
631 return curr; // Rest of list is returned here.
632}
633
634static void call_fundamental(lbm_uint fundamental, lbm_value *args, lbm_uint arg_count, eval_context_t *ctx) {
635 lbm_value res;
636 res = fundamental_table[fundamental](args, arg_count, ctx);
637 if (lbm_is_error(res)) {
638 if (lbm_is_symbol_merror(res)) {
639 gc();
640 res = fundamental_table[fundamental](args, arg_count, ctx);
641 }
642 if (lbm_is_error(res)) {
643 error_at_ctx(res, lbm_enc_sym(FUNDAMENTAL_SYMBOLS_START0x20000 | fundamental));
644 }
645 }
646 lbm_stack_drop(&ctx->K, arg_count+1);
647 ctx->app_cont = true1;
648 ctx->r = res;
649}
650
651// block_current_ctx blocks a context until it is
652// woken up externally or a timeout period of time passes.
653static void block_current_ctx(uint32_t state, lbm_uint sleep_us, bool_Bool do_cont) {
654 ctx_running->timestamp = timestamp_us_callback();
655 ctx_running->sleep_us = sleep_us;
656 ctx_running->state = state;
657 ctx_running->app_cont = do_cont;
658 enqueue_ctx(&blocked, ctx_running);
659 ctx_running = NULL((void*)0);
660}
661
662lbm_flash_status lbm_write_const_array_padded(uint8_t *data, lbm_uint n, lbm_uint *res) {
663 lbm_uint full_words = n / sizeof(lbm_uint);
664 lbm_uint n_mod = n % sizeof(lbm_uint);
665
666 if (n_mod == 0) { // perfect fit.
667 return lbm_write_const_raw((lbm_uint*)data, full_words, res);
668 } else {
669 lbm_uint last_word = 0;
670 memcpy(&last_word, &data[full_words * sizeof(lbm_uint)], n_mod);
671 if (full_words >= 1) {
672 lbm_flash_status s = lbm_write_const_raw((lbm_uint*)data, full_words, res);
673 if ( s == LBM_FLASH_WRITE_OK) {
674 lbm_uint dummy;
675 s = lbm_write_const_raw(&last_word, 1, &dummy);
676 }
677 return s;
678 } else {
679 return lbm_write_const_raw(&last_word, 1, res);
680 }
681 }
682}
683
684/****************************************************/
685/* Error message creation */
686
687#define ERROR_MESSAGE_BUFFER_SIZE_BYTES256 256
688
689void print_environments(char *buf, unsigned int size) {
690
691 lbm_value curr_l = ctx_running->curr_env;
692 printf_callback("\tCurrent local environment:\n");
693 while (lbm_type_of(curr_l) == LBM_TYPE_CONS0x10000000u) {
694 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_l));
695 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_l)));
696 printf_callback("\t%s = %s\n", buf, buf+(size/2));
697 curr_l = lbm_cdr(curr_l);
698 }
699 printf_callback("\n\n");
700 printf_callback("\tCurrent global environment:\n");
701 lbm_value *glob_env = lbm_get_global_env();
702
703 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
704 lbm_value curr_g = glob_env[i];;
705 while (lbm_type_of(curr_g) == LBM_TYPE_CONS0x10000000u) {
706
707 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_g));
708 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_g)));
709 printf_callback("\t%s = %s\n", buf, buf+(size/2));
710 curr_g = lbm_cdr(curr_g);
711 }
712 }
713}
714
715void print_error_message(lbm_value error, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int col, lbm_int row0, lbm_int row1) {
716 if (!printf_callback) return;
717
718 /* try to allocate a lbm_print_value buffer on the lbm_memory */
719 char *buf = lbm_malloc_reserve(ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
720 if (!buf) {
721 printf_callback("Error: Not enough free memory to create a human readable error message\n");
722 return;
723 }
724
725 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, error);
726 printf_callback( "*** Error: %s\n", buf);
727 if (has_at) {
728 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, at);
729 printf_callback("*** In: %s\n",buf);
730 if (lbm_error_has_suspect) {
731 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, lbm_error_suspect);
732 lbm_error_has_suspect = false0;
733 printf_callback("*** At: %s\n", buf);
734 } else {
735 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
736 printf_callback("*** After: %s\n",buf);
737 }
738 } else {
739 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
740 printf_callback("*** Near: %s\n",buf);
741 }
742
743 printf_callback("\n");
744
745 if (lbm_is_symbol(error) &&
746 error == ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u)) {
747 printf_callback("*** Line: %u\n", row);
748 printf_callback("*** Column: %u\n", col);
749 } else if (row0 != -1 || row1 != -1 ) {
750 printf_callback("*** Between rows: (-1 unknown) \n");
751 printf_callback("*** Start: %d\n", (int32_t)row0);
752 printf_callback("*** End: %d\n", (int32_t)row1);
753 }
754
755 printf_callback("\n");
756
757 if (ctx_running->error_reason) {
758 printf_callback("Reason:\n %s\n\n", ctx_running->error_reason);
759 }
760 if (lbm_verbose) {
761 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->curr_exp);
762 printf_callback(" In context: %d\n", ctx_running->id);
763 printf_callback(" Current intermediate result: %s\n\n", buf);
764
765 print_environments(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256);
766 printf_callback("\n\n");
767
768 printf_callback(" Stack:\n");
769 for (unsigned int i = 0; i < ctx_running->K.sp; i ++) {
770 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES256, ctx_running->K.data[i]);
771 printf_callback(" %s\n", buf);
772 }
773 }
774 lbm_free(buf);
775}
776
777/****************************************************/
778/* Tokenizing and parsing */
779
780bool_Bool create_string_channel(char *str, lbm_value *res) {
781
782 lbm_char_channel_t *chan = NULL((void*)0);
783 lbm_string_channel_state_t *st = NULL((void*)0);
784
785 st = (lbm_string_channel_state_t*)lbm_memory_allocate(sizeof(lbm_string_channel_state_t) / sizeof(lbm_uint) +1);
786 if (st == NULL((void*)0)) {
787 return false0;
788 }
789 chan = (lbm_char_channel_t*)lbm_memory_allocate(sizeof(lbm_char_channel_t) / sizeof(lbm_uint) + 1);
790 if (chan == NULL((void*)0)) {
791 lbm_memory_free((lbm_uint*)st);
792 return false0;
793 }
794
795 lbm_create_string_char_channel(st, chan, str);
796 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
797 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
798 lbm_memory_free((lbm_uint*)st);
799 lbm_memory_free((lbm_uint*)chan);
800 return false0;
801 }
802
803 *res = cell;
804 return true1;
805}
806
807bool_Bool lift_char_channel(lbm_char_channel_t *chan , lbm_value *res) {
808 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL0x90000000u, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u));
809 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) {
810 return false0;
811 }
812 *res = cell;
813 return true1;
814}
815
816
817/****************************************************/
818/* Queue functions */
819
820static void queue_iterator_nm(eval_context_queue_t *q, ctx_fun f, void *arg1, void *arg2) {
821 eval_context_t *curr;
822 curr = q->first;
823
824 while (curr != NULL((void*)0)) {
825 f(curr, arg1, arg2);
826 curr = curr->next;
827 }
828}
829
830void lbm_running_iterator(ctx_fun f, void *arg1, void *arg2){
831 mutex_lock(&qmutex);
832 queue_iterator_nm(&queue, f, arg1, arg2);
833 mutex_unlock(&qmutex);
834}
835
836void lbm_blocked_iterator(ctx_fun f, void *arg1, void *arg2){
837 mutex_lock(&qmutex);
838 queue_iterator_nm(&blocked, f, arg1, arg2);
839 mutex_unlock(&qmutex);
840}
841
842static void enqueue_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
843 if (q->last == NULL((void*)0)) {
844 ctx->prev = NULL((void*)0);
845 ctx->next = NULL((void*)0);
846 q->first = ctx;
847 q->last = ctx;
848 } else {
849 ctx->prev = q->last;
850 ctx->next = NULL((void*)0);
851 q->last->next = ctx;
852 q->last = ctx;
853 }
854}
855
856static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx) {
857 mutex_lock(&qmutex);
858 enqueue_ctx_nm(q,ctx);
859 mutex_unlock(&qmutex);
860}
861
862static eval_context_t *lookup_ctx_nm(eval_context_queue_t *q, lbm_cid cid) {
863 eval_context_t *curr;
864 curr = q->first;
865 while (curr != NULL((void*)0)) {
866 if (curr->id == cid) {
867 return curr;
868 }
869 curr = curr->next;
870 }
871 return NULL((void*)0);
872}
873
874static bool_Bool drop_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
875
876 bool_Bool res = false0;
877 if (q->first == NULL((void*)0) || q->last == NULL((void*)0)) {
878 if (!(q->last == NULL((void*)0) && q->first == NULL((void*)0))) {
879 /* error state that should not happen */
880 return res;
881 }
882 /* Queue is empty */
883 return res;
884 }
885
886 eval_context_t *curr = q->first;
887 while (curr) {
888 if (curr->id == ctx->id) {
889 res = true1;
890 eval_context_t *tmp = curr->next;
891 if (curr->prev == NULL((void*)0)) {
892 if (curr->next == NULL((void*)0)) {
893 q->last = NULL((void*)0);
894 q->first = NULL((void*)0);
895 } else {
896 q->first = tmp;
897 tmp->prev = NULL((void*)0);
898 }
899 } else { /* curr->prev != NULL */
900 if (curr->next == NULL((void*)0)) {
901 q->last = curr->prev;
902 q->last->next = NULL((void*)0);
903 } else {
904 curr->prev->next = tmp;
905 tmp->prev = curr->prev;
906 }
907 }
908 break;
909 }
910 curr = curr->next;
911 }
912 return res;
913}
914
915/* End execution of the running context. */
916static void finish_ctx(void) {
917
918 if (!ctx_running) {
919 return;
920 }
921 /* Drop the continuation stack immediately to free up lbm_memory */
922 lbm_stack_free(&ctx_running->K);
923 ctx_done_callback(ctx_running);
924 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->name)) {
925 lbm_free(ctx_running->name);
926 }
927 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->error_reason)) {
928 lbm_memory_free((lbm_uint*)ctx_running->error_reason);
929 }
930 lbm_memory_free((lbm_uint*)ctx_running->mailbox);
931 lbm_memory_free((lbm_uint*)ctx_running);
932 ctx_running = NULL((void*)0);
933}
934
935static void context_exists(eval_context_t *ctx, void *cid, void *b) {
936 if (ctx->id == *(lbm_cid*)cid) {
937 *(bool_Bool*)b = true1;
938 }
939}
940
941bool_Bool lbm_wait_ctx(lbm_cid cid, lbm_uint timeout_ms) {
942
943 bool_Bool exists;
944 uint32_t i = 0;
945
946 do {
947 exists = false0;
948 lbm_blocked_iterator(context_exists, &cid, &exists);
949 lbm_running_iterator(context_exists, &cid, &exists);
950
951 if (ctx_running &&
952 ctx_running->id == cid) {
953 exists = true1;
954 }
955
956 if (exists) {
957 if (usleep_callback) {
958 usleep_callback(1000);
959 }
960 if (timeout_ms > 0) i ++;
961 }
962 } while (exists && i < timeout_ms);
963
964 if (exists) return false0;
965 return true1;
966}
967
968void lbm_set_error_suspect(lbm_value suspect) {
969 lbm_error_suspect = suspect;
970 lbm_error_has_suspect = true1;
971}
972
973void lbm_set_error_reason(char *error_str) {
974 if (ctx_running != NULL((void*)0)) {
975 ctx_running->error_reason = error_str;
976 }
977}
978
979// Not possible to CONS_WITH_GC in error_ctx_base (potential loop)
980static void error_ctx_base(lbm_value err_val, bool_Bool has_at, lbm_value at, unsigned int row, unsigned int column) {
981
982 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
983 if (lbm_heap_num_free() < 3) {
984 gc();
985 }
986
987 if (lbm_heap_num_free() >= 3) {
988 lbm_value msg = lbm_cons(err_val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
989 msg = lbm_cons(lbm_enc_i(ctx_running->id), msg);
990 msg = lbm_cons(ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u), msg);
991 if (!lbm_is_symbol_merror(msg)) {
992 lbm_find_receiver_and_send(ctx_running->parent, msg);
993 goto error_ctx_base_done;
994 }
995 }
996 }
997 if ((ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10) &&
998 (err_val != ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u))) {
999 lbm_uint v;
1000 while (ctx_running->K.sp > 0) {
1001 lbm_pop(&ctx_running->K, &v);
1002 if (v == EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u)) {
1003 lbm_value *sptr = get_stack_ptr(ctx_running, 2);
1004 lbm_set_car(sptr[0], ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
1005 stack_reserve(ctx_running, 1)[0] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1006 ctx_running->app_cont = true1;
1007 ctx_running->r = err_val;
1008 longjmp(error_jmp_buf, 1);
1009 }
1010 }
1011 err_val = ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u);
1012 }
1013 print_error_message(err_val,
1014 has_at,
1015 at,
1016 row,
1017 column,
1018 ctx_running->row0,
1019 ctx_running->row1);
1020 error_ctx_base_done:
1021 ctx_running->r = err_val;
1022 finish_ctx();
1023 longjmp(error_jmp_buf, 1);
1024}
1025
1026static void error_at_ctx(lbm_value err_val, lbm_value at) {
1027 error_ctx_base(err_val, true1, at, 0, 0);
1028}
1029
1030static void error_ctx(lbm_value err_val) {
1031 error_ctx_base(err_val, false0, 0, 0, 0);
1032}
1033
1034static void read_error_ctx(unsigned int row, unsigned int column) {
1035 error_ctx_base(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u), false0, 0, row, column);
1036}
1037
1038void lbm_critical_error(void) {
1039 longjmp(critical_error_jmp_buf, 1);
1040}
1041
1042// successfully finish a context
1043static void ok_ctx(void) {
1044 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01) {
1045 lbm_value msg;
1046 WITH_GC(msg, lbm_heap_allocate_list_init(3,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1047 ENC_SYM_EXIT_OK,(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1048 lbm_enc_i(ctx_running->id),(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } }
1049 ctx_running->r))(msg) = (lbm_heap_allocate_list_init(3, (((0x3000B) << 4
) | 0x00000000u), lbm_enc_i(ctx_running->id), ctx_running->
r)); if (lbm_is_symbol_merror((msg))) { gc(); (msg) = (lbm_heap_allocate_list_init
(3, (((0x3000B) << 4) | 0x00000000u), lbm_enc_i(ctx_running
->id), ctx_running->r)); if (lbm_is_symbol_merror((msg)
)) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
1050 lbm_find_receiver_and_send(ctx_running->parent, msg);
1051 }
1052 finish_ctx();
1053}
1054
1055static eval_context_t *dequeue_ctx_nm(eval_context_queue_t *q) {
1056 if (q->last == NULL((void*)0)) {
1057 return NULL((void*)0);
1058 }
1059 // q->first should only be NULL if q->last is.
1060 eval_context_t *res = q->first;
1061
1062 if (q->first == q->last) { // One thing in queue
1063 q->first = NULL((void*)0);
1064 q->last = NULL((void*)0);
1065 } else {
1066 q->first = q->first->next;
1067 q->first->prev = NULL((void*)0);
1068 }
1069 res->prev = NULL((void*)0);
1070 res->next = NULL((void*)0);
1071 return res;
1072}
1073
1074static void wake_up_ctxs_nm(void) {
1075 lbm_uint t_now;
1076
1077 if (timestamp_us_callback) {
1078 t_now = timestamp_us_callback();
1079 } else {
1080 t_now = 0;
1081 }
1082
1083 eval_context_queue_t *q = &blocked;
1084 eval_context_t *curr = q->first;
1085
1086 while (curr != NULL((void*)0)) {
1087 lbm_uint t_diff;
1088 eval_context_t *next = curr->next;
1089 if (curr->state != LBM_THREAD_STATE_BLOCKED(uint32_t)1) {
1090 if ( curr->timestamp > t_now) {
1091 /* There was an overflow on the counter */
1092#ifndef LBM64
1093 t_diff = (0xFFFFFFFF - curr->timestamp) + t_now;
1094#else
1095 t_diff = (0xFFFFFFFFFFFFFFFF - curr->timestamp) + t_now;
1096#endif
1097 } else {
1098 t_diff = t_now - curr->timestamp;
1099 }
1100
1101 if (t_diff >= curr->sleep_us) {
1102 eval_context_t *wake_ctx = curr;
1103 if (curr == q->last) {
1104 if (curr->prev) {
1105 q->last = curr->prev;
1106 q->last->next = NULL((void*)0);
1107 } else {
1108 q->first = NULL((void*)0);
1109 q->last = NULL((void*)0);
1110 }
1111 } else if (curr->prev == NULL((void*)0)) {
1112 q->first = curr->next;
1113 q->first->prev = NULL((void*)0);
1114 } else {
1115 curr->prev->next = curr->next;
1116 if (curr->next) {
1117 curr->next->prev = curr->prev;
1118 }
1119 }
1120 wake_ctx->next = NULL((void*)0);
1121 wake_ctx->prev = NULL((void*)0);
1122 if (curr->state == LBM_THREAD_STATE_TIMEOUT(uint32_t)2) {
1123 mailbox_add_mail(wake_ctx, ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u));
1124 wake_ctx->r = ENC_SYM_TIMEOUT(((0xA) << 4) | 0x00000000u);
1125 }
1126 wake_ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1127 enqueue_ctx_nm(&queue, wake_ctx);
1128 }
1129 }
1130 curr = next;
1131 }
1132}
1133
1134static void yield_ctx(lbm_uint sleep_us) {
1135 if (timestamp_us_callback) {
1136 ctx_running->timestamp = timestamp_us_callback();
1137 ctx_running->sleep_us = sleep_us;
1138 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1139 } else {
1140 ctx_running->timestamp = 0;
1141 ctx_running->sleep_us = 0;
1142 ctx_running->state = LBM_THREAD_STATE_SLEEPING(uint32_t)3;
1143 }
1144 ctx_running->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1145 ctx_running->app_cont = true1;
1146 enqueue_ctx(&blocked,ctx_running);
1147 ctx_running = NULL((void*)0);
1148}
1149
1150static lbm_cid lbm_create_ctx_parent(lbm_value program, lbm_value env, lbm_uint stack_size, lbm_cid parent, uint32_t context_flags, char *name) {
1151
1152 if (!lbm_is_cons(program)) return -1;
1153
1154 eval_context_t *ctx = NULL((void*)0);
1155
1156 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1157 if (ctx == NULL((void*)0)) {
1158 lbm_uint roots[2] = {program, env};
1159 lbm_gc_mark_roots(roots, 2);
1160 gc();
1161 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1162 }
1163 if (ctx == NULL((void*)0)) return -1;
1164
1165 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1166 lbm_uint roots[2] = {program, env};
1167 lbm_gc_mark_roots(roots, 2);
1168 gc();
1169 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1170 lbm_memory_free((lbm_uint*)ctx);
1171 return -1;
1172 }
1173 }
1174
1175 lbm_value *mailbox = NULL((void*)0);
1176 mailbox = (lbm_value*)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1177 if (mailbox == NULL((void*)0)) {
1178 lbm_value roots[2] = {program, env};
1179 lbm_gc_mark_roots(roots,2);
1180 gc();
1181 mailbox = (lbm_value *)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE10);
1182 }
1183 if (mailbox == NULL((void*)0)) {
1184 lbm_stack_free(&ctx->K);
1185 lbm_memory_free((lbm_uint*)ctx);
1186 return -1;
1187 }
1188
1189 // TODO: Limit names to 19 chars + 1 char for 0? (or something similar).
1190 if (name) {
1191 lbm_uint name_len = strlen(name) + 1;
1192 ctx->name = lbm_malloc(strlen(name) + 1);
1193 if (ctx->name == NULL((void*)0)) {
1194 lbm_value roots[2] = {program, env};
1195 lbm_gc_mark_roots(roots, 2);
1196 gc();
1197 ctx->name = lbm_malloc(strlen(name) + 1);
1198 }
1199 if (ctx->name == NULL((void*)0)) {
1200 lbm_stack_free(&ctx->K);
1201 lbm_memory_free((lbm_uint*)mailbox);
1202 lbm_memory_free((lbm_uint*)ctx);
1203 return -1;
1204 }
1205 memcpy(ctx->name, name, name_len+1);
1206 } else {
1207 ctx->name = NULL((void*)0);
1208 }
1209
1210 lbm_int cid = lbm_memory_address_to_ix((lbm_uint*)ctx);
1211
1212 ctx->program = lbm_cdr(program);
1213 ctx->curr_exp = lbm_car(program);
1214 ctx->curr_env = env;
1215 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1216 ctx->error_reason = NULL((void*)0);
1217 ctx->mailbox = mailbox;
1218 ctx->mailbox_size = EVAL_CPS_DEFAULT_MAILBOX_SIZE10;
1219 ctx->flags = context_flags;
1220 ctx->num_mail = 0;
1221 ctx->app_cont = false0;
1222 ctx->timestamp = 0;
1223 ctx->sleep_us = 0;
1224 ctx->state = LBM_THREAD_STATE_READY(uint32_t)0;
1225 ctx->prev = NULL((void*)0);
1226 ctx->next = NULL((void*)0);
1227
1228 ctx->row0 = -1;
1229 ctx->row1 = -1;
1230
1231 ctx->id = cid;
1232 ctx->parent = parent;
1233
1234 if (!lbm_push(&ctx->K, DONE(((0) << 2) | 0xF8000001u))) {
1235 lbm_memory_free((lbm_uint*)ctx->mailbox);
1236 lbm_stack_free(&ctx->K);
1237 lbm_memory_free((lbm_uint*)ctx);
1238 return -1;
1239 }
1240
1241 enqueue_ctx(&queue,ctx);
1242
1243 return ctx->id;
1244}
1245
1246lbm_cid lbm_create_ctx(lbm_value program, lbm_value env, lbm_uint stack_size, char *name) {
1247 // Creates a parentless context.
1248 return lbm_create_ctx_parent(program,
1249 env,
1250 stack_size,
1251 -1,
1252 EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00,
1253 name);
1254}
1255
1256bool_Bool lbm_mailbox_change_size(eval_context_t *ctx, lbm_uint new_size) {
1257
1258 lbm_value *mailbox = NULL((void*)0);
1259 mailbox = (lbm_value*)lbm_memory_allocate(new_size);
1260 if (mailbox == NULL((void*)0)) {
1261 gc();
1262 mailbox = (lbm_value *)lbm_memory_allocate(new_size);
1263 }
1264 if (mailbox == NULL((void*)0)) {
1265 return false0;
1266 }
1267
1268 for (lbm_uint i = 0; i < ctx->num_mail; i ++ ) {
1269 mailbox[i] = ctx->mailbox[i];
1270 }
1271 lbm_memory_free(ctx->mailbox);
1272 ctx->mailbox = mailbox;
1273 ctx->mailbox_size = (uint32_t)new_size;
1274 return true1;
1275}
1276
1277static void mailbox_remove_mail(eval_context_t *ctx, lbm_uint ix) {
1278
1279 for (lbm_uint i = ix; i < ctx->num_mail-1; i ++) {
1280 ctx->mailbox[i] = ctx->mailbox[i+1];
1281 }
1282 ctx->num_mail --;
1283}
1284
1285static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail) {
1286
1287 if (ctx->num_mail >= ctx->mailbox_size) {
1288 mailbox_remove_mail(ctx, 0);
1289 }
1290
1291 ctx->mailbox[ctx->num_mail] = mail;
1292 ctx->num_mail ++;
1293 return true1;
1294}
1295
1296/* Advance execution to the next expression in the program */
1297static void advance_ctx(eval_context_t *ctx) {
1298 if (lbm_is_cons(ctx->program)) {
1299 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);;
1300 get_car_and_cdr(ctx->program, &ctx->curr_exp, &ctx->program);
1301 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1302 } else {
1303 if (ctx_running == ctx) { // This should always be the case because of odd historical reasons.
1304 ok_ctx();
1305 }
1306 }
1307}
1308
1309bool_Bool lbm_unblock_ctx(lbm_cid cid, lbm_flat_value_t *fv) {
1310 return event_internal(LBM_EVENT_UNBLOCK_CTX, (lbm_uint)cid, (lbm_uint)fv->buf, fv->buf_size);
1311}
1312
1313bool_Bool lbm_unblock_ctx_r(lbm_cid cid) {
1314 mutex_lock(&blocking_extension_mutex);
1315 bool_Bool r = false0;
1316 eval_context_t *found = NULL((void*)0);
1317 mutex_lock(&qmutex);
1318 found = lookup_ctx_nm(&blocked, cid);
1319 if (found) {
1320 drop_ctx_nm(&blocked,found);
1321 enqueue_ctx_nm(&queue,found);
1322 r = true1;
1323 }
1324 mutex_unlock(&qmutex);
1325 mutex_unlock(&blocking_extension_mutex);
1326 return r;
1327}
1328
1329// unblock unboxed is also safe for rmbr:ed things.
1330bool_Bool lbm_unblock_ctx_unboxed(lbm_cid cid, lbm_value unboxed) {
1331 mutex_lock(&blocking_extension_mutex);
1332 bool_Bool r = false0;
1333 eval_context_t *found = NULL((void*)0);
1334 mutex_lock(&qmutex);
1335 found = lookup_ctx_nm(&blocked, cid);
1336 if (found) {
1337 drop_ctx_nm(&blocked,found);
1338 found->r = unboxed;
1339 if (lbm_is_error(unboxed)) {
1340 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
1341 found->app_cont = true1;
1342 }
1343 enqueue_ctx_nm(&queue,found);
1344 r = true1;
1345 }
1346 mutex_unlock(&qmutex);
1347 mutex_unlock(&blocking_extension_mutex);
1348 return r;
1349}
1350
1351static bool_Bool lbm_block_ctx_base(bool_Bool timeout, float t_s) {
1352 mutex_lock(&blocking_extension_mutex);
1353 blocking_extension = true1;
1354 if (timeout) {
1355 blocking_extension_timeout_us = S_TO_US(t_s)(lbm_uint)((t_s) * 1000000);
1356 blocking_extension_timeout = true1;
1357 } else {
1358 blocking_extension_timeout = false0;
1359 }
1360 return true1;
1361}
1362
1363void lbm_block_ctx_from_extension_timeout(float s) {
1364 lbm_block_ctx_base(true1, s);
1365}
1366
1367void lbm_block_ctx_from_extension(void) {
1368 lbm_block_ctx_base(false0, 0);
1369}
1370
1371// todo: May need to pop rmbrs from stack, if present.
1372// Suspect that the letting the discard cont run is really not a problem.
1373// Either way will be quite confusing what happens to allocated things when undoing block.
1374void lbm_undo_block_ctx_from_extension(void) {
1375 blocking_extension = false0;
1376 blocking_extension_timeout_us = 0;
1377 blocking_extension_timeout = false0;
1378 mutex_unlock(&blocking_extension_mutex);
1379}
1380
1381lbm_value lbm_find_receiver_and_send(lbm_cid cid, lbm_value msg) {
1382 mutex_lock(&qmutex);
1383 eval_context_t *found = NULL((void*)0);
1384 bool_Bool found_blocked = false0;
1385
1386 found = lookup_ctx_nm(&blocked, cid);
1387 if (found) found_blocked = true1;
1388
1389 if (found == NULL((void*)0)) {
1390 found = lookup_ctx_nm(&queue, cid);
1391 }
1392
1393 if (found) {
1394 if (!mailbox_add_mail(found, msg)) {
1395 mutex_unlock(&qmutex);
1396 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1397 }
1398
1399 if (found_blocked){
1400 drop_ctx_nm(&blocked,found);
1401 enqueue_ctx_nm(&queue,found);
1402 }
1403 mutex_unlock(&qmutex);
1404 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1405 }
1406
1407 /* check the current context */
1408 if (ctx_running && ctx_running->id == cid) {
1409 if (!mailbox_add_mail(ctx_running, msg)) {
1410 mutex_unlock(&qmutex);
1411 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1412 }
1413 mutex_unlock(&qmutex);
1414 return ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1415 }
1416 mutex_unlock(&qmutex);
1417 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1418}
1419
1420/* Pattern matching is currently implemented as a recursive
1421 function and make use of stack relative to the size of
1422 expressions that are being matched. */
1423static bool_Bool match(lbm_value p, lbm_value e, lbm_value *env, bool_Bool *gc) {
1424
1425 lbm_value binding;
1426
1427 if (lbm_is_match_binder(p)) {
1428 lbm_value var = get_cadr(p);
1429 lbm_value bindertype = get_car(p);
1430
1431 if (!lbm_is_symbol(var)) return false0;
1432
1433 switch (bindertype) {
1434 case ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u):
1435 if ( var == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) {
1436 return true1;
1437 }
1438 break;
1439 default: /* this should be an error case */
1440 return false0;
1441 }
1442 binding = lbm_cons(var, e);
1443 if ( lbm_type_of(binding) == LBM_TYPE_SYMBOL0x00000000u ) {
1444 *gc = true1;
1445 return false0;
1446 }
1447 *env = lbm_cons(binding, *env);
1448 if ( lbm_type_of(*env) == LBM_TYPE_SYMBOL0x00000000u ) {
1449 *gc = true1;
1450 return false0;
1451 }
1452 return true1;
1453 }
1454
1455 if (lbm_is_symbol(p)) {
1456 if (p == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return true1;
1457 return (p == e);
1458 }
1459 if (lbm_is_cons(p) &&
1460 lbm_is_cons(e) ) {
1461
1462 lbm_value headp, tailp;
1463 lbm_value heade, taile;
1464 get_car_and_cdr(p, &headp, &tailp);
1465 get_car_and_cdr(e, &heade, &taile); // Static analysis warns, but execution does not
1466 // past this point unless head and tail get initialized.
1467 if (!match(headp, heade, env, gc)) {
1468 return false0;
1469 }
1470 return match (tailp, taile, env, gc);
1471 }
1472 return struct_eq(p, e);
1473}
1474
1475// Find match is not very picky about syntax.
1476// A completely malformed recv form is most likely to
1477// just return no_match.
1478static int find_match(lbm_value plist, lbm_value *earr, lbm_uint num, lbm_value *e, lbm_value *env) {
1479
1480 // A pattern list is a list of pattern, expression lists.
1481 // ( (p1 e1) (p2 e2) ... (pn en))
1482 lbm_value curr_p = plist;
1483 int n = 0;
1484 bool_Bool gc = false0;
1485 for (int i = 0; i < (int)num; i ++ ) {
1486 lbm_value curr_e = earr[i];
1487 while (!lbm_is_symbol_nil(curr_p)) {
1488 lbm_value me = get_car(curr_p);
1489 if (match(get_car(me), curr_e, env, &gc)) {
1490 if (gc) return FM_NEED_GC-1;
1491 *e = get_cadr(me);
1492
1493 if (!lbm_is_symbol_nil(get_cadr(get_cdr(me)))) {
1494 return FM_PATTERN_ERROR-3;
1495 }
1496 return n;
1497 }
1498 curr_p = get_cdr(curr_p);
1499 }
1500 curr_p = plist; /* search all patterns against next exp */
1501 n ++;
1502 }
1503
1504 return FM_NO_MATCH-2;
1505}
1506
1507/****************************************************/
1508/* Garbage collection */
1509
1510static void mark_context(eval_context_t *ctx, void *arg1, void *arg2) {
1511 (void) arg1;
1512 (void) arg2;
1513 lbm_value roots[3] = {ctx->curr_exp, ctx->program, ctx->r };
1514 lbm_gc_mark_env(ctx->curr_env);
1515 lbm_gc_mark_roots(roots, 3);
1516 lbm_gc_mark_roots(ctx->mailbox, ctx->num_mail);
1517 lbm_gc_mark_aux(ctx->K.data, ctx->K.sp);
1518}
1519
1520static int gc(void) {
1521 if (ctx_running) {
1522 ctx_running->state = ctx_running->state | LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1523 }
1524
1525 gc_requested = false0;
1526 lbm_gc_state_inc();
1527
1528 // The freelist should generally be NIL when GC runs.
1529 lbm_nil_freelist();
1530 lbm_value *env = lbm_get_global_env();
1531 for (int i = 0; i < GLOBAL_ENV_ROOTS32; i ++) {
1532 lbm_gc_mark_env(env[i]);
1533 }
1534
1535 mutex_lock(&qmutex); // Lock the queues.
1536 // Any concurrent messing with the queues
1537 // while doing GC cannot possibly be good.
1538 queue_iterator_nm(&queue, mark_context, NULL((void*)0), NULL((void*)0));
1539 queue_iterator_nm(&blocked, mark_context, NULL((void*)0), NULL((void*)0));
1540
1541 if (ctx_running) {
1542 mark_context(ctx_running, NULL((void*)0), NULL((void*)0));
1543 }
1544 mutex_unlock(&qmutex);
1545
1546#ifdef VISUALIZE_HEAP
1547 heap_vis_gen_image();
1548#endif
1549
1550 int r = lbm_gc_sweep_phase();
1551 lbm_heap_new_freelist_length();
1552
1553 if (ctx_running) {
1554 ctx_running->state = ctx_running->state & ~LBM_THREAD_STATE_GC_BIT(uint32_t)(1 << 31);
1555 }
1556 return r;
1557}
1558
1559int lbm_perform_gc(void) {
1560 return gc();
1561}
1562
1563/****************************************************/
1564/* Evaluation functions */
1565
1566
1567static void eval_symbol(eval_context_t *ctx) {
1568 lbm_uint s = lbm_dec_sym(ctx->curr_exp);
1569 if (s >= RUNTIME_SYMBOLS_START0x40000) {
1570 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1571 if (lbm_env_lookup_b(&res, ctx->curr_exp, ctx->curr_env) ||
1572 lbm_global_env_lookup(&res, ctx->curr_exp)) {
1573 ctx->r = res;
1574 ctx->app_cont = true1;
1575 return;
1576 }
1577 // Dynamic load attempt
1578 // Only symbols of kind RUNTIME can be dynamically loaded.
1579 const char *sym_str = lbm_get_name_by_symbol(s);
1580 const char *code_str = NULL((void*)0);
1581 if (!dynamic_load_callback(sym_str, &code_str)) {
1582 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), ctx->curr_exp);
1583 }
1584 lbm_value *sptr = stack_reserve(ctx, 3);
1585 sptr[0] = ctx->curr_exp;
1586 sptr[1] = ctx->curr_env;
1587 sptr[2] = RESUME(((12) << 2) | 0xF8000001u);
1588
1589 lbm_value chan;
1590 if (!create_string_channel((char *)code_str, &chan)) {
1591 gc();
1592 if (!create_string_channel((char *)code_str, &chan)) {
1593 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1594 }
1595 }
1596
1597 lbm_value loader;
1598 WITH_GC_RMBR_1(loader, lbm_heap_allocate_list_init(2,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1599 ENC_SYM_READ,(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} }
1600 chan), chan)(loader) = (lbm_heap_allocate_list_init(2, (((0x30001) <<
4) | 0x00000000u), chan)); if (lbm_is_symbol_merror((loader)
)) { lbm_gc_mark_phase(chan); gc(); (loader) = (lbm_heap_allocate_list_init
(2, (((0x30001) << 4) | 0x00000000u), chan)); if (lbm_is_symbol_merror
((loader))) { error_ctx((((0x23) << 4) | 0x00000000u));
} };
1601 lbm_value evaluator;
1602 WITH_GC_RMBR_1(evaluator, lbm_heap_allocate_list_init(2,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1603 ENC_SYM_EVAL,(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } }
1604 loader), loader)(evaluator) = (lbm_heap_allocate_list_init(2, (((0x30008) <<
4) | 0x00000000u), loader)); if (lbm_is_symbol_merror((evaluator
))) { lbm_gc_mark_phase(loader); gc(); (evaluator) = (lbm_heap_allocate_list_init
(2, (((0x30008) << 4) | 0x00000000u), loader)); if (lbm_is_symbol_merror
((evaluator))) { error_ctx((((0x23) << 4) | 0x00000000u
)); } };
1605 ctx->curr_exp = evaluator;
1606 ctx->curr_env = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // dynamics should be evaluable in empty local env
1607 } else {
1608 //special symbols and extensions can be handled the same way.
1609 ctx->r = ctx->curr_exp;
1610 ctx->app_cont = true1;
1611 }
1612}
1613
1614static void eval_quote(eval_context_t *ctx) {
1615 ctx->r = get_cadr(ctx->curr_exp);
1616 ctx->app_cont = true1;
1617}
1618
1619static void eval_selfevaluating(eval_context_t *ctx) {
1620 ctx->r = ctx->curr_exp;
1621 ctx->app_cont = true1;
1622}
1623
1624static void eval_progn(eval_context_t *ctx) {
1625 lbm_value exps = get_cdr(ctx->curr_exp);
1626
1627 if (lbm_is_cons(exps)) {
1628 lbm_uint *sptr = stack_reserve(ctx, 4);
1629 sptr[0] = ctx->curr_env; // env to restore between expressions in progn
1630 sptr[1] = lbm_enc_u(0); // Has env been copied (needed for progn local bindings)
1631 sptr[3] = PROGN_REST(((4) << 2) | 0xF8000001u);
1632 get_car_and_cdr(exps, &ctx->curr_exp, &sptr[2]);
1633 if (lbm_is_symbol(sptr[2])) /* The only symbol it can be is nil */
1634 lbm_stack_drop(&ctx->K, 4);
1635 } else if (lbm_is_symbol_nil(exps)) {
1636 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1637 ctx->app_cont = true1;
1638 } else {
1639 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1640 }
1641}
1642
1643static void eval_atomic(eval_context_t *ctx) {
1644 if (is_atomic) {
1645 lbm_set_error_reason("Atomic blocks cannot be nested!");
1646 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1647 }
1648 stack_reserve(ctx, 1)[0] = EXIT_ATOMIC(((14) << 2) | 0xF8000001u);
1649 is_atomic ++;
1650 eval_progn(ctx);
1651}
1652
1653/* (call-cc (lambda (k) .... )) */
1654static void eval_callcc(eval_context_t *ctx) {
1655 lbm_value cont_array;
1656 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1657 gc();
1658 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1659 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1660 return; // dead return but static analysis doesn't know :)
1661 }
1662 }
1663 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(cont_array);
1664 memcpy(arr->data, ctx->K.data, ctx->K.sp * sizeof(lbm_uint));
1665
1666 lbm_value acont = cons_with_gc(ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u), cont_array, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1667 lbm_value arg_list = cons_with_gc(acont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1668 // Go directly into application evaluation without passing go
1669 lbm_uint *sptr = stack_reserve(ctx, 3);
1670 sptr[0] = ctx->curr_env;
1671 sptr[1] = arg_list;
1672 sptr[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
1673 ctx->curr_exp = get_cadr(ctx->curr_exp);
1674}
1675
1676// (define sym exp)
1677#define KEY1 1
1678#define VAL2 2
1679static void eval_define(eval_context_t *ctx) {
1680 lbm_value parts[3];
1681 lbm_value rest = extract_n(ctx->curr_exp, parts, 3);
1682 lbm_uint *sptr = stack_reserve(ctx, 2);
1683 if (lbm_is_symbol(parts[KEY1]) && lbm_is_symbol_nil(rest)) {
1684 lbm_uint sym_val = lbm_dec_sym(parts[KEY1]);
1685 sptr[0] = parts[KEY1];
1686 if (sym_val >= RUNTIME_SYMBOLS_START0x40000) {
1687 sptr[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
1688 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02) {
1689 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
1690 }
1691 ctx->curr_exp = parts[VAL2];
1692 return;
1693 }
1694 }
1695 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
1696}
1697
1698
1699/* Eval lambda is cheating, a lot! It does this
1700 for performance reasons. The cheats are that
1701 1. When closure is created, a reference to the local env
1702 in which the lambda was evaluated is added to the closure.
1703 Ideally it should have created a list of free variables in the function
1704 and then looked up the values of these creating a new environment.
1705 2. The global env is considered global constant. As there is no copying
1706 of environment bindings into the closure, undefine may break closures.
1707
1708 Correct closure creation is a lot more expensive than what happens here.
1709 However, one can try to write programs in such a way that closures are created
1710 seldomly. If one does that the space-usage benefits of "correct" closures
1711 may outweigh the performance gain of "incorrect" ones.
1712
1713 some obscure programs such as test_setq_local_closure.lisp does not
1714 work properly due to this cheating.
1715 */
1716// (lambda param-list body-exp) -> (closure param-list body-exp env)
1717static void eval_lambda(eval_context_t *ctx) {
1718 lbm_value vals[3];
1719 extract_n(ctx->curr_exp, vals, 3);
1720 ctx->r = allocate_closure(vals[1],vals[2], ctx->curr_env);
1721#ifdef CLEAN_UP_CLOSURES
1722 lbm_uint sym_id = 0;
1723 if (clean_cl_env_symbol) {
1724 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1725 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1726 ctx->curr_exp = app;
1727 } else if (lbm_get_symbol_by_name("clean-cl-env", &sym_id)) {
1728 clean_cl_env_symbol = lbm_enc_sym(sym_id);
1729 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1730 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1731 ctx->curr_exp = app;
1732 } else {
1733 ctx->app_cont = true1;
1734 }
1735#else
1736 ctx->app_cont = true1;
1737#endif
1738}
1739
1740// (if cond-expr then-expr else-expr)
1741static void eval_if(eval_context_t *ctx) {
1742 lbm_value cdr = get_cdr(ctx->curr_exp);
1743 lbm_value *sptr = stack_reserve(ctx, 3);
1744 sptr[0] = get_cdr(cdr);
1745 sptr[1] = ctx->curr_env;
1746 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1747 ctx->curr_exp = get_car(cdr);
1748}
1749
1750// (cond (cond-expr-1 expr-1)
1751// ...
1752// (cond-expr-N expr-N))
1753static void eval_cond(eval_context_t *ctx) {
1754 lbm_value cond1[2];
1755 lbm_value rest_conds = extract_n(ctx->curr_exp, cond1, 2);
1756
1757 // end recursion at (cond )
1758 if (lbm_is_symbol_nil(cond1[1])) {
1759 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
1760 ctx->app_cont = true1;
1761 } else {
1762 // Cond is one of the few places where a bit of syntax checking takes place at runtime..
1763 // Maybe dont bother?
1764 lbm_uint len = lbm_list_length(cond1[1]);
1765 if (len != 2) {
1766 lbm_set_error_reason("Incorrect syntax in cond");
1767 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1768 }
1769 lbm_value cond_expr[2];
1770 extract_n(cond1[1], cond_expr, 2);
1771 lbm_value rest;
1772 WITH_GC(rest, lbm_heap_allocate_list_init(2,(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1773 cond_expr[1], // Then branch(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } }
1774 cons_with_gc(ENC_SYM_COND, rest_conds , ENC_SYM_NIL)))(rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { gc
(); (rest) = (lbm_heap_allocate_list_init(2, cond_expr[1], cons_with_gc
((((0x110) << 4) | 0x00000000u), rest_conds , (((0x0) <<
4) | 0x00000000u)))); if (lbm_is_symbol_merror((rest))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
1775 lbm_value *sptr = stack_reserve(ctx, 3);
1776 sptr[0] = rest;
1777 sptr[1] = ctx->curr_env;
1778 sptr[2] = IF(((3) << 2) | 0xF8000001u);
1779 ctx->curr_exp = cond_expr[0]; //condition;
1780 }
1781}
1782
1783static void eval_app_cont(eval_context_t *ctx) {
1784 lbm_stack_drop(&ctx->K, 1);
1785 ctx->app_cont = true1;
1786}
1787
1788// Create a named location in an environment to later receive a value.
1789static binding_location_status create_binding_location_internal(lbm_value key, lbm_value *env) {
1790
1791 if (lbm_is_symbol(key) &&
1792 (key == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u) ||
1793 key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)))
1794 return BL_OK;
1795
1796 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) { // default case
1797 lbm_value binding;
1798 lbm_value new_env_tmp;
1799 binding = lbm_cons(key, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
1800 new_env_tmp = lbm_cons(binding, *env);
1801 if (lbm_is_symbol(binding) || lbm_is_symbol(new_env_tmp)) {
1802 return BL_NO_MEMORY;
1803 }
1804 *env = new_env_tmp;
1805 } else if (lbm_is_cons(key)) { // deconstruct case
1806 int r = create_binding_location_internal(get_car(key), env);
1807 if (r == BL_OK) {
1808 r = create_binding_location_internal(get_cdr(key), env);
1809 }
1810 return r;
1811 }
1812 return BL_OK;
1813}
1814
1815static void create_binding_location(lbm_value key, lbm_value *env) {
1816
1817 lbm_value env_tmp = *env;
1818 binding_location_status r = create_binding_location_internal(key, &env_tmp);
1819 if (r != BL_OK) {
1820 if (r == BL_NO_MEMORY) {
1821 env_tmp = *env;
1822 lbm_gc_mark_phase(env_tmp);
1823 gc();
1824 r = create_binding_location_internal(key, &env_tmp);
1825 }
1826 switch(r) {
1827 case BL_OK:
1828 break;
1829 case BL_NO_MEMORY:
1830 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
1831 break;
1832 case BL_INCORRECT_KEY:
1833 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
1834 break;
1835 }
1836 }
1837 *env = env_tmp;
1838}
1839
1840static void let_bind_values_eval(lbm_value binds, lbm_value exp, lbm_value env, eval_context_t *ctx) {
1841
1842 if (!lbm_is_cons(binds)) {
1843 // binds better be nil or there is a programmer error.
1844 ctx->curr_exp = exp;
1845 return;
1846 }
1847
1848 // Preallocate binding locations.
1849 lbm_value curr = binds;
1850 while (lbm_is_cons(curr)) {
1851 lbm_value new_env_tmp = env;
1852 lbm_value car_curr, cdr_curr;
1853 get_car_and_cdr(curr, &car_curr, &cdr_curr);
1854 lbm_value key = get_car(car_curr);
1855 create_binding_location(key, &new_env_tmp);
1856 env = new_env_tmp;
1857 curr = cdr_curr;
1858 }
1859
1860 lbm_value car_binds;
1861 lbm_value cdr_binds;
1862 get_car_and_cdr(binds, &car_binds, &cdr_binds);
1863 lbm_value key_val[2];
1864 extract_n(car_binds, key_val, 2);
1865
1866 lbm_uint *sptr = stack_reserve(ctx, 5);
1867 sptr[0] = exp;
1868 sptr[1] = cdr_binds;
1869 sptr[2] = env;
1870 sptr[3] = key_val[0];
1871 sptr[4] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
1872 ctx->curr_exp = key_val[1];
1873 ctx->curr_env = env;
1874}
1875
1876// (var x (...)) - local binding inside of an progn
1877// var has to take, place root-level nesting within progn.
1878// (progn ... (var a 10) ...) OK!
1879// (progn ... (something (var a 10)) ... ) NOT OK!
1880/* progn stack
1881 sp-4 : env
1882 sp-3 : 0
1883 sp-2 : rest
1884 sp-1 : PROGN_REST
1885*/
1886static void eval_var(eval_context_t *ctx) {
1887
1888 if (ctx->K.sp >= 4) { // Possibly in progn
1889 lbm_value sv = ctx->K.data[ctx->K.sp - 1];
1890 if (IS_CONTINUATION(sv)(((sv) & 0xF8000001u) == 0xF8000001u) && (sv == PROGN_REST(((4) << 2) | 0xF8000001u))) {
1891 lbm_uint sp = ctx->K.sp;
1892 uint32_t is_copied = lbm_dec_as_u32(ctx->K.data[sp-3]);
1893 if (is_copied == 0) {
1894 lbm_value env;
1895 WITH_GC(env, lbm_env_copy_spine(ctx->K.data[sp-4]))(env) = (lbm_env_copy_spine(ctx->K.data[sp-4])); if (lbm_is_symbol_merror
((env))) { gc(); (env) = (lbm_env_copy_spine(ctx->K.data[sp
-4])); if (lbm_is_symbol_merror((env))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1896 ctx->K.data[sp-3] = lbm_enc_u(1);
1897 ctx->K.data[sp-4] = env;
1898 }
1899 lbm_value new_env = ctx->K.data[sp-4];
1900 lbm_value args = get_cdr(ctx->curr_exp);
1901 lbm_value key = get_car(args);
1902 create_binding_location(key, &new_env);
1903 ctx->K.data[sp-4] = new_env;
1904
1905 lbm_value v_exp = get_cadr(args);
1906 lbm_value *sptr = stack_reserve(ctx, 3);
1907 sptr[0] = new_env;
1908 sptr[1] = key;
1909 sptr[2] = PROGN_VAR(((29) << 2) | 0xF8000001u);
1910 // Activating the new environment before the evaluation of the value to be bound,
1911 // means that other variables with same name will be shadowed already in the value
1912 // body.
1913 // The way closures work, the var-variable needs to be in scope during val evaluation
1914 // for a recursive closure to be possible.
1915 ctx->curr_env = new_env;
1916 ctx->curr_exp = v_exp;
1917 return;
1918 }
1919 }
1920 lbm_set_error_reason((char*)lbm_error_str_var_outside_progn);
1921 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
1922}
1923
1924// (setq x (...)) - same as (set 'x (...)) or (setvar 'x (...))
1925static void eval_setq(eval_context_t *ctx) {
1926 lbm_value parts[3];
1927 extract_n(ctx->curr_exp, parts, 3);
1928 lbm_value *sptr = stack_reserve(ctx, 3);
1929 sptr[0] = ctx->curr_env;
1930 sptr[1] = parts[1];
1931 sptr[2] = SETQ(((30) << 2) | 0xF8000001u);
1932 ctx->curr_exp = parts[2];
1933}
1934
1935static void eval_move_to_flash(eval_context_t *ctx) {
1936 lbm_value args = get_cdr(ctx->curr_exp);
1937 lbm_value *sptr = stack_reserve(ctx,2);
1938 sptr[0] = args;
1939 sptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
1940 ctx->app_cont = true1;
1941}
1942
1943// (loop list-of-local-bindings
1944// condition-exp
1945// body-exp)
1946static void eval_loop(eval_context_t *ctx) {
1947 lbm_value env = ctx->curr_env;
1948 lbm_value parts[3];
1949 extract_n(get_cdr(ctx->curr_exp), parts, 3);
1950 lbm_value *sptr = stack_reserve(ctx, 3);
1951 sptr[0] = parts[LOOP_BODY2];
1952 sptr[1] = parts[LOOP_COND1];
1953 sptr[2] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
1954 let_bind_values_eval(parts[LOOP_BINDS0], parts[LOOP_COND1], env, ctx);
1955}
1956
1957/* (trap expression)
1958 *
1959 * suggested use:
1960 * (match (trap expression)
1961 * ((exit-error (? err)) (error-handler err))
1962 * ((exit-ok (? v)) (value-handler v)))
1963 */
1964static void eval_trap(eval_context_t *ctx) {
1965
1966 lbm_value expr = get_cadr(ctx->curr_exp);
1967 lbm_value retval;
1968 WITH_GC(retval, lbm_heap_allocate_list(2))(retval) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((retval))) { gc(); (retval) = (lbm_heap_allocate_list(2)); if
(lbm_is_symbol_merror((retval))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
1969 lbm_set_car(retval, ENC_SYM_EXIT_OK(((0x3000B) << 4) | 0x00000000u)); // Assume things will go well.
1970 lbm_uint *sptr = stack_reserve(ctx,3);
1971 sptr[0] = retval;
1972 sptr[1] = ctx->flags;
1973 sptr[2] = EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u);
1974 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN(uint32_t)0x10;
1975 ctx->curr_exp = expr;
1976}
1977
1978// (let list-of-binding s
1979// body-exp)
1980static void eval_let(eval_context_t *ctx) {
1981 lbm_value env = ctx->curr_env;
1982 lbm_value parts[3];
1983 extract_n(ctx->curr_exp, parts, 3);
1984 let_bind_values_eval(parts[1], parts[2], env, ctx);
1985}
1986
1987// (and exp0 ... expN)
1988static void eval_and(eval_context_t *ctx) {
1989 lbm_value rest = get_cdr(ctx->curr_exp);
1990 if (lbm_is_symbol_nil(rest)) {
1991 ctx->app_cont = true1;
1992 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
1993 } else {
1994 lbm_value *sptr = stack_reserve(ctx, 3);
1995 sptr[0] = ctx->curr_env;
1996 sptr[1] = get_cdr(rest);
1997 sptr[2] = AND(((6) << 2) | 0xF8000001u);
1998 ctx->curr_exp = get_car(rest);
1999 }
2000}
2001
2002// (or exp0 ... expN)
2003static void eval_or(eval_context_t *ctx) {
2004 lbm_value rest = get_cdr(ctx->curr_exp);
2005 if (lbm_is_symbol_nil(rest)) {
2006 ctx->app_cont = true1;
2007 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2008 } else {
2009 lbm_value *sptr = stack_reserve(ctx, 3);
2010 sptr[0] = ctx->curr_env;
2011 sptr[1] = get_cdr(rest);
2012 sptr[2] = OR(((7) << 2) | 0xF8000001u);
2013 ctx->curr_exp = get_car(rest);
2014 }
2015}
2016
2017// Pattern matching
2018// format:
2019// (match e (pattern body)
2020// (pattern body)
2021// ... )
2022//
2023// There can be an optional pattern guard:
2024// (match e (pattern guard body)
2025// ... )
2026// a guard is a boolean expression.
2027// Guards make match, pattern matching more complicated
2028// than the recv pattern matching and requires staged execution
2029// via the continuation system rather than a while loop over a list.
2030static void eval_match(eval_context_t *ctx) {
2031
2032 lbm_value rest = get_cdr(ctx->curr_exp);
2033 if (lbm_type_of(rest) == LBM_TYPE_SYMBOL0x00000000u &&
1
Taking false branch
→
2034 rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
2035 // Someone wrote the program (match)
2036 ctx->app_cont = true1;
2037 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2038 } else {
2039 lbm_value cdr_rest;
2
←
'cdr_rest' declared without an initial value
→
2040 get_car_and_cdr(rest, &ctx->curr_exp, &cdr_rest);
3
←
Calling 'get_car_and_cdr'
→
7
←
Returning from 'get_car_and_cdr'
→
2041 lbm_value *sptr = stack_reserve(ctx, 3);
2042 sptr[0] = cdr_rest;
8
←
Assigned value is garbage or undefined
2043 sptr[1] = ctx->curr_env;
2044 sptr[2] = MATCH(((9) << 2) | 0xF8000001u);
2045 }
2046}
2047
2048static void receive_base(eval_context_t *ctx, lbm_value pats, float timeout_time, bool_Bool timeout) {
2049 if (ctx->num_mail == 0) {
2050 if (timeout) {
2051 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000), false0);
2052 } else {
2053 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1,0,false0);
2054 }
2055 } else {
2056 lbm_value *msgs = ctx->mailbox;
2057 lbm_uint num = ctx->num_mail;
2058
2059 if (lbm_is_symbol_nil(pats)) {
2060 /* A receive statement without any patterns */
2061 ctx->app_cont = true1;
2062 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2063 } else {
2064 /* The common case */
2065 lbm_value e;
2066 lbm_value new_env = ctx->curr_env;
2067 int n = find_match(pats, msgs, num, &e, &new_env);
2068 if (n == FM_NEED_GC-1) {
2069 gc();
2070 new_env = ctx->curr_env;
2071 n = find_match(pats, msgs, num, &e, &new_env);
2072 if (n == FM_NEED_GC-1) {
2073 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2074 }
2075 }
2076 if (n == FM_PATTERN_ERROR-3) {
2077 lbm_set_error_reason("Incorrect pattern format for recv");
2078 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),pats);
2079 } else if (n >= 0 ) { /* Match */
2080 mailbox_remove_mail(ctx, (lbm_uint)n);
2081 ctx->curr_env = new_env;
2082 ctx->curr_exp = e;
2083 } else { /* No match go back to sleep */
2084 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
2085 if (timeout) {
2086 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2,S_TO_US(timeout_time)(lbm_uint)((timeout_time) * 1000000),false0);
2087 } else {
2088 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,false0);
2089 }
2090 }
2091 }
2092 }
2093 return;
2094}
2095
2096static void eval_receive_timeout(eval_context_t *ctx) {
2097 if (is_atomic) {
2098 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2099 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2100 }
2101 lbm_value timeout_val = get_cadr(ctx->curr_exp);
2102 if (!lbm_is_number(timeout_val)) {
2103 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2104 }
2105 float timeout_time = lbm_dec_as_float(timeout_val);
2106 lbm_value pats = get_cdr(get_cdr(ctx->curr_exp));
2107 receive_base(ctx, pats, timeout_time, true1);
2108}
2109
2110// Receive
2111// (recv (pattern expr)
2112// (pattern expr))
2113static void eval_receive(eval_context_t *ctx) {
2114
2115 if (is_atomic) {
2116 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2117 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->curr_exp);
2118 }
2119 lbm_value pats = get_cdr(ctx->curr_exp);
2120 receive_base(ctx, pats, 0, false0);
2121}
2122
2123/*********************************************************/
2124/* Continuation functions */
2125
2126/* cont_set_global_env
2127 sp-1 : Key-symbol
2128 */
2129static void cont_set_global_env(eval_context_t *ctx){
2130
2131 lbm_value key;
2132 lbm_value val = ctx->r;
2133
2134 lbm_pop(&ctx->K, &key);
2135 lbm_uint dec_key = lbm_dec_sym(key);
2136 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
2137 lbm_value *global_env = lbm_get_global_env();
2138 lbm_uint orig_env = global_env[ix_key];
2139 lbm_value new_env;
2140 // A key is a symbol and should not need to be remembered.
2141 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2142
2143 global_env[ix_key] = new_env;
2144 ctx->r = val;
2145
2146 ctx->app_cont = true1;
2147
2148 return;
2149}
2150
2151static void cont_resume(eval_context_t *ctx) {
2152 lbm_pop_2(&ctx->K, &ctx->curr_env, &ctx->curr_exp);
2153}
2154
2155static void cont_progn_rest(eval_context_t *ctx) {
2156 lbm_value *sptr = get_stack_ptr(ctx, 3);
2157
2158 lbm_value rest = sptr[2];
2159 lbm_value env = sptr[0];
2160
2161 lbm_value rest_car, rest_cdr;
2162 get_car_and_cdr(rest, &rest_car, &rest_cdr);
2163 ctx->curr_exp = rest_car;
2164 ctx->curr_env = env;
2165 if (lbm_is_symbol_nil(rest_cdr)) {
2166 // allow for tail recursion
2167 lbm_stack_drop(&ctx->K, 3);
2168 } else {
2169 sptr[2] = rest_cdr;
2170 stack_reserve(ctx, 1)[0] = PROGN_REST(((4) << 2) | 0xF8000001u);
2171 }
2172}
2173
2174static void cont_wait(eval_context_t *ctx) {
2175
2176 lbm_value cid_val;
2177 lbm_pop(&ctx->K, &cid_val);
2178 lbm_cid cid = (lbm_cid)lbm_dec_i(cid_val);
2179
2180 bool_Bool exists = false0;
2181
2182 lbm_blocked_iterator(context_exists, &cid, &exists);
2183 lbm_running_iterator(context_exists, &cid, &exists);
2184
2185 if (ctx_running->id == cid) {
2186 exists = true1;
2187 }
2188
2189 if (exists) {
2190 lbm_value *sptr = stack_reserve(ctx, 2);
2191 sptr[0] = lbm_enc_i(cid);
2192 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2193 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2194 ctx->app_cont = true1;
2195 yield_ctx(50000);
2196 } else {
2197 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2198 ctx->app_cont = true1;
2199 }
2200}
2201
2202static lbm_value perform_setvar(lbm_value key, lbm_value val, lbm_value env) {
2203
2204 lbm_uint s = lbm_dec_sym(key);
2205 if (s >= RUNTIME_SYMBOLS_START0x40000) {
2206 lbm_value new_env = lbm_env_modify_binding(env, key, val);
2207 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2208 lbm_uint ix_key = lbm_dec_sym(key) & GLOBAL_ENV_MASK0x1F;
2209 lbm_value *glob_env = lbm_get_global_env();
2210 new_env = lbm_env_modify_binding(glob_env[ix_key], key, val);
2211 glob_env[ix_key] = new_env;
2212 }
2213 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u)) {
2214 lbm_set_error_reason((char*)lbm_error_str_variable_not_bound);
2215 error_at_ctx(ENC_SYM_NOT_FOUND(((0x24) << 4) | 0x00000000u), key);
2216 }
2217 return val;
2218 }
2219 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2220 return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // unreachable
2221}
2222
2223static void apply_setvar(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2224 if (nargs == 2 && lbm_is_symbol(args[0])) {
2225 lbm_value res;
2226 WITH_GC(res, perform_setvar(args[0], args[1], ctx->curr_env))(res) = (perform_setvar(args[0], args[1], ctx->curr_env));
if (lbm_is_symbol_merror((res))) { gc(); (res) = (perform_setvar
(args[0], args[1], ctx->curr_env)); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2227 ctx->r = args[1];
2228 lbm_stack_drop(&ctx->K, nargs+1);
2229 ctx->app_cont = true1;
2230 } else {
2231 if (nargs == 2) lbm_set_error_reason((char*)lbm_error_str_incorrect_arg);
2232 else lbm_set_error_reason((char*)lbm_error_str_num_args);
2233 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SETVAR(((0x30000) << 4) | 0x00000000u));
2234 }
2235}
2236
2237static void apply_read_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, bool_Bool program, bool_Bool incremental) {
2238 if (nargs == 1) {
2239 lbm_value chan = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2240 if (lbm_type_of_functional(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2241 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2242 gc();
2243 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2244 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
2245 }
2246 }
2247 } else if (lbm_type_of(args[0]) == LBM_TYPE_CHANNEL0x90000000u) {
2248 chan = args[0];
2249 } else {
2250 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2251 }
2252 lbm_value *sptr = get_stack_ptr(ctx, 2);
2253
2254 // If we are inside a reader, its settings are stored.
2255 sptr[0] = lbm_enc_u(ctx->flags); // flags stored.
2256 sptr[1] = chan;
2257 lbm_value *rptr = stack_reserve(ctx,1);
2258 rptr[0] = READ_DONE(((20) << 2) | 0xF8000001u);
2259
2260 // Each reader starts in a fresh situation
2261 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
2262
2263 if (program) {
2264 if (incremental) {
2265 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2266 lbm_value *rptr1 = stack_reserve(ctx,3);
2267 rptr1[0] = chan;
2268 rptr1[1] = ctx->curr_env;
2269 rptr1[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
2270 } else {
2271 ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08;
2272 lbm_value *rptr1 = stack_reserve(ctx,4);
2273 rptr1[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2274 rptr1[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2275 rptr1[2] = chan;
2276 rptr1[3] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
2277 }
2278 }
2279 rptr = stack_reserve(ctx,3); // reuse of variable rptr
2280 rptr[0] = chan;
2281 rptr[1] = lbm_enc_u(1);
2282 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
2283 ctx->app_cont = true1;
2284 } else {
2285 lbm_set_error_reason((char*)lbm_error_str_num_args);
2286 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2287 }
2288}
2289
2290static void apply_read_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2291 apply_read_base(args,nargs,ctx,true1,false0);
2292}
2293
2294static void apply_read_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2295 apply_read_base(args,nargs,ctx,true1,true1);
2296}
2297
2298static void apply_read(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2299 apply_read_base(args,nargs,ctx,false0,false0);
2300}
2301
2302static void apply_spawn_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, uint32_t context_flags) {
2303
2304 lbm_uint stack_size = EVAL_CPS_DEFAULT_STACK_SIZE256;
2305 lbm_uint closure_pos = 0;
2306 char *name = NULL((void*)0);
2307
2308 if (nargs >= 1 &&
2309 lbm_is_closure(args[0])) {
2310 closure_pos = 0;
2311 } else if (nargs >= 2 &&
2312 lbm_is_number(args[0]) &&
2313 lbm_is_closure(args[1])) {
2314 stack_size = lbm_dec_as_u32(args[0]);
2315 closure_pos = 1;
2316 } else if (nargs >= 2 &&
2317 lbm_is_array_r(args[0]) &&
2318 lbm_is_closure(args[1])) {
2319 name = lbm_dec_str(args[0]);
2320 closure_pos = 1;
2321 }else if (nargs >= 3 &&
2322 lbm_is_array_r(args[0]) &&
2323 lbm_is_number(args[1]) &&
2324 lbm_is_closure(args[2])) {
2325 stack_size = lbm_dec_as_u32(args[1]);
2326 closure_pos = 2;
2327 name = lbm_dec_str(args[0]);
2328 } else {
2329 if (context_flags & EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01)
2330 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN_TRAP(((0x30005) << 4) | 0x00000000u));
2331 else
2332 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u),ENC_SYM_SPAWN(((0x30004) << 4) | 0x00000000u));
2333 }
2334
2335 lbm_value cl[3];
2336 extract_n(get_cdr(args[closure_pos]), cl, 3);
2337 lbm_value curr_param = cl[CLO_PARAMS0];
2338 lbm_value clo_env = cl[CLO_ENV2];
2339 lbm_uint i = closure_pos + 1;
2340 while (lbm_is_cons(curr_param) && i <= nargs) {
2341 lbm_value entry = cons_with_gc(get_car(curr_param), args[i], clo_env);
2342 lbm_value aug_env = cons_with_gc(entry, clo_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2343 clo_env = aug_env;
2344 curr_param = get_cdr(curr_param);
2345 i ++;
2346 }
2347
2348 lbm_stack_drop(&ctx->K, nargs+1);
2349
2350 lbm_value program = cons_with_gc(cl[CLO_BODY1], ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), clo_env);
2351
2352 lbm_cid cid = lbm_create_ctx_parent(program,
2353 clo_env,
2354 stack_size,
2355 lbm_get_current_cid(),
2356 context_flags,
2357 name);
2358 ctx->r = lbm_enc_i(cid);
2359 ctx->app_cont = true1;
2360}
2361
2362static void apply_spawn(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2363 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_NOTHING(uint32_t)0x00);
2364}
2365
2366static void apply_spawn_trap(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2367 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_TRAP(uint32_t)0x01);
2368}
2369
2370static void apply_yield(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2371 if (is_atomic) {
2372 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2373 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2374 }
2375 if (nargs == 1 && lbm_is_number(args[0])) {
2376 lbm_uint ts = lbm_dec_as_u32(args[0]);
2377 lbm_stack_drop(&ctx->K, nargs+1);
2378 yield_ctx(ts);
2379 } else {
2380 lbm_set_error_reason((char*)lbm_error_str_no_number);
2381 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_YIELD(((0x30006) << 4) | 0x00000000u));
2382 }
2383}
2384
2385static void apply_sleep(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2386 if (is_atomic) {
2387 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2388 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2389 }
2390 if (nargs == 1 && lbm_is_number(args[0])) {
2391 lbm_uint ts = (lbm_uint)(1000000.0f * lbm_dec_as_float(args[0]));
2392 lbm_stack_drop(&ctx->K, nargs+1);
2393 yield_ctx(ts);
2394 } else {
2395 lbm_set_error_reason((char*)lbm_error_str_no_number);
2396 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SLEEP(((0x30012) << 4) | 0x00000000u));
2397 }
2398}
2399
2400static void apply_wait(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2401 if (nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2402 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2403 lbm_value *sptr = get_stack_ptr(ctx, 2);
2404 sptr[0] = lbm_enc_i(cid);
2405 sptr[1] = WAIT(((8) << 2) | 0xF8000001u);
2406 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2407 ctx->app_cont = true1;
2408 yield_ctx(50000);
2409 } else {
2410 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_WAIT(((0x30007) << 4) | 0x00000000u));
2411 }
2412}
2413
2414/* (eval expr)
2415 (eval env expr) */
2416static void apply_eval(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2417 if ( nargs == 1) {
2418 ctx->curr_exp = args[0];
2419 } else if (nargs == 2) {
2420 ctx->curr_exp = args[1];
2421 ctx->curr_env = args[0];
2422 } else {
2423 lbm_set_error_reason((char*)lbm_error_str_num_args);
2424 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL(((0x30008) << 4) | 0x00000000u));
2425 }
2426 lbm_stack_drop(&ctx->K, nargs+1);
2427}
2428
2429static void apply_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2430 int prg_pos = 0;
2431 if (nargs == 2) {
2432 prg_pos = 1;
2433 ctx->curr_env = args[0];
2434 }
2435 if (nargs == 1 || nargs == 2) {
2436 lbm_value prg = args[prg_pos];
2437 lbm_value app_cont;
2438 lbm_value app_cont_prg;
2439 lbm_value new_prg;
2440 lbm_value prg_copy;
2441
2442 int len = -1;
2443 WITH_GC(prg_copy, lbm_list_copy(&len, prg))(prg_copy) = (lbm_list_copy(&len, prg)); if (lbm_is_symbol_merror
((prg_copy))) { gc(); (prg_copy) = (lbm_list_copy(&len, prg
)); if (lbm_is_symbol_merror((prg_copy))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2444 lbm_stack_drop(&ctx->K, nargs+1);
2445
2446 if (ctx->K.sp > nargs+2) { // if there is a continuation
2447 app_cont = cons_with_gc(ENC_SYM_APP_CONT(((0x111) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2448 app_cont_prg = cons_with_gc(app_cont, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), prg_copy);
2449 new_prg = lbm_list_append(app_cont_prg, ctx->program);
2450 new_prg = lbm_list_append(prg_copy, new_prg);
2451 } else {
2452 new_prg = lbm_list_append(prg_copy, ctx->program);
2453 }
2454 if (!lbm_is_list(new_prg)) {
2455 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2456 }
2457 stack_reserve(ctx, 1)[0] = DONE(((0) << 2) | 0xF8000001u);
2458 ctx->program = get_cdr(new_prg);
2459 ctx->curr_exp = get_car(new_prg);
2460 } else {
2461 lbm_set_error_reason((char*)lbm_error_str_num_args);
2462 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_EVAL_PROGRAM(((0x30009) << 4) | 0x00000000u));
2463 }
2464}
2465
2466static void apply_send(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2467 if (nargs == 2) {
2468 if (lbm_type_of(args[0]) == LBM_TYPE_I0x00000008u) {
2469 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2470 lbm_value msg = args[1];
2471 lbm_value status = lbm_find_receiver_and_send(cid, msg);
2472 /* return the status */
2473 lbm_stack_drop(&ctx->K, nargs+1);
2474 ctx->r = status;
2475 ctx->app_cont = true1;
2476 } else {
2477 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2478 }
2479 } else {
2480 lbm_set_error_reason((char*)lbm_error_str_num_args);
2481 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_SEND(((0x3000A) << 4) | 0x00000000u));
2482 }
2483}
2484
2485static void apply_ok(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2486 lbm_value ok_val = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2487 if (nargs >= 1) {
2488 ok_val = args[0];
2489 }
2490 ctx->r = ok_val;
2491 ok_ctx();
2492}
2493
2494static void apply_error(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2495 (void) ctx;
2496 lbm_value err_val = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
2497 if (nargs >= 1) {
2498 err_val = args[0];
2499 }
2500 error_at_ctx(err_val, ENC_SYM_EXIT_ERROR(((0x3000C) << 4) | 0x00000000u));
2501}
2502
2503// (map f arg-list)
2504static void apply_map(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2505 if (nargs == 2 && lbm_is_cons(args[1])) {
2506 lbm_value *sptr = get_stack_ptr(ctx, 3);
2507
2508 lbm_value f = args[0];
2509 lbm_value h = get_car(args[1]);
2510 lbm_value t = get_cdr(args[1]);
2511
2512 lbm_value appli_1;
2513 lbm_value appli;
2514 WITH_GC(appli_1, lbm_heap_allocate_list(2))(appli_1) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli_1))) { gc(); (appli_1) = (lbm_heap_allocate_list(2));
if (lbm_is_symbol_merror((appli_1))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2515 WITH_GC_RMBR_1(appli, lbm_heap_allocate_list(2), appli_1)(appli) = (lbm_heap_allocate_list(2)); if (lbm_is_symbol_merror
((appli))) { lbm_gc_mark_phase(appli_1); gc(); (appli) = (lbm_heap_allocate_list
(2)); if (lbm_is_symbol_merror((appli))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2516
2517 lbm_value appli_0 = get_cdr(appli_1);
2518
2519 lbm_set_car_and_cdr(appli_0, h, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2520 lbm_set_car(appli_1, ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u));
2521
2522 lbm_set_car_and_cdr(get_cdr(appli), appli_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2523 lbm_set_car(appli, f);
2524
2525 lbm_value elt = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), appli);
2526 sptr[0] = t; // reuse stack space
2527 sptr[1] = ctx->curr_env;
2528 sptr[2] = elt;
2529 lbm_value *rptr = stack_reserve(ctx,4);
2530 rptr[0] = elt;
2531 rptr[1] = appli;
2532 rptr[2] = appli_0;
2533 rptr[3] = MAP(((26) << 2) | 0xF8000001u);
2534 ctx->curr_exp = appli;
2535 } else if (nargs == 2 && lbm_is_symbol_nil(args[1])) {
2536 lbm_stack_drop(&ctx->K, 3);
2537 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2538 ctx->app_cont = true1;
2539 return;
2540 } else {
2541 lbm_set_error_reason((char*)lbm_error_str_num_args);
2542 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_MAP(((0x3000D) << 4) | 0x00000000u));
2543 }
2544}
2545
2546static void apply_reverse(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2547 if (nargs == 1 && lbm_is_list(args[0])) {
2548 lbm_value curr = args[0];
2549
2550 lbm_value new_list = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2551 while (lbm_is_cons(curr)) {
2552 lbm_value tmp = cons_with_gc(get_car(curr), new_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2553 new_list = tmp;
2554 curr = get_cdr(curr);
2555 }
2556 lbm_stack_drop(&ctx->K, 2);
2557 ctx->r = new_list;
2558 ctx->app_cont = true1;
2559 } else {
2560 lbm_set_error_reason("Reverse requires a list argument");
2561 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ENC_SYM_REVERSE(((0x3000E) << 4) | 0x00000000u));
2562 }
2563}
2564
2565static void apply_flatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2566 if (nargs == 1) {
2567
2568 lbm_value v = flatten_value(args[0]);
2569 if ( v == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)) {
2570 gc();
2571 v = flatten_value(args[0]);
2572 }
2573
2574 if (lbm_is_symbol(v)) {
2575 error_at_ctx(v, ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2576 } else {
2577 lbm_stack_drop(&ctx->K, 2);
2578 ctx->r = v;
2579 ctx->app_cont = true1;
2580 }
2581 return;
2582 }
2583 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_FLATTEN(((0x3000F) << 4) | 0x00000000u));
2584}
2585
2586static void apply_unflatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2587 if(nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_ARRAY0x80000000u) {
2588 lbm_array_header_t *array;
2589 array = (lbm_array_header_t *)get_car(args[0]);
2590
2591 lbm_flat_value_t fv;
2592 fv.buf = (uint8_t*)array->data;
2593 fv.buf_size = array->size;
2594 fv.buf_pos = 0;
2595
2596 lbm_value res;
2597
2598 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2599 if (lbm_unflatten_value(&fv, &res)) {
2600 ctx->r = res;
2601 }
2602 lbm_stack_drop(&ctx->K, 2);
2603 ctx->app_cont = true1;
2604 return;
2605 }
2606 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_UNFLATTEN(((0x30010) << 4) | 0x00000000u));
2607}
2608
2609static void apply_kill(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2610 if (nargs == 2 && lbm_is_number(args[0])) {
2611 lbm_cid cid = lbm_dec_as_i32(args[0]);
2612
2613 if (ctx->id == cid) {
2614 ctx->r = args[1];
2615 finish_ctx();
2616 return;
2617 }
2618 mutex_lock(&qmutex);
2619 eval_context_t *found = NULL((void*)0);
2620 found = lookup_ctx_nm(&blocked, cid);
2621 if (found)
2622 drop_ctx_nm(&blocked, found);
2623 else
2624 found = lookup_ctx_nm(&queue, cid);
2625 if (found)
2626 drop_ctx_nm(&queue, found);
2627
2628 if (found) {
2629 found->K.data[found->K.sp - 1] = KILL(((40) << 2) | 0xF8000001u);
2630 found->r = args[1];
2631 found->app_cont = true1;
2632 enqueue_ctx_nm(&queue,found);
2633 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
2634 } else {
2635 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2636 }
2637 lbm_stack_drop(&ctx->K, 3);
2638 ctx->app_cont = true1;
2639 mutex_unlock(&qmutex);
2640 return;
2641 }
2642 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_KILL(((0x30011) << 4) | 0x00000000u));
2643}
2644
2645// (merge comparator list1 list2)
2646static void apply_merge(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2647 if (nargs == 3 && lbm_is_list(args[1]) && lbm_is_list(args[2])) {
2648
2649 if (!lbm_is_closure(args[0])) {
2650 lbm_value closure;
2651 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2652 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2653 lbm_value cl1 = lbm_cdr(closure);
2654 lbm_value par;
2655 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2656 lbm_set_car(cl1, par);
2657 lbm_value cl2 = lbm_cdr(cl1);
2658 lbm_value body;
2659 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2660 lbm_set_car(cl2, body);
2661 lbm_value cl3 = lbm_cdr(cl2);
2662 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2663
2664 // Replace operator on stack with closure and rest of the code is
2665 // compatible.
2666 args[0] = closure;
2667 }
2668
2669 // Copy input lists for functional behaviour at top-level
2670 // merge itself is in-place in the copied lists.
2671 lbm_value a;
2672 lbm_value b;
2673 int len_a = -1;
2674 int len_b = -1;
2675 WITH_GC(a, lbm_list_copy(&len_a, args[1]))(a) = (lbm_list_copy(&len_a, args[1])); if (lbm_is_symbol_merror
((a))) { gc(); (a) = (lbm_list_copy(&len_a, args[1])); if
(lbm_is_symbol_merror((a))) { error_ctx((((0x23) << 4)
| 0x00000000u)); } };
2676 WITH_GC_RMBR_1(b, lbm_list_copy(&len_b, args[2]), a)(b) = (lbm_list_copy(&len_b, args[2])); if (lbm_is_symbol_merror
((b))) { lbm_gc_mark_phase(a); gc(); (b) = (lbm_list_copy(&
len_b, args[2])); if (lbm_is_symbol_merror((b))) { error_ctx(
(((0x23) << 4) | 0x00000000u)); } };
2677
2678 if (len_a == 0) {
2679 ctx->r = b;
2680 lbm_stack_drop(&ctx->K, 4);
2681 ctx->app_cont = true1;
2682 return;
2683 }
2684 if (len_b == 0) {
2685 ctx->r = a;
2686 lbm_stack_drop(&ctx->K, 4);
2687 ctx->app_cont = true1;
2688 return;
2689 }
2690
2691 args[1] = a; // keep safe by replacing the original on stack.
2692 args[2] = b;
2693
2694 lbm_value a_1 = a;
2695 lbm_value a_rest = lbm_cdr(a);
2696 lbm_value b_1 = b;
2697 lbm_value b_rest = lbm_cdr(b);
2698
2699 lbm_value cl[3]; // Comparator closure
2700 extract_n(lbm_cdr(args[0]), cl, 3);
2701 lbm_value cmp_env = cl[CLO_ENV2];
2702 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2703 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2704 lbm_uint len = lbm_list_length(cl[CLO_PARAMS0]);
2705 if (len == 2) {
2706 par1 = get_car(cl[CLO_PARAMS0]);
2707 par2 = get_cadr(cl[CLO_PARAMS0]);
2708 lbm_value new_env0;
2709 lbm_value new_env;
2710 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a_1)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a_1))); if (
lbm_is_symbol_merror((new_env0))) { gc(); (new_env0) = (lbm_env_set
(cmp_env, par1, lbm_car(a_1))); if (lbm_is_symbol_merror((new_env0
))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
2711 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b_1)),new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1))); if (
lbm_is_symbol_merror((new_env))) { lbm_gc_mark_phase(new_env0
); gc(); (new_env) = (lbm_env_set(new_env0, par2, lbm_car(b_1
))); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23
) << 4) | 0x00000000u)); } };
2712 cmp_env = new_env;
2713 } else {
2714 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2715 }
2716 lbm_set_cdr(a_1, b_1);
2717 lbm_set_cdr(b_1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2718 lbm_value cmp = cl[CLO_BODY1];
2719
2720 lbm_stack_drop(&ctx->K, 4); // TODO: Optimize drop 4 alloc 10 into alloc 6
2721 lbm_uint *sptr = stack_reserve(ctx, 10);
2722 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged list
2723 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged list
2724 sptr[2] = a_1;
2725 sptr[3] = a_rest;
2726 sptr[4] = b_rest;
2727 sptr[5] = cmp;
2728 sptr[6] = cmp_env;
2729 sptr[7] = par1;
2730 sptr[8] = par2;
2731 sptr[9] = MERGE_REST(((43) << 2) | 0xF8000001u);
2732 ctx->curr_exp = cl[CLO_BODY1];
2733 ctx->curr_env = cmp_env;
2734 return;
2735 }
2736 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MERGE(((0x30013) << 4) | 0x00000000u));
2737}
2738
2739// (sort comparator list)
2740static void apply_sort(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2741 if (nargs == 2 && lbm_is_list(args[1])) {
2742
2743 if (!lbm_is_closure(args[0])) {
2744 lbm_value closure;
2745 WITH_GC(closure, lbm_heap_allocate_list(4))(closure) = (lbm_heap_allocate_list(4)); if (lbm_is_symbol_merror
((closure))) { gc(); (closure) = (lbm_heap_allocate_list(4));
if (lbm_is_symbol_merror((closure))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2746 lbm_set_car(closure, ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u));
2747 lbm_value cl1 = lbm_cdr(closure);
2748 lbm_value par;
2749 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure)(par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y));
if (lbm_is_symbol_merror((par))) { lbm_gc_mark_phase(closure
); gc(); (par) = (lbm_heap_allocate_list_init(2, symbol_x, symbol_y
)); if (lbm_is_symbol_merror((par))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
2750 lbm_set_car(cl1, par);
2751 lbm_value cl2 = lbm_cdr(cl1);
2752 lbm_value body;
2753 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure)(body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y
)); if (lbm_is_symbol_merror((body))) { lbm_gc_mark_phase(closure
); gc(); (body) = (lbm_heap_allocate_list_init(3, args[0], symbol_x
, symbol_y)); if (lbm_is_symbol_merror((body))) { error_ctx((
((0x23) << 4) | 0x00000000u)); } };
2754 lbm_set_car(cl2, body);
2755 lbm_value cl3 = lbm_cdr(cl2);
2756 lbm_set_car(cl3, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2757
2758 // Replace operator on stack with closure and rest of the code is
2759 // compatible.
2760 args[0] = closure;
2761 }
2762
2763 int len = -1;
2764 lbm_value list_copy;
2765 WITH_GC(list_copy, lbm_list_copy(&len, args[1]))(list_copy) = (lbm_list_copy(&len, args[1])); if (lbm_is_symbol_merror
((list_copy))) { gc(); (list_copy) = (lbm_list_copy(&len,
args[1])); if (lbm_is_symbol_merror((list_copy))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2766 if (len <= 1) {
2767 lbm_stack_drop(&ctx->K, 3);
2768 ctx->r = list_copy;
2769 ctx->app_cont = true1;
2770 return;
2771 }
2772
2773 args[1] = list_copy; // Keep safe, original replaced on stack.
2774
2775 // Take the headmost 2, 1-element sublists.
2776 lbm_value a = list_copy;
2777 lbm_value b = lbm_cdr(a);
2778 lbm_value rest = lbm_cdr(b);
2779 // Do not terminate b. keep rest of list safe from GC in the following
2780 // closure extraction.
2781 //lbm_set_cdr(a, b); // This is void
2782
2783 lbm_value cl[3]; // Comparator closure
2784 extract_n(lbm_cdr(args[0]), cl, 3);
2785 lbm_value cmp_env = cl[CLO_ENV2];
2786 lbm_value par1 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2787 lbm_value par2 = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2788 lbm_uint cl_len = lbm_list_length(cl[CLO_PARAMS0]);
2789 if (cl_len == 2) {
2790 par1 = get_car(cl[CLO_PARAMS0]);
2791 par2 = get_cadr(cl[CLO_PARAMS0]);
2792 lbm_value new_env0;
2793 lbm_value new_env;
2794 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a)))(new_env0) = (lbm_env_set(cmp_env, par1, lbm_car(a))); if (lbm_is_symbol_merror
((new_env0))) { gc(); (new_env0) = (lbm_env_set(cmp_env, par1
, lbm_car(a))); if (lbm_is_symbol_merror((new_env0))) { error_ctx
((((0x23) << 4) | 0x00000000u)); } };
2795 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b)), new_env0)(new_env) = (lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { lbm_gc_mark_phase(new_env0); gc(); (new_env) =
(lbm_env_set(new_env0, par2, lbm_car(b))); if (lbm_is_symbol_merror
((new_env))) { error_ctx((((0x23) << 4) | 0x00000000u))
; } };
2796 cmp_env = new_env;
2797 } else {
2798 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), args[0]);
2799 }
2800 lbm_value cmp = cl[CLO_BODY1];
2801
2802 // Terminate the comparator argument list.
2803 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2804
2805 lbm_stack_drop(&ctx->K, 3); //TODO: optimize drop 3, alloc 20 into alloc 17
2806 lbm_uint *sptr = stack_reserve(ctx, 20);
2807 sptr[0] = cmp;
2808 sptr[1] = cmp_env;
2809 sptr[2] = par1;
2810 sptr[3] = par2;
2811 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged accumulation of sublists
2812 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged accumulation of sublists
2813 sptr[6] = rest;
2814 sptr[7] = lbm_enc_i(1);
2815 sptr[8] = lbm_enc_i(len); //TODO: 28 bit i vs 32 bit i
2816 sptr[9] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
2817 sptr[10] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // head of merged sublist
2818 sptr[11] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last of merged sublist
2819 sptr[12] = a;
2820 sptr[13] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no a_rest, 1 element lists in layer 1.
2821 sptr[14] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // no b_rest, 1 element lists in layer 1.
2822 sptr[15] = cmp;
2823 sptr[16] = cmp_env;
2824 sptr[17] = par1;
2825 sptr[18] = par2;
2826 sptr[19] = MERGE_REST(((43) << 2) | 0xF8000001u);
2827 ctx->curr_exp = cmp;
2828 ctx->curr_env = cmp_env;
2829 return;
2830 }
2831 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
2832}
2833
2834static void apply_rest_args(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2835 lbm_value res;
2836 if (lbm_env_lookup_b(&res, ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ctx->curr_env)) {
2837 if (nargs == 1 && lbm_is_number(args[0])) {
2838 int32_t ix = lbm_dec_as_i32(args[0]);
2839 res = lbm_index_list(res, ix);
2840 }
2841 ctx->r = res;
2842 } else {
2843 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2844 }
2845 lbm_stack_drop(&ctx->K, nargs+1);
2846 ctx->app_cont = true1;
2847}
2848
2849/* (rotate list-expr dist/dir-expr) */
2850static void apply_rotate(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2851 if (nargs == 2 && lbm_is_list(args[0]) && lbm_is_number(args[1])) {
2852 int len = -1;
2853 lbm_value ls = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2854 WITH_GC(ls, lbm_list_copy(&len, args[0]))(ls) = (lbm_list_copy(&len, args[0])); if (lbm_is_symbol_merror
((ls))) { gc(); (ls) = (lbm_list_copy(&len, args[0])); if
(lbm_is_symbol_merror((ls))) { error_ctx((((0x23) << 4
) | 0x00000000u)); } };
2855 int dist = lbm_dec_as_i32(args[1]);
2856 if (len > 0 && dist != 0) {
2857 int d = dist;
2858 if (dist > 0) {
2859 ls = lbm_list_destructive_reverse(ls);
2860 } else {
2861 d = -dist;
2862 }
2863
2864 lbm_value start = ls;
2865 lbm_value end = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
2866 lbm_value curr = start;
2867 while (lbm_is_cons(curr)) {
2868 end = curr;
2869 curr = get_cdr(curr);
2870 }
2871
2872 for (int i = 0; i < d; i ++) {
2873 lbm_value a = start;
2874 start = lbm_cdr(start);
2875 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
2876 lbm_set_cdr(end, a);
2877 end = a;
2878 }
2879 ls = start;
2880 if (dist > 0) {
2881 ls = lbm_list_destructive_reverse(ls);
2882 }
2883 }
2884 lbm_stack_drop(&ctx->K, nargs+1);
2885 ctx->app_cont = true1;
2886 ctx->r = ls;
2887 return;
2888 }
2889 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
2890}
2891
2892/***************************************************/
2893/* Application lookup table */
2894
2895typedef void (*apply_fun)(lbm_value *, lbm_uint, eval_context_t *);
2896static const apply_fun fun_table[] =
2897 {
2898 apply_setvar,
2899 apply_read,
2900 apply_read_program,
2901 apply_read_eval_program,
2902 apply_spawn,
2903 apply_spawn_trap,
2904 apply_yield,
2905 apply_wait,
2906 apply_eval,
2907 apply_eval_program,
2908 apply_send,
2909 apply_ok,
2910 apply_error,
2911 apply_map,
2912 apply_reverse,
2913 apply_flatten,
2914 apply_unflatten,
2915 apply_kill,
2916 apply_sleep,
2917 apply_merge,
2918 apply_sort,
2919 apply_rest_args,
2920 apply_rotate,
2921 };
2922
2923/***************************************************/
2924/* Application of function that takes arguments */
2925/* passed over the stack. */
2926
2927static void application(eval_context_t *ctx, lbm_value *fun_args, lbm_uint arg_count) {
2928 /* If arriving here, we know that the fun is a symbol.
2929 * and can be a built in operation or an extension.
2930 */
2931 lbm_value fun = fun_args[0];
2932
2933 lbm_uint fun_val = lbm_dec_sym(fun);
2934 lbm_uint fun_kind = SYMBOL_KIND(fun_val)((fun_val) >> 16);
2935
2936 switch (fun_kind) {
2937 case SYMBOL_KIND_EXTENSION1: {
2938 extension_fptr f = extension_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)].fptr;
2939
2940 lbm_value ext_res;
2941 WITH_GC(ext_res, f(&fun_args[1], arg_count))(ext_res) = (f(&fun_args[1], arg_count)); if (lbm_is_symbol_merror
((ext_res))) { gc(); (ext_res) = (f(&fun_args[1], arg_count
)); if (lbm_is_symbol_merror((ext_res))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
2942 if (lbm_is_error(ext_res)) { //Error other than merror
2943 error_at_ctx(ext_res, fun);
2944 }
2945 lbm_stack_drop(&ctx->K, arg_count + 1);
2946
2947 ctx->app_cont = true1;
2948 ctx->r = ext_res;
2949
2950 if (blocking_extension) {
2951 blocking_extension = false0;
2952 if (blocking_extension_timeout) {
2953 blocking_extension_timeout = false0;
2954 block_current_ctx(LBM_THREAD_STATE_TIMEOUT(uint32_t)2, blocking_extension_timeout_us,true1);
2955 } else {
2956 block_current_ctx(LBM_THREAD_STATE_BLOCKED(uint32_t)1, 0,true1);
2957 }
2958 mutex_unlock(&blocking_extension_mutex);
2959 }
2960 } break;
2961 case SYMBOL_KIND_FUNDAMENTAL2:
2962 call_fundamental(SYMBOL_IX(fun_val)((fun_val) & 0xFFFF), &fun_args[1], arg_count, ctx);
2963 break;
2964 case SYMBOL_KIND_APPFUN3:
2965 fun_table[SYMBOL_IX(fun_val)((fun_val) & 0xFFFF)](&fun_args[1], arg_count, ctx);
2966 break;
2967 default:
2968 // Symbols that are "special" but not in the way caught above
2969 // ends up here.
2970 lbm_set_error_reason("Symbol does not represent a function");
2971 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u),fun_args[0]);
2972 break;
2973 }
2974}
2975
2976static void cont_closure_application_args(eval_context_t *ctx) {
2977 lbm_uint* sptr = get_stack_ptr(ctx, 5);
2978
2979 lbm_value arg_env = (lbm_value)sptr[0];
2980 lbm_value exp = (lbm_value)sptr[1];
2981 lbm_value clo_env = (lbm_value)sptr[2];
2982 lbm_value params = (lbm_value)sptr[3];
2983 lbm_value args = (lbm_value)sptr[4];
2984
2985 lbm_value car_params, cdr_params;
2986 get_car_and_cdr(params, &car_params, &cdr_params);
2987
2988 bool_Bool a_nil = lbm_is_symbol_nil(args);
2989 bool_Bool p_nil = lbm_is_symbol_nil(cdr_params);
2990
2991 lbm_value binder = allocate_binding(car_params, ctx->r, clo_env);
2992
2993 if (!a_nil && !p_nil) {
2994 lbm_value car_args, cdr_args;
2995 get_car_and_cdr(args, &car_args, &cdr_args);
2996 sptr[2] = binder;
2997 sptr[3] = cdr_params;
2998 sptr[4] = cdr_args;
2999 stack_reserve(ctx,1)[0] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
3000 ctx->curr_exp = car_args;
3001 ctx->curr_env = arg_env;
3002 } else if (a_nil && p_nil) {
3003 // Arguments and parameters match up in number
3004 lbm_stack_drop(&ctx->K, 5);
3005 ctx->curr_env = binder;
3006 ctx->curr_exp = exp;
3007 } else if (p_nil) {
3008 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), binder);
3009 sptr[2] = rest_binder;
3010 sptr[3] = get_cdr(args);
3011 sptr[4] = get_car(rest_binder); // last element of rest_args so far
3012 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3013 ctx->curr_exp = get_car(args);
3014 ctx->curr_env = arg_env;
3015 } else {
3016 lbm_set_error_reason((char*)lbm_error_str_num_args);
3017 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
3018 }
3019}
3020
3021
3022static void cont_closure_args_rest(eval_context_t *ctx) {
3023 lbm_uint* sptr = get_stack_ptr(ctx, 5);
3024 lbm_value arg_env = (lbm_value)sptr[0];
3025 lbm_value exp = (lbm_value)sptr[1];
3026 lbm_value clo_env = (lbm_value)sptr[2];
3027 lbm_value args = (lbm_value)sptr[3];
3028 lbm_value last = (lbm_value)sptr[4];
3029 lbm_cons_t* heap = lbm_heap_state.heap;
3030
3031 lbm_value binding = lbm_heap_state.freelist;
3032 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3033 gc();
3034 binding = lbm_heap_state.freelist;
3035 if (binding == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3036 }
3037 lbm_uint binding_ix = lbm_dec_ptr(binding);
3038 lbm_heap_state.freelist = heap[binding_ix].cdr;
3039 lbm_heap_state.num_alloc += 1;
3040 heap[binding_ix].car = ctx->r;
3041 heap[binding_ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3042
3043
3044 lbm_set_cdr(last, binding);
3045 sptr[4] = binding;
3046
3047 if (args == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3048 lbm_stack_drop(&ctx->K, 5);
3049 ctx->curr_env = clo_env;
3050 ctx->curr_exp = exp;
3051 } else {
3052 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
3053 sptr[3] = get_cdr(args);
3054 ctx->curr_exp = get_car(args);
3055 ctx->curr_env = arg_env;
3056 }
3057}
3058
3059static void cont_application_args(eval_context_t *ctx) {
3060 lbm_uint *sptr = get_stack_ptr(ctx, 3);
3061
3062 lbm_value env = sptr[0];
3063 lbm_value rest = sptr[1];
3064 lbm_value count = sptr[2];
3065
3066 ctx->curr_env = env;
3067 sptr[0] = ctx->r; // Function 1st then Arguments
3068 if (lbm_is_cons(rest)) {
3069 lbm_cons_t *cell = lbm_ref_cell(rest);
3070 sptr[1] = env;
3071 sptr[2] = cell->cdr;
3072 lbm_value *rptr = stack_reserve(ctx,2);
3073 rptr[0] = count + (1 << LBM_VAL_SHIFT4);
3074 rptr[1] = APPLICATION_ARGS(((5) << 2) | 0xF8000001u);
3075 ctx->curr_exp = cell->car;
3076 } else {
3077 // No more arguments
3078 lbm_stack_drop(&ctx->K, 2);
3079 lbm_uint nargs = lbm_dec_u(count);
3080 lbm_value *args = get_stack_ptr(ctx, (uint32_t)(nargs + 1));
3081 application(ctx,args, nargs);
3082 }
3083}
3084
3085static void cont_and(eval_context_t *ctx) {
3086 lbm_value env;
3087 lbm_value rest;
3088 lbm_value arg = ctx->r;
3089 lbm_pop_2(&ctx->K, &rest, &env);
3090 if (lbm_is_symbol_nil(arg)) {
3091 ctx->app_cont = true1;
3092 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3093 } else if (lbm_is_symbol_nil(rest)) {
3094 ctx->app_cont = true1;
3095 } else {
3096 lbm_value *sptr = stack_reserve(ctx, 3);
3097 sptr[0] = env;
3098 sptr[1] = get_cdr(rest);
3099 sptr[2] = AND(((6) << 2) | 0xF8000001u);
3100 ctx->curr_env = env;
3101 ctx->curr_exp = get_car(rest);
3102 }
3103}
3104
3105static void cont_or(eval_context_t *ctx) {
3106 lbm_value env;
3107 lbm_value rest;
3108 lbm_value arg = ctx->r;
3109 lbm_pop_2(&ctx->K, &rest, &env);
3110 if (!lbm_is_symbol_nil(arg)) {
3111 ctx->app_cont = true1;
3112 } else if (lbm_is_symbol_nil(rest)) {
3113 ctx->app_cont = true1;
3114 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3115 } else {
3116 lbm_value *sptr = stack_reserve(ctx, 3);
3117 sptr[0] = env;
3118 sptr[1] = get_cdr(rest);
3119 sptr[2] = OR(((7) << 2) | 0xF8000001u);
3120 ctx->curr_exp = get_car(rest);
3121 ctx->curr_env = env;
3122 }
3123}
3124
3125static int fill_binding_location(lbm_value key, lbm_value value, lbm_value env) {
3126 if (lbm_type_of(key) == LBM_TYPE_SYMBOL0x00000000u) {
3127 if (key == ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u)) return FB_OK0;
3128 lbm_env_modify_binding(env,key,value);
3129 return FB_OK0;
3130 } else if (lbm_is_cons(key) &&
3131 lbm_is_cons(value)) {
3132 int r = fill_binding_location(get_car(key), get_car(value), env);
3133 if (r == FB_OK0) {
3134 r = fill_binding_location(get_cdr(key), get_cdr(value), env);
3135 }
3136 return r;
3137 }
3138 return FB_TYPE_ERROR-1;
3139}
3140
3141static void cont_bind_to_key_rest(eval_context_t *ctx) {
3142
3143 lbm_value *sptr = get_stack_ptr(ctx, 4);
3144
3145 lbm_value rest = sptr[1];
3146 lbm_value env = sptr[2];
3147 lbm_value key = sptr[3];
3148
3149 if (fill_binding_location(key, ctx->r, env) < 0) {
3150 lbm_set_error_reason("Incorrect type of name/key in let-binding");
3151 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
3152 }
3153
3154 if (lbm_is_cons(rest)) {
3155 lbm_value car_rest = get_car(rest);
3156 lbm_value key_val[2];
3157 extract_n(car_rest, key_val, 2);
3158
3159 sptr[1] = get_cdr(rest);
3160 sptr[3] = key_val[0];
3161 stack_reserve(ctx,1)[0] = BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u);
3162 ctx->curr_exp = key_val[1];
3163 ctx->curr_env = env;
3164 } else {
3165 // Otherwise evaluate the expression in the populated env
3166 ctx->curr_exp = sptr[0];
3167 ctx->curr_env = env;
3168 lbm_stack_drop(&ctx->K, 4);
3169 }
3170}
3171
3172static void cont_if(eval_context_t *ctx) {
3173
3174 lbm_value arg = ctx->r;
3175
3176 lbm_value *sptr = pop_stack_ptr(ctx, 2);
3177
3178 ctx->curr_env = sptr[1];
3179 if (lbm_is_symbol_nil(arg)) {
3180 ctx->curr_exp = get_cadr(sptr[0]); // else branch
3181 } else {
3182 ctx->curr_exp = get_car(sptr[0]); // then branch
3183 }
3184}
3185
3186static void cont_match(eval_context_t *ctx) {
3187 lbm_value e = ctx->r;
3188 bool_Bool do_gc = false0;
3189
3190 lbm_uint *sptr = get_stack_ptr(ctx, 2);
3191 lbm_value patterns = (lbm_value)sptr[0];
3192 lbm_value orig_env = (lbm_value)sptr[1]; // restore enclosing environment.
3193 lbm_value new_env = orig_env;
3194
3195 if (lbm_is_symbol_nil(patterns)) {
3196 // no more patterns
3197 lbm_stack_drop(&ctx->K, 2);
3198 ctx->r = ENC_SYM_NO_MATCH(((0x40) << 4) | 0x00000000u);
3199 ctx->app_cont = true1;
3200 } else if (lbm_is_cons(patterns)) {
3201 lbm_value match_case = get_car(patterns);
3202 lbm_value pattern = get_car(match_case);
3203 lbm_value n1 = get_cadr(match_case);
3204 lbm_value n2 = get_cadr(get_cdr(match_case));
3205 lbm_value body;
3206 bool_Bool check_guard = false0;
3207 if (lbm_is_symbol_nil(n2)) { // TODO: Not a very robust check.
3208 body = n1;
3209 } else {
3210 body = n2;
3211 check_guard = true1;
3212 }
3213
3214 bool_Bool is_match = match(pattern, e, &new_env, &do_gc);
3215 if (do_gc) {
3216 gc();
3217 do_gc = false0;
3218 new_env = orig_env;
3219 is_match = match(pattern, e, &new_env, &do_gc);
3220 if (do_gc) {
3221 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3222 }
3223 }
3224 if (is_match) {
3225 if (check_guard) {
3226 lbm_value *rptr = stack_reserve(ctx,5);
3227 sptr[0] = get_cdr(patterns);
3228 sptr[1] = ctx->curr_env;
3229 rptr[0] = MATCH(((9) << 2) | 0xF8000001u);
3230 rptr[1] = new_env;
3231 rptr[2] = body;
3232 rptr[3] = e;
3233 rptr[4] = MATCH_GUARD(((27) << 2) | 0xF8000001u);
3234 ctx->curr_env = new_env;
3235 ctx->curr_exp = n1; // The guard
3236 } else {
3237 lbm_stack_drop(&ctx->K, 2);
3238 ctx->curr_env = new_env;
3239 ctx->curr_exp = body;
3240 }
3241 } else {
3242 // set up for checking of next pattern
3243 sptr[0] = get_cdr(patterns);
3244 sptr[1] = orig_env;
3245 stack_reserve(ctx,1)[0] = MATCH(((9) << 2) | 0xF8000001u);
3246 // leave r unaltered
3247 ctx->app_cont = true1;
3248 }
3249 } else {
3250 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), ENC_SYM_MATCH(((0x108) << 4) | 0x00000000u));
3251 }
3252}
3253
3254static void cont_exit_atomic(eval_context_t *ctx) {
3255 is_atomic --;
3256 ctx->app_cont = true1;
3257}
3258
3259static void cont_map(eval_context_t *ctx) {
3260 lbm_value *sptr = get_stack_ptr(ctx, 6);
3261
3262 lbm_value ls = sptr[0];
3263 lbm_value env = sptr[1];
3264 lbm_value t = sptr[3];
3265 lbm_set_car(t, ctx->r); // update car field tailmost position.
3266 if (lbm_is_cons(ls)) {
3267 lbm_value next, rest;
3268 get_car_and_cdr(ls, &next, &rest);
3269 sptr[0] = rest;
3270 stack_reserve(ctx,1)[0] = MAP(((26) << 2) | 0xF8000001u);
3271 lbm_set_car(sptr[5], next); // new arguments
3272
3273 lbm_value elt = cons_with_gc(ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3274 lbm_set_cdr(t, elt);
3275 sptr[3] = elt; // (r1 ... rN . (nil . nil))
3276 ctx->curr_exp = sptr[4];
3277 ctx->curr_env = env;
3278 } else {
3279 ctx->r = sptr[2]; //head of result list
3280 ctx->curr_env = env;
3281 lbm_stack_drop(&ctx->K, 6);
3282 ctx->app_cont = true1;
3283 }
3284}
3285
3286static void cont_match_guard(eval_context_t *ctx) {
3287 if (lbm_is_symbol_nil(ctx->r)) {
3288 lbm_value e;
3289 lbm_pop(&ctx->K, &e);
3290 lbm_stack_drop(&ctx->K, 2);
3291 ctx->r = e;
3292 ctx->app_cont = true1;
3293 } else {
3294 lbm_value body;
3295 lbm_value env;
3296 lbm_stack_drop(&ctx->K, 1);
3297 lbm_pop_2(&ctx->K, &body, &env);
3298 lbm_stack_drop(&ctx->K, 3);
3299 ctx->curr_env = env;
3300 ctx->curr_exp = body;
3301 }
3302}
3303
3304static void cont_terminate(eval_context_t *ctx) {
3305 error_ctx(ctx->r);
3306}
3307
3308static void cont_loop(eval_context_t *ctx) {
3309 lbm_value *sptr = get_stack_ptr(ctx, 2);
3310 stack_reserve(ctx,1)[0] = LOOP_CONDITION(((42) << 2) | 0xF8000001u);
3311 ctx->curr_exp = sptr[1];
3312}
3313
3314static void cont_loop_condition(eval_context_t *ctx) {
3315 if (lbm_is_symbol_nil(ctx->r)) {
3316 lbm_stack_drop(&ctx->K, 2);
3317 ctx->app_cont = true1; // A loop returns nil? Makes sense to me... but in general?
3318 return;
3319 }
3320 lbm_value *sptr = get_stack_ptr(ctx, 2);
3321 stack_reserve(ctx,1)[0] = LOOP(((41) << 2) | 0xF8000001u);
3322 ctx->curr_exp = sptr[0];
3323}
3324
3325static void cont_merge_rest(eval_context_t *ctx) {
3326 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3327
3328 // If comparator returns true (result is in ctx->r):
3329 // "a" should be moved to the last element position in merged list.
3330 // A new element from "a_rest" should be moved into comparator argument 1 pos.
3331 // else
3332 // "b" should be moved to last element position in merged list.
3333 // A new element from "b_rest" should be moved into comparator argument 2 pos.
3334 //
3335 // If a_rest or b_rest is NIL:
3336 // we are done, the remaining elements of
3337 // non_nil list should be appended to merged list.
3338 // else
3339 // Set up for a new comparator evaluation and recurse.
3340 lbm_value a = sptr[2];
3341 lbm_value b = lbm_cdr(a);
3342 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate 1 element list
3343
3344 if (ctx->r == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) { // Comparison false
3345
3346 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3347 sptr[0] = b;
3348 sptr[1] = b;
3349 } else {
3350 lbm_set_cdr(sptr[1], b);
3351 sptr[1] = b;
3352 }
3353 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3354 lbm_set_cdr(a, sptr[3]);
3355 lbm_set_cdr(sptr[1], a);
3356 ctx->r = sptr[0];
3357 lbm_stack_drop(&ctx->K, 9);
3358 ctx->app_cont = true1;
3359 return;
3360 } else {
3361 b = sptr[4];
3362 sptr[4] = lbm_cdr(sptr[4]);
3363 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3364 }
3365 } else {
3366 if (sptr[0] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3367 sptr[0] = a;
3368 sptr[1] = a;
3369 } else {
3370 lbm_set_cdr(sptr[1], a);
3371 sptr[1] = a;
3372 }
3373
3374 if (sptr[3] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3375 lbm_set_cdr(b, sptr[4]);
3376 lbm_set_cdr(sptr[1], b);
3377 ctx->r = sptr[0];
3378 lbm_stack_drop(&ctx->K, 9);
3379 ctx->app_cont = true1;
3380 return;
3381 } else {
3382 a = sptr[3];
3383 sptr[3] = lbm_cdr(sptr[3]);
3384 lbm_set_cdr(a, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3385 }
3386 }
3387 lbm_set_cdr(a, b);
3388 sptr[2] = a;
3389
3390 lbm_value par1 = sptr[7];
3391 lbm_value par2 = sptr[8];
3392 lbm_value cmp_body = sptr[5];
3393 lbm_value cmp_env = sptr[6];
3394 // Environment should be preallocated already at this point
3395 // and the operations below should never need GC.
3396 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3397 lbm_value new_env = lbm_env_set(new_env0, par2, lbm_car(b));
3398 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3399 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3400 }
3401 cmp_env = new_env;
3402
3403 stack_reserve(ctx,1)[0] = MERGE_REST(((43) << 2) | 0xF8000001u);
3404 ctx->curr_exp = cmp_body;
3405 ctx->curr_env = cmp_env;
3406}
3407
3408// merge_layer stack contents
3409// s[sp-9] = cmp
3410// s[sp-8] = cmp_env
3411// s[sp-7] = par1
3412// s[sp-6] = par2
3413// s[sp-5] = acc - first cell
3414// s[sp-4] = acc - last cell
3415// s[sp-3] = rest;
3416// s[sp-2] = layer
3417// s[sp-1] = length or original list
3418//
3419// ctx->r merged sublist
3420static void cont_merge_layer(eval_context_t *ctx) {
3421 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3422 lbm_int layer = lbm_dec_i(sptr[7]);
3423 lbm_int len = lbm_dec_i(sptr[8]);
3424
3425 lbm_value r_curr = ctx->r;
3426 while (lbm_is_cons(r_curr)) {
3427 lbm_value next = lbm_cdr(r_curr);
3428 if (next == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3429 break;
3430 }
3431 r_curr = next;
3432 }
3433
3434 if (sptr[4] == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3435 sptr[4] = ctx->r;
3436 sptr[5] = r_curr;
3437 } else {
3438 lbm_set_cdr(sptr[5], ctx->r); // accumulate merged sublists.
3439 sptr[5] = r_curr;
3440 }
3441
3442 lbm_value layer_rest = sptr[6];
3443 // switch layer or done ?
3444 if (layer_rest == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3445 if (layer * 2 >= len) {
3446 ctx->r = sptr[4];
3447 ctx->app_cont = true1;
3448 lbm_stack_drop(&ctx->K, 9);
3449 return;
3450 } else {
3451 // Setup for merges of the next layer
3452 layer = layer * 2;
3453 sptr[7] = lbm_enc_i(layer);
3454 layer_rest = sptr[4]; // continue on the accumulation of all sublists.
3455 sptr[5] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3456 sptr[4] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3457 }
3458 }
3459 // merge another sublist based on current layer.
3460 lbm_value a_list = layer_rest;
3461 // build sublist a
3462 lbm_value curr = layer_rest;
3463 for (int i = 0; i < layer-1; i ++) {
3464 if (lbm_is_cons(curr)) {
3465 curr = lbm_cdr(curr);
3466 } else {
3467 break;
3468 }
3469 }
3470 layer_rest = lbm_cdr(curr);
3471 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3472
3473 lbm_value b_list = layer_rest;
3474 // build sublist b
3475 curr = layer_rest;
3476 for (int i = 0; i < layer-1; i ++) {
3477 if (lbm_is_cons(curr)) {
3478 curr = lbm_cdr(curr);
3479 } else {
3480 break;
3481 }
3482 }
3483 layer_rest = lbm_cdr(curr);
3484 lbm_set_cdr(curr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); //terminate sublist.
3485
3486 sptr[6] = layer_rest;
3487
3488 if (b_list == ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)) {
3489 stack_reserve(ctx,1)[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3490 ctx->r = a_list;
3491 ctx->app_cont = true1;
3492 return;
3493 }
3494 // Set up for a merge of sublists.
3495
3496 lbm_value a_rest = lbm_cdr(a_list);
3497 lbm_value b_rest = lbm_cdr(b_list);
3498 lbm_value a = a_list;
3499 lbm_value b = b_list;
3500 lbm_set_cdr(a, b);
3501 // Terminating the b list would be incorrect here
3502 // if there was any chance that the environment update below
3503 // performs GC.
3504 lbm_set_cdr(b, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
3505
3506 lbm_value cmp_body = sptr[0];
3507 lbm_value cmp_env = sptr[1];
3508 lbm_value par1 = sptr[2];
3509 lbm_value par2 = sptr[3];
3510 // Environment should be preallocated already at this point
3511 // and the operations below should never need GC.
3512 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3513 lbm_value new_env = lbm_env_set(cmp_env, par2, lbm_car(b));
3514 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3515 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3516 }
3517 cmp_env = new_env;
3518
3519 lbm_uint *merge_cont = stack_reserve(ctx, 11);
3520 merge_cont[0] = MERGE_LAYER(((44) << 2) | 0xF8000001u);
3521 merge_cont[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3522 merge_cont[2] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3523 merge_cont[3] = a;
3524 merge_cont[4] = a_rest;
3525 merge_cont[5] = b_rest;
3526 merge_cont[6] = cmp_body;
3527 merge_cont[7] = cmp_env;
3528 merge_cont[8] = par1;
3529 merge_cont[9] = par2;
3530 merge_cont[10] = MERGE_REST(((43) << 2) | 0xF8000001u);
3531 ctx->curr_exp = cmp_body;
3532 ctx->curr_env = cmp_env;
3533 return;
3534}
3535
3536/****************************************************/
3537/* READER */
3538
3539static void read_finish(lbm_char_channel_t *str, eval_context_t *ctx) {
3540
3541 /* Tokenizer reached "end of file"
3542 The parser could be in a state where it needs
3543 more tokens to correctly finish an expression.
3544
3545 Three cases
3546 1. The program / expression is malformed and the context should die.
3547 2. We are finished reading a program and should close off the
3548 internal representation with a closing parenthesis. Then
3549 apply continuation.
3550 3. We are finished reading an expression and should
3551 apply the continuation.
3552
3553 In case 3, we should find the READ_DONE at sp - 1.
3554 In case 2, we should find the READ_DONE at sp - 5.
3555
3556 */
3557
3558 if (lbm_is_symbol(ctx->r)) {
3559 lbm_uint sym_val = lbm_dec_sym(ctx->r);
3560 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
3561 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
3562 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3563 }
3564 }
3565
3566 if (ctx->K.data[ctx->K.sp-1] == READ_DONE(((20) << 2) | 0xF8000001u) &&
3567 lbm_dec_u(ctx->K.data[ctx->K.sp-3]) == 0) {
3568 /* successfully finished reading an expression (CASE 3) */
3569 ctx->app_cont = true1;
3570 } else if (ctx->K.sp > 4 && ctx->K.data[ctx->K.sp - 4] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3571 lbm_value env;
3572 lbm_value s;
3573 lbm_value sym;
3574 lbm_pop_3(&ctx->K, &sym, &env, &s);
3575 ctx->curr_env = env;
3576 ctx->app_cont = true1; // Program evaluated and result is in ctx->r.
3577 } else if (ctx->K.sp > 5 && ctx->K.data[ctx->K.sp - 5] == READ_DONE(((20) << 2) | 0xF8000001u)) {
3578 /* successfully finished reading a program (CASE 2) */
3579 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3580 ctx->app_cont = true1;
3581 } else {
3582 /* Parsing failed */
3583 if (lbm_channel_row(str) == 1 &&
3584 lbm_channel_column(str) == 1 ){
3585 // eof at empty stream.
3586 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3587 ctx->app_cont = true1;
3588 } else {
3589 lbm_set_error_reason((char*)lbm_error_str_parse_eof);
3590 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3591 }
3592 lbm_channel_reader_close(str);
3593 }
3594}
3595
3596/* cont_read_next_token
3597 sp-2 : Stream
3598 sp-1 : Grab row
3599*/
3600static void cont_read_next_token(eval_context_t *ctx) {
3601 lbm_value *sptr = get_stack_ptr(ctx, 2);
3602 lbm_value stream = sptr[0];
3603 lbm_value grab_row0 = sptr[1];
3604
3605 lbm_char_channel_t *chan = lbm_dec_channel(stream);
3606 if (chan == NULL((void*)0) || chan->state == NULL((void*)0)) {
3607 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3608 }
3609
3610 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3611 lbm_stack_drop(&ctx->K, 2);
3612 read_finish(chan, ctx);
3613 return;
3614 }
3615 /* Eat whitespace and comments */
3616 if (!tok_clean_whitespace(chan)) {
3617 sptr[0] = stream;
3618 sptr[1] = lbm_enc_u(0);
3619 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3620 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3621 return;
3622 }
3623 /* After eating whitespace we may be at end of file/stream */
3624 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3625 lbm_stack_drop(&ctx->K, 2);
3626 read_finish(chan, ctx);
3627 return;
3628 }
3629
3630 if (lbm_dec_u(grab_row0)) {
3631 ctx->row0 = (int32_t)lbm_channel_row(chan);
3632 }
3633
3634 /* Attempt to extract tokens from the character stream */
3635 int n = 0;
3636 lbm_value res = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3637 unsigned int string_len = 0;
3638
3639 /*
3640 * SYNTAX
3641 */
3642 uint32_t match;
3643 n = tok_syntax(chan, &match);
3644 if (n > 0) {
3645 if (!lbm_channel_drop(chan, (unsigned int)n)) {
3646 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3647 }
3648 ctx->app_cont = true1;
3649 lbm_uint do_next = 0;
3650 switch(match) {
3651 case TOKOPENPAR1u: {
3652 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3653 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3654 lbm_value *rptr = stack_reserve(ctx,5);
3655 rptr[0] = stream;
3656 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3657 rptr[2] = stream;
3658 rptr[3] = lbm_enc_u(0);
3659 rptr[4] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3660 ctx->r = ENC_SYM_OPENPAR(((0x70) << 4) | 0x00000000u);
3661 } return;
3662 case TOKCLOSEPAR2u: {
3663 lbm_stack_drop(&ctx->K, 2);
3664 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3665 } return;
3666 case TOKOPENBRACK3u: {
3667 sptr[0] = stream;
3668 sptr[1] = READ_START_ARRAY(((24) << 2) | 0xF8000001u);
3669 lbm_value *rptr = stack_reserve(ctx, 3);
3670 rptr[0] = stream;
3671 rptr[1] = lbm_enc_u(0);
3672 rptr[2] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3673 ctx->r = ENC_SYM_OPENBRACK(((0x80) << 4) | 0x00000000u);
3674 } return;
3675 case TOKCLOSEBRACK4u:
3676 lbm_stack_drop(&ctx->K, 2);
3677 ctx->r = ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u);
3678 return;
3679 case TOKDOT5u:
3680 lbm_stack_drop(&ctx->K, 2);
3681 ctx->r = ENC_SYM_DOT(((0x76) << 4) | 0x00000000u);
3682 return;
3683 case TOKDONTCARE6u:
3684 lbm_stack_drop(&ctx->K, 2);
3685 ctx->r = ENC_SYM_DONTCARE(((0x9) << 4) | 0x00000000u);
3686 return;
3687 case TOKQUOTE7u:
3688 do_next = READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u);
3689 break;
3690 case TOKBACKQUOTE8u: {
3691 sptr[0] = QQ_EXPAND_START(((35) << 2) | 0xF8000001u);
3692 sptr[1] = stream;
3693 lbm_value *rptr = stack_reserve(ctx, 2);
3694 rptr[0] = lbm_enc_u(0);
3695 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3696 ctx->app_cont = true1;
3697 } return;
3698 case TOKCOMMAAT9u:
3699 do_next = READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u);
3700 break;
3701 case TOKCOMMA10u:
3702 do_next = READ_COMMA_RESULT(((23) << 2) | 0xF8000001u);
3703 break;
3704 case TOKMATCHANY11u:
3705 lbm_stack_drop(&ctx->K, 2);
3706 ctx->r = ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u);
3707 return;
3708 case TOKOPENCURL12u: {
3709 sptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3710 sptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
3711 lbm_value *rptr = stack_reserve(ctx,2);
3712 rptr[0] = stream;
3713 rptr[1] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
3714 ctx->r = ENC_SYM_PROGN(((0x102) << 4) | 0x00000000u);
3715 } return;
3716 case TOKCLOSECURL13u:
3717 lbm_stack_drop(&ctx->K, 2);
3718 ctx->r = ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u);
3719 return;
3720 case TOKCONSTSTART14u: /* fall through */
3721 case TOKCONSTEND15u:
3722 case TOKCONSTSYMSTR16u: {
3723 if (match == TOKCONSTSTART14u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3724 if (match == TOKCONSTEND15u) ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_CONST(uint32_t)0x02;
3725 if (match == TOKCONSTSYMSTR16u) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04;
3726 sptr[0] = stream;
3727 sptr[1] = lbm_enc_u(0);
3728 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3729 ctx->app_cont = true1;
3730 } return;
3731 default:
3732 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3733 }
3734 sptr[0] = do_next;
3735 sptr[1] = stream;
3736 lbm_value *rptr = stack_reserve(ctx, 2);
3737 rptr[0] = lbm_enc_u(0);
3738 rptr[1] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3739 ctx->app_cont = true1;
3740 return;
3741 } else if (n < 0) goto retry_token;
3742
3743 /*
3744 * STRING
3745 */
3746 n = tok_string(chan, &string_len);
3747 if (n >= 2) {
3748 lbm_channel_drop(chan, (unsigned int)n);
3749 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3750 gc();
3751 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3752 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3753 return; // dead return but static analysis does not know that.
3754 }
3755 }
3756 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(res);
3757 char *data = (char*)arr->data;
3758 memset(data,0, string_len + 1);
3759 memcpy(data, tokpar_sym_str, string_len);
3760 lbm_stack_drop(&ctx->K, 2);
3761 ctx->r = res;
3762 ctx->app_cont = true1;
3763 return;
3764 } else if (n < 0) goto retry_token;
3765
3766 /*
3767 * FLOAT
3768 */
3769 token_float f_val;
3770 n = tok_double(chan, &f_val);
3771 if (n > 0) {
3772 lbm_channel_drop(chan, (unsigned int) n);
3773 switch(f_val.type) {
3774 case TOKTYPEF32107u:
3775 WITH_GC(res, lbm_enc_float((float)f_val.value))(res) = (lbm_enc_float((float)f_val.value)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (lbm_enc_float((float)f_val.value));
if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
3776 break;
3777 case TOKTYPEF64108u:
3778 res = lbm_enc_double(f_val.value);
3779 break;
3780 default:
3781 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3782 }
3783 lbm_stack_drop(&ctx->K, 2);
3784 ctx->r = res;
3785 ctx->app_cont = true1;
3786 return;
3787 } else if (n < 0) goto retry_token;
3788
3789 /*
3790 * INTEGER
3791 */
3792 token_int int_result;
3793 n = tok_integer(chan, &int_result);
3794 if (n > 0) {
3795 lbm_channel_drop(chan, (unsigned int)n);
3796 switch(int_result.type) {
3797 case TOKTYPEBYTE100u:
3798 res = lbm_enc_char((uint8_t)(int_result.negative ? -int_result.value : int_result.value));
3799 break;
3800 case TOKTYPEI101u:
3801 res = lbm_enc_i((lbm_int)(int_result.negative ? -int_result.value : int_result.value));
3802 break;
3803 case TOKTYPEU102u:
3804 res = lbm_enc_u((lbm_uint)(int_result.negative ? -int_result.value : int_result.value));
3805 break;
3806 case TOKTYPEI32103u:
3807 WITH_GC(res, lbm_enc_i32((int32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i32((int32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i32((int32_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3808 break;
3809 case TOKTYPEU32104u:
3810 WITH_GC(res,lbm_enc_u32((uint32_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u32((uint32_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u32((uint32_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3811 break;
3812 case TOKTYPEI64105u:
3813 WITH_GC(res,lbm_enc_i64((int64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_i64((int64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_i64((int64_t)(int_result.negative ?
-int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3814 break;
3815 case TOKTYPEU64106u:
3816 WITH_GC(res,lbm_enc_u64((uint64_t)(int_result.negative ? -int_result.value : int_result.value)))(res) = (lbm_enc_u64((uint64_t)(int_result.negative ? -int_result
.value : int_result.value))); if (lbm_is_symbol_merror((res))
) { gc(); (res) = (lbm_enc_u64((uint64_t)(int_result.negative
? -int_result.value : int_result.value))); if (lbm_is_symbol_merror
((res))) { error_ctx((((0x23) << 4) | 0x00000000u)); } };
3817 break;
3818 default:
3819 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3820 }
3821 lbm_stack_drop(&ctx->K, 2);
3822 ctx->r = res;
3823 ctx->app_cont = true1;
3824 return;
3825 } else if (n < 0) goto retry_token;
3826
3827 /*
3828 * SYMBOL
3829 */
3830 n = tok_symbol(chan);
3831 if (n > 0) {
3832 lbm_channel_drop(chan, (unsigned int) n);
3833 lbm_uint symbol_id;
3834 if (lbm_get_symbol_by_name(tokpar_sym_str, &symbol_id)) {
3835 res = lbm_enc_sym(symbol_id);
3836 } else {
3837 int r = 0;
3838 if (n > 4 &&
3839 tokpar_sym_str[0] == 'e' &&
3840 tokpar_sym_str[1] == 'x' &&
3841 tokpar_sym_str[2] == 't' &&
3842 tokpar_sym_str[3] == '-') {
3843 lbm_uint ext_id;
3844 lbm_uint ext_name_len = (lbm_uint)n + 1;
3845 char *ext_name = lbm_malloc(ext_name_len);
3846 if (!ext_name) {
3847 gc();
3848 ext_name = lbm_malloc(ext_name_len);
3849 }
3850 if (ext_name) {
3851 memcpy(ext_name, tokpar_sym_str, ext_name_len);
3852 r = lbm_add_extension(ext_name, lbm_extensions_default);
3853 if (!lbm_lookup_extension_id(ext_name, &ext_id)) {
3854 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3855 }
3856 symbol_id = ext_id;
3857 } else {
3858 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3859 }
3860 } else {
3861 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS(uint32_t)0x04 &&
3862 ctx->flags & EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ(uint32_t)0x08) {
3863 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id, true1); //flash
3864 if (!r) {
3865 lbm_set_error_reason((char*)lbm_error_str_flash_error);
3866 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3867 }
3868 } else {
3869 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3870 if (!r) {
3871 gc();
3872 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false0); //ram
3873 }
3874 }
3875 }
3876 if (r) {
3877 res = lbm_enc_sym(symbol_id);
3878 } else {
3879 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3880 }
3881 }
3882 lbm_stack_drop(&ctx->K, 2);
3883 ctx->r = res;
3884 ctx->app_cont = true1;
3885 return;
3886 } else if (n == TOKENIZER_NEED_MORE-1) {
3887 goto retry_token;
3888 } else if (n <= TOKENIZER_STRING_ERROR-2) {
3889 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3890 }
3891
3892 /*
3893 * CHAR
3894 */
3895 char c_val;
3896 n = tok_char(chan, &c_val);
3897 if(n > 0) {
3898 lbm_channel_drop(chan,(unsigned int) n);
3899 lbm_stack_drop(&ctx->K, 2);
3900 ctx->r = lbm_enc_char((uint8_t)c_val);
3901 ctx->app_cont = true1;
3902 return;
3903 }else if (n < 0) goto retry_token;
3904
3905 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3906
3907 retry_token:
3908 if (n == TOKENIZER_NEED_MORE-1) {
3909 sptr[0] = stream;
3910 sptr[1] = lbm_enc_u(0);
3911 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3912 yield_ctx(EVAL_CPS_MIN_SLEEP200);
3913 return;
3914 }
3915 read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3916}
3917
3918static void cont_read_start_array(eval_context_t *ctx) {
3919 lbm_value *sptr = get_stack_ptr(ctx, 1);
3920 lbm_value stream = sptr[0];
3921
3922 lbm_char_channel_t *str = lbm_dec_channel(stream);
3923 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
3924 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3925 }
3926
3927 lbm_uint num_free = lbm_memory_longest_free();
3928 lbm_uint initial_size = (lbm_uint)((float)num_free * 0.9);
3929 if (initial_size == 0) {
3930 gc();
3931 num_free = lbm_memory_longest_free();
3932 initial_size = (lbm_uint)((float)num_free * 0.9);
3933 if (initial_size == 0) {
3934 lbm_channel_reader_close(str);
3935 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3936 }
3937 }
3938
3939 if (lbm_is_number(ctx->r)) {
3940 lbm_value array;
3941 initial_size = sizeof(lbm_uint) * initial_size;
3942
3943 if (!lbm_heap_allocate_array(&array, initial_size)) {
3944 lbm_set_error_reason("Out of memory while reading.");
3945 lbm_channel_reader_close(str);
3946 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
3947 // NOTE: If array is not created evaluation ends here.
3948 // Static analysis seems unaware.
3949 }
3950
3951 sptr[0] = array;
3952 lbm_value *rptr = stack_reserve(ctx, 4);
3953 rptr[0] = lbm_enc_u(initial_size);
3954 rptr[1] = lbm_enc_u(0);
3955 rptr[2] = stream;
3956 rptr[3] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3957 ctx->app_cont = true1;
3958 } else {
3959 lbm_channel_reader_close(str);
3960 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3961 }
3962}
3963
3964static void cont_read_append_array(eval_context_t *ctx) {
3965 lbm_uint *sptr = get_stack_ptr(ctx, 4);
3966
3967 lbm_value array = sptr[0];
3968 lbm_value size = lbm_dec_as_u32(sptr[1]);
3969 lbm_value ix = lbm_dec_as_u32(sptr[2]);
3970 lbm_value stream = sptr[3];
3971
3972 if (ix >= (size - 1)) {
3973 error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
3974 }
3975
3976 // get_car can return nil. Whose value is 0!
3977 // So static Analysis is right about this being a potential NULL pointer.
3978 // However, if the array was created correcly to begin with, it should be fine.
3979 lbm_value arr_car = get_car(array);
3980 lbm_array_header_t *arr = (lbm_array_header_t*)arr_car;
3981
3982 if (lbm_is_number(ctx->r)) {
3983 ((uint8_t*)arr->data)[ix] = (uint8_t)lbm_dec_as_u32(ctx->r);
3984
3985 sptr[2] = lbm_enc_u(ix + 1);
3986 lbm_value *rptr = stack_reserve(ctx, 4);
3987 rptr[0] = READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u);
3988 rptr[1] = stream;
3989 rptr[2] = lbm_enc_u(0);
3990 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
3991 ctx->app_cont = true1;
3992 } else if (lbm_is_symbol(ctx->r) && ctx->r == ENC_SYM_CLOSEBRACK(((0x81) << 4) | 0x00000000u)) {
3993 lbm_uint array_size = ix / sizeof(lbm_uint);
3994
3995 if (ix % sizeof(lbm_uint) != 0) {
3996 array_size = array_size + 1;
3997 }
3998 lbm_memory_shrink((lbm_uint*)arr->data, array_size);
3999 arr->size = ix;
4000 lbm_stack_drop(&ctx->K, 4);
4001 ctx->r = array;
4002 ctx->app_cont = true1;
4003 } else {
4004 error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u));
4005 }
4006}
4007
4008static void cont_read_append_continue(eval_context_t *ctx) {
4009 lbm_value *sptr = get_stack_ptr(ctx, 3);
4010
4011 lbm_value first_cell = sptr[0];
4012 lbm_value last_cell = sptr[1];
4013 lbm_value stream = sptr[2];
4014
4015 lbm_char_channel_t *str = lbm_dec_channel(stream);
4016 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4017 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4018 }
4019
4020 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4021
4022 switch(ctx->r) {
4023 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4024 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4025 lbm_set_cdr(last_cell, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); // terminate the list
4026 ctx->r = first_cell;
4027 } else {
4028 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4029 }
4030 lbm_stack_drop(&ctx->K, 3);
4031 /* Skip reading another token and apply the continuation */
4032 ctx->app_cont = true1;
4033 return;
4034 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4035 lbm_value *rptr = stack_reserve(ctx, 4);
4036 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4037 rptr[1] = stream;
4038 rptr[2] = lbm_enc_u(0);
4039 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4040 ctx->app_cont = true1;
4041 } return;
4042 }
4043 }
4044 lbm_value new_cell = cons_with_gc(ctx->r, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4045 if (lbm_is_symbol_merror(new_cell)) {
4046 lbm_channel_reader_close(str);
4047 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4048 return;
4049 }
4050 if (lbm_type_of(last_cell) == LBM_TYPE_CONS0x10000000u) {
4051 lbm_set_cdr(last_cell, new_cell);
4052 last_cell = new_cell;
4053 } else {
4054 first_cell = last_cell = new_cell;
4055 }
4056 sptr[0] = first_cell;
4057 sptr[1] = last_cell;
4058 sptr[2] = stream; // unchanged.
4059 lbm_value *rptr = stack_reserve(ctx, 4);
4060 rptr[0] = READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u);
4061 rptr[1] = stream;
4062 rptr[2] = lbm_enc_u(0);
4063 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4064 ctx->app_cont = true1;
4065}
4066
4067static void cont_read_eval_continue(eval_context_t *ctx) {
4068 lbm_value env;
4069 lbm_value stream;
4070 lbm_pop_2(&ctx->K, &env, &stream);
4071
4072 lbm_char_channel_t *str = lbm_dec_channel(stream);
4073 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4074 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4075 }
4076
4077 ctx->row1 = (lbm_int)str->row(str);
4078
4079 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u) {
4080
4081 switch(ctx->r) {
4082 case ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u):
4083 ctx->app_cont = true1;
4084 return;
4085 case ENC_SYM_DOT(((0x76) << 4) | 0x00000000u): {
4086 // This case is a bit mysterious.
4087 // A dot, may in reality be an error in this location.
4088 lbm_value *rptr = stack_reserve(ctx, 4);
4089 rptr[0] = READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u);
4090 rptr[1] = stream;
4091 rptr[2] = lbm_enc_u(0);
4092 rptr[3] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4093 ctx->app_cont = true1;
4094 } return;
4095 }
4096 }
4097
4098 lbm_value *rptr = stack_reserve(ctx, 6);
4099 rptr[0] = stream;
4100 rptr[1] = env;
4101 rptr[2] = READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u);
4102 rptr[3] = stream;
4103 rptr[4] = lbm_enc_u(1);
4104 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4105 rptr[6] = lbm_enc_u(ctx->flags);
4106 rptr[7] = POP_READER_FLAGS(((47) << 2) | 0xF8000001u);
4107 ctx->curr_env = env;
4108 ctx->curr_exp = ctx->r;
4109}
4110
4111static void cont_read_expect_closepar(eval_context_t *ctx) {
4112 lbm_value res;
4113 lbm_value stream;
4114
4115 lbm_pop_2(&ctx->K, &res, &stream);
4116
4117 lbm_char_channel_t *str = lbm_dec_channel(stream);
4118 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4119 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4120 }
4121
4122 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4123 ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u)) {
4124 ctx->r = res;
4125 ctx->app_cont = true1;
4126 } else {
4127 lbm_channel_reader_close(str);
4128 lbm_set_error_reason((char*)lbm_error_str_parse_close);
4129 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4130 }
4131}
4132
4133static void cont_read_dot_terminate(eval_context_t *ctx) {
4134 lbm_value *sptr = get_stack_ptr(ctx, 3);
4135
4136 lbm_value first_cell = sptr[0];
4137 lbm_value last_cell = sptr[1];
4138 lbm_value stream = sptr[2];
4139
4140 lbm_char_channel_t *str = lbm_dec_channel(stream);
4141 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4142 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4143 }
4144
4145 lbm_stack_drop(&ctx->K ,3);
4146
4147 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL0x00000000u &&
4148 (ctx->r == ENC_SYM_CLOSEPAR(((0x71) << 4) | 0x00000000u) ||
4149 ctx->r == ENC_SYM_DOT(((0x76) << 4) | 0x00000000u))) {
4150 lbm_channel_reader_close(str);
4151 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4152 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4153 } else {
4154 if (lbm_is_cons(last_cell)) {
4155 lbm_set_cdr(last_cell, ctx->r);
4156 ctx->r = first_cell;
4157 lbm_value *rptr = stack_reserve(ctx, 6);
4158 rptr[0] = stream;
4159 rptr[1] = ctx->r;
4160 rptr[2] = READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u);
4161 rptr[3] = stream;
4162 rptr[4] = lbm_enc_u(0);
4163 rptr[5] = READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u);
4164 ctx->app_cont = true1;
4165 } else {
4166 lbm_channel_reader_close(str);
4167 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4168 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4169 }
4170 }
4171}
4172
4173static void cont_read_done(eval_context_t *ctx) {
4174 lbm_value stream;
4175 lbm_value f_val;
4176 lbm_pop_2(&ctx->K, &stream ,&f_val);
4177
4178 uint32_t flags = lbm_dec_as_u32(f_val);
4179 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4180 ctx->flags |= (flags & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4181
4182 lbm_char_channel_t *str = lbm_dec_channel(stream);
4183 if (str == NULL((void*)0) || str->state == NULL((void*)0)) {
4184 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4185 }
4186
4187 lbm_channel_reader_close(str);
4188 if (lbm_is_symbol(ctx->r)) {
4189 lbm_uint sym_val = lbm_dec_sym(ctx->r);
4190 if (sym_val >= TOKENIZER_SYMBOLS_START0x70 &&
4191 sym_val <= TOKENIZER_SYMBOLS_END0x85) {
4192 read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4193 }
4194 }
4195
4196 ctx->row0 = -1;
4197 ctx->row1 = -1;
4198 ctx->app_cont = true1;
4199}
4200
4201static void cont_read_quote_result(eval_context_t *ctx) {
4202 lbm_value cell;
4203 WITH_GC(cell, lbm_heap_allocate_list_init(2,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4204 ENC_SYM_QUOTE,(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
}
4205 ctx->r))(cell) = (lbm_heap_allocate_list_init(2, (((0x100) << 4
) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror((cell
))) { gc(); (cell) = (lbm_heap_allocate_list_init(2, (((0x100
) << 4) | 0x00000000u), ctx->r)); if (lbm_is_symbol_merror
((cell))) { error_ctx((((0x23) << 4) | 0x00000000u)); }
};
4206 ctx->r = cell;
4207 ctx->app_cont = true1;
4208}
4209
4210static void cont_read_commaat_result(eval_context_t *ctx) {
4211 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4212 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4213 ctx->r = cell1;
4214 ctx->app_cont = true1;
4215}
4216
4217static void cont_read_comma_result(eval_context_t *ctx) {
4218 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u),ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4219 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u), cell2, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4220 ctx->r = cell1;
4221 ctx->app_cont = true1;
4222}
4223
4224static void cont_application_start(eval_context_t *ctx) {
4225
4226 /* sptr[0] = env
4227 * sptr[1] = args
4228 * ctx->r = function
4229 */
4230
4231 if (lbm_is_symbol(ctx->r)) {
4232 stack_reserve(ctx,1)[0] = lbm_enc_u(0);
4233 cont_application_args(ctx);
4234 } else if (lbm_is_cons(ctx->r)) {
4235 lbm_uint *sptr = get_stack_ptr(ctx, 2);
4236 lbm_value args = (lbm_value)sptr[1];
4237 switch (get_car(ctx->r)) {
4238 case ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u): {
4239 lbm_value cl[3];
4240 extract_n(get_cdr(ctx->r), cl, 3);
4241 lbm_value arg_env = (lbm_value)sptr[0];
4242 lbm_value arg0, arg_rest;
4243 get_car_and_cdr(args, &arg0, &arg_rest);
4244 sptr[1] = cl[CLO_BODY1];
4245 bool_Bool a_nil = lbm_is_symbol_nil(args);
4246 bool_Bool p_nil = lbm_is_symbol_nil(cl[CLO_PARAMS0]);
4247 lbm_value *reserved = stack_reserve(ctx, 4);
4248
4249 if (!a_nil && !p_nil) {
4250 reserved[0] = cl[CLO_ENV2];
4251 reserved[1] = cl[CLO_PARAMS0];
4252 reserved[2] = arg_rest;
4253 reserved[3] = CLOSURE_ARGS(((13) << 2) | 0xF8000001u);
4254 ctx->curr_exp = arg0;
4255 ctx->curr_env = arg_env;
4256 } else if (a_nil && p_nil) {
4257 // No params, No args
4258 lbm_stack_drop(&ctx->K, 6);
4259 ctx->curr_exp = cl[CLO_BODY1];
4260 ctx->curr_env = cl[CLO_ENV2];
4261 } else if (p_nil) {
4262 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS(((0x30015) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), cl[CLO_ENV2]);
4263 reserved[0] = rest_binder;
4264 reserved[1] = get_cdr(args);
4265 reserved[2] = get_car(rest_binder);
4266 reserved[3] = CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u);
4267 ctx->curr_exp = get_car(args);
4268 ctx->curr_env = arg_env;
4269 } else {
4270 lbm_set_error_reason((char*)lbm_error_str_num_args);
4271 error_at_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u), ctx->r);
4272 }
4273 } break;
4274 case ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u):{
4275 /* Continuation created using call-cc.
4276 * ((SYM_CONT . cont-array) arg0 )
4277 */
4278 lbm_value c = get_cdr(ctx->r); /* should be the continuation array*/
4279
4280 if (!lbm_is_lisp_array_r(c)) {
4281 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4282 }
4283
4284 lbm_uint arg_count = lbm_list_length(args);
4285 lbm_value arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4286 switch (arg_count) {
4287 case 0:
4288 arg = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4289 break;
4290 case 1:
4291 arg = get_car(args);
4292 break;
4293 default:
4294 lbm_set_error_reason((char*)lbm_error_str_num_args);
4295 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4296 }
4297 lbm_stack_clear(&ctx->K);
4298
4299 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(c);
4300
4301 ctx->K.sp = arr->size / sizeof(lbm_uint);
4302 memcpy(ctx->K.data, arr->data, arr->size);
4303
4304 ctx->curr_exp = arg;
4305 break;
4306 }
4307 case ENC_SYM_MACRO(((0x10D) << 4) | 0x00000000u):{
4308 /*
4309 * Perform macro expansion.
4310 * Macro expansion is really just evaluation in an
4311 * environment augmented with the unevaluated expressions passed
4312 * as arguments.
4313 */
4314 lbm_value env = (lbm_value)sptr[0];
4315
4316 lbm_value curr_param = get_cadr(ctx->r);
4317 lbm_value curr_arg = args;
4318 lbm_value expand_env = env;
4319 while (lbm_is_cons(curr_param) &&
4320 lbm_is_cons(curr_arg)) {
4321 lbm_value car_curr_param, cdr_curr_param;
4322 lbm_value car_curr_arg, cdr_curr_arg;
4323 get_car_and_cdr(curr_param, &car_curr_param, &cdr_curr_param);
4324 get_car_and_cdr(curr_arg, &car_curr_arg, &cdr_curr_arg);
4325
4326 lbm_value entry = cons_with_gc(car_curr_param, car_curr_arg, expand_env);
4327 lbm_value aug_env = cons_with_gc(entry, expand_env,ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4328 expand_env = aug_env;
4329
4330 curr_param = cdr_curr_param;
4331 curr_arg = cdr_curr_arg;
4332 }
4333 /* Two rounds of evaluation is performed.
4334 * First to instantiate the arguments into the macro body.
4335 * Second to evaluate the resulting program.
4336 */
4337 sptr[1] = EVAL_R(((11) << 2) | 0xF8000001u);
4338 lbm_value exp = get_cadr(get_cdr(ctx->r));
4339 ctx->curr_exp = exp;
4340 ctx->curr_env = expand_env;
4341 } break;
4342 default:
4343 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4344 }
4345 } else {
4346 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4347 }
4348}
4349
4350static void cont_eval_r(eval_context_t* ctx) {
4351 lbm_value env;
4352 lbm_pop(&ctx->K, &env);
4353 ctx->curr_exp = ctx->r;
4354 ctx->curr_env = env;
4355}
4356
4357static void cont_progn_var(eval_context_t* ctx) {
4358
4359 lbm_value key;
4360 lbm_value env;
4361
4362 lbm_pop_2(&ctx->K, &key, &env);
4363
4364 if (fill_binding_location(key, ctx->r, env) < 0) {
4365 lbm_set_error_reason("Incorrect type of name/key in let-binding");
4366 error_at_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u), key);
4367 }
4368
4369 ctx->app_cont = true1;
4370}
4371
4372static void cont_setq(eval_context_t *ctx) {
4373 lbm_value sym;
4374 lbm_value env;
4375 lbm_pop_2(&ctx->K, &sym, &env);
4376 lbm_value res;
4377 WITH_GC(res, perform_setvar(sym, ctx->r, env))(res) = (perform_setvar(sym, ctx->r, env)); if (lbm_is_symbol_merror
((res))) { gc(); (res) = (perform_setvar(sym, ctx->r, env)
); if (lbm_is_symbol_merror((res))) { error_ctx((((0x23) <<
4) | 0x00000000u)); } };
4378 ctx->r = res;
4379 ctx->app_cont = true1;
4380}
4381
4382lbm_flash_status request_flash_storage_cell(lbm_value val, lbm_value *res) {
4383
4384 lbm_value flash_cell;
4385 lbm_flash_status s = lbm_allocate_const_cell(&flash_cell);
4386 if (s != LBM_FLASH_WRITE_OK)
4387 return s;
4388 lbm_value new_val = val;
4389 new_val &= ~LBM_PTR_VAL_MASK0x03FFFFFCu; // clear the value part of the ptr
4390 new_val |= (flash_cell & LBM_PTR_VAL_MASK0x03FFFFFCu);
4391 new_val |= LBM_PTR_TO_CONSTANT_BIT0x04000000u;
4392 *res = new_val;
4393 return s;
4394}
4395
4396static void cont_move_to_flash(eval_context_t *ctx) {
4397
4398 lbm_value args;
4399 lbm_pop(&ctx->K, &args);
4400
4401 if (lbm_is_symbol_nil(args)) {
4402 // Done looping over arguments. return true.
4403 ctx->r = ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u);
4404 ctx->app_cont = true1;
4405 return;
4406 }
4407
4408 lbm_value first_arg, rest;
4409 get_car_and_cdr(args, &first_arg, &rest);
4410
4411 lbm_value val;
4412 if (lbm_is_symbol(first_arg) && lbm_global_env_lookup(&val, first_arg)) {
4413 // Prepare to copy the rest of the arguments when done with first.
4414 lbm_value *rptr = stack_reserve(ctx, 2);
4415 rptr[0] = rest;
4416 rptr[1] = MOVE_TO_FLASH(((31) << 2) | 0xF8000001u);
4417 if (lbm_is_ptr(val) &&
4418 (!(val & LBM_PTR_TO_CONSTANT_BIT0x04000000u))) {
4419 lbm_value * rptr1 = stack_reserve(ctx, 3);
4420 rptr1[0] = first_arg;
4421 rptr1[1] = SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u);
4422 rptr1[2] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4423 ctx->r = val;
4424 }
4425 ctx->app_cont = true1;
4426 return;
4427 }
4428 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4429}
4430
4431static void cont_move_val_to_flash_dispatch(eval_context_t *ctx) {
4432
4433 lbm_value val = ctx->r;
4434
4435 if (lbm_is_cons(val)) {
4436 lbm_value *rptr = stack_reserve(ctx, 5);
4437 rptr[0] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // fst cell of list
4438 rptr[1] = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // last cell of list
4439 rptr[2] = get_cdr(val);
4440 rptr[3] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4441 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4442 ctx->r = get_car(val);
4443 ctx->app_cont = true1;
4444 return;
4445 }
4446
4447 if (lbm_is_ptr(val) && (val & LBM_PTR_TO_CONSTANT_BIT0x04000000u)) {
4448 ctx->r = val;
4449 ctx->app_cont = true1;
4450 return;
4451 }
4452
4453 if (lbm_is_ptr(val)) {
4454 lbm_cons_t *ref = lbm_ref_cell(val);
4455 if (lbm_type_of(ref->cdr) == LBM_TYPE_SYMBOL0x00000000u) {
4456 switch (ref->cdr) {
4457 case ENC_SYM_RAW_I_TYPE(((0x31) << 4) | 0x00000000u): /* fall through */
4458 case ENC_SYM_RAW_U_TYPE(((0x32) << 4) | 0x00000000u):
4459 case ENC_SYM_RAW_F_TYPE(((0x33) << 4) | 0x00000000u): {
4460 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4461 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4462 handle_flash_status(write_const_car(flash_cell, ref->car));
4463 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4464 ctx->r = flash_cell;
4465 } break;
4466 case ENC_SYM_IND_I_TYPE(((0x34) << 4) | 0x00000000u): /* fall through */
4467 case ENC_SYM_IND_U_TYPE(((0x35) << 4) | 0x00000000u):
4468 case ENC_SYM_IND_F_TYPE(((0x36) << 4) | 0x00000000u): {
4469#ifndef LBM64
4470 /* 64 bit values are in lbm mem on 32bit platforms. */
4471 lbm_uint *lbm_mem_ptr = (lbm_uint*)ref->car;
4472 lbm_uint flash_ptr;
4473
4474 handle_flash_status(lbm_write_const_raw(lbm_mem_ptr, 2, &flash_ptr));
4475 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4476 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4477 handle_flash_status(write_const_car(flash_cell, flash_ptr));
4478 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4479 ctx->r = flash_cell;
4480#else
4481 // There are no indirect types in LBM64
4482 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4483#endif
4484 } break;
4485 case ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u): {
4486 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4487 lbm_uint size = arr->size / sizeof(lbm_uint);
4488 lbm_uint flash_addr;
4489 lbm_value *arrdata = (lbm_value *)arr->data;
4490 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4491 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4492 handle_flash_status(lbm_allocate_const_raw(size, &flash_addr));
4493 lift_array_flash(flash_cell,
4494 false0,
4495 (char *)flash_addr,
4496 arr->size);
4497 // Move array contents to flash recursively
4498 lbm_value *rptr = stack_reserve(ctx, 5);
4499 rptr[0] = flash_cell;
4500 rptr[1] = lbm_enc_u(0);
4501 rptr[2] = val;
4502 rptr[3] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4503 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4504 ctx->r = arrdata[0];
4505 ctx->app_cont = true1;
4506 return;
4507 }
4508 case ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u): {
4509 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4510 // arbitrary address: flash_arr.
4511 lbm_uint flash_arr;
4512 handle_flash_status(lbm_write_const_array_padded((uint8_t*)arr->data, arr->size, &flash_arr));
4513 lbm_value flash_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4514 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4515 lift_array_flash(flash_cell,
4516 true1,
4517 (char *)flash_arr,
4518 arr->size);
4519 ctx->r = flash_cell;
4520 } break;
4521 case ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u): /* fall through */
4522 case ENC_SYM_CUSTOM_TYPE(((0x38) << 4) | 0x00000000u):
4523 lbm_set_error_reason((char *)lbm_error_str_flash_not_possible);
4524 error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u));
4525 }
4526 } else {
4527 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4528 }
4529 ctx->app_cont = true1;
4530 return;
4531 }
4532 ctx->r = val;
4533 ctx->app_cont = true1;
4534}
4535
4536static void cont_move_list_to_flash(eval_context_t *ctx) {
4537
4538 // ctx->r holds the value that should go in car
4539
4540 lbm_value *sptr = get_stack_ptr(ctx, 3);
4541
4542 lbm_value fst = sptr[0];
4543 lbm_value lst = sptr[1];
4544 lbm_value val = sptr[2];
4545
4546
4547 lbm_value new_lst = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4548 // Allocate element ptr storage after storing the element to flash.
4549 handle_flash_status(request_flash_storage_cell(lbm_enc_cons_ptr(LBM_PTR_NULL(0x03FFFFFCu >> 2)), &new_lst));
4550
4551 if (lbm_is_symbol_nil(fst)) {
4552 lst = new_lst;
4553 fst = new_lst;
4554 handle_flash_status(write_const_car(lst, ctx->r));
4555 } else {
4556 handle_flash_status(write_const_cdr(lst, new_lst)); // low before high
4557 handle_flash_status(write_const_car(new_lst, ctx->r));
4558 lst = new_lst;
4559 }
4560
4561 if (lbm_is_cons(val)) {
4562 sptr[0] = fst;
4563 sptr[1] = lst;//rest_cell;
4564 sptr[2] = get_cdr(val);
4565 lbm_value *rptr = stack_reserve(ctx, 2);
4566 rptr[0] = MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u);
4567 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4568 ctx->r = get_car(val);
4569 } else {
4570 sptr[0] = fst;
4571 sptr[1] = lst;
4572 sptr[2] = CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u);
4573 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4574 ctx->r = val;
4575 }
4576 ctx->app_cont = true1;
4577}
4578
4579static void cont_close_list_in_flash(eval_context_t *ctx) {
4580 lbm_value fst;
4581 lbm_value lst;
4582 lbm_pop_2(&ctx->K, &lst, &fst);
4583 lbm_value val = ctx->r;
4584 handle_flash_status(write_const_cdr(lst, val));
4585 ctx->r = fst;
4586 ctx->app_cont = true1;
4587}
4588
4589static void cont_move_array_elts_to_flash(eval_context_t *ctx) {
4590 lbm_value *sptr = get_stack_ptr(ctx, 3);
4591 // sptr[2] = source array in RAM
4592 // sptr[1] = current index
4593 // sptr[0] = target array in flash
4594 lbm_array_header_t *src_arr = (lbm_array_header_t*)get_car(sptr[2]);
4595 lbm_uint size = src_arr->size / sizeof(lbm_uint);
4596 lbm_value *srcdata = (lbm_value *)src_arr->data;
4597
4598 lbm_array_header_t *tgt_arr = (lbm_array_header_t*)get_car(sptr[0]);
4599 lbm_uint *tgtdata = (lbm_value *)tgt_arr->data;
4600 lbm_uint ix = lbm_dec_as_u32(sptr[1]);
4601 handle_flash_status(lbm_const_write(&tgtdata[ix], ctx->r));
4602 if (ix >= size-1) {
4603 ctx->r = sptr[0];
4604 lbm_stack_drop(&ctx->K, 3);
4605 ctx->app_cont = true1;
4606 return;
4607 }
4608 sptr[1] = lbm_enc_u(ix + 1);
4609 lbm_value *rptr = stack_reserve(ctx, 2);
4610 rptr[0] = MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u);
4611 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u);
4612 ctx->r = srcdata[ix+1];
4613 ctx->app_cont = true1;
4614 return;
4615}
4616
4617static void cont_qq_expand_start(eval_context_t *ctx) {
4618 lbm_value *rptr = stack_reserve(ctx, 2);
4619 rptr[0] = ctx->r;
4620 rptr[1] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4621 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4622 ctx->app_cont = true1;
4623}
4624
4625lbm_value quote_it(lbm_value qquoted) {
4626 if (lbm_is_symbol(qquoted) &&
4627 lbm_is_special(qquoted)) return qquoted;
4628
4629 lbm_value val = cons_with_gc(qquoted, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4630 return cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4631}
4632
4633bool_Bool is_append(lbm_value a) {
4634 return (lbm_is_cons(a) &&
4635 lbm_is_symbol(get_car(a)) &&
4636 (get_car(a) == ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u)));
4637}
4638
4639lbm_value append(lbm_value front, lbm_value back) {
4640 if (lbm_is_symbol_nil(front)) return back;
4641 if (lbm_is_symbol_nil(back)) return front;
4642
4643 if (lbm_is_quoted_list(front) &&
4644 lbm_is_quoted_list(back)) {
4645 lbm_value f = get_cadr(front);
4646 lbm_value b = get_cadr(back);
4647 return quote_it(lbm_list_append(f, b));
4648 }
4649
4650 if (is_append(back) &&
4651 lbm_is_quoted_list(get_cadr(back)) &&
4652 lbm_is_quoted_list(front)) {
4653 lbm_value ql = get_cadr(back);
4654 lbm_value f = get_cadr(front);
4655 lbm_value b = get_cadr(ql);
4656
4657 lbm_value v = lbm_list_append(f, b);
4658 lbm_set_car(get_cdr(ql), v);
4659 return back;
4660 }
4661
4662 if (is_append(back)) {
4663 back = get_cdr(back);
4664 lbm_value new = cons_with_gc(front, back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4665 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), new, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4666 }
4667
4668 lbm_value t0, t1;
4669
4670 t0 = cons_with_gc(back, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), front);
4671 t1 = cons_with_gc(front, t0, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4672 return cons_with_gc(ENC_SYM_APPEND(((0x20015) << 4) | 0x00000000u), t1, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4673}
4674
4675/* Bawden's qq-expand implementation
4676(define (qq-expand x)
4677 (cond ((tag-comma? x)
4678 (tag-data x))
4679 ((tag-comma-atsign? x)
4680 (error "Illegal"))
4681 ((tag-backquote? x)
4682 (qq-expand
4683 (qq-expand (tag-data x))))
4684 ((pair? x)
4685 `(append
4686 ,(qq-expand-list (car x))
4687 ,(qq-expand (cdr x))))
4688 (else `',x)))
4689 */
4690static void cont_qq_expand(eval_context_t *ctx) {
4691 lbm_value qquoted;
4692 lbm_pop(&ctx->K, &qquoted);
4693
4694 switch(lbm_type_of(qquoted)) {
4695 case LBM_TYPE_CONS0x10000000u: {
4696 lbm_value car_val = get_car(qquoted);
4697 lbm_value cdr_val = get_cdr(qquoted);
4698 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4699 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4700 ctx->r = append(ctx->r, get_car(cdr_val));
4701 ctx->app_cont = true1;
4702 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4703 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4704 error_ctx(ENC_SYM_RERROR(((0x20) << 4) | 0x00000000u));
4705 } else {
4706 lbm_value *rptr = stack_reserve(ctx, 6);
4707 rptr[0] = ctx->r;
4708 rptr[1] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4709 rptr[2] = cdr_val;
4710 rptr[3] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4711 rptr[4] = car_val;
4712 rptr[5] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4713 ctx->app_cont = true1;
4714 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4715 }
4716
4717 } break;
4718 default: {
4719 lbm_value res = quote_it(qquoted);
4720 ctx->r = append(ctx->r, res);
4721 ctx->app_cont = true1;
4722 }
4723 }
4724}
4725
4726static void cont_qq_append(eval_context_t *ctx) {
4727 lbm_value head;
4728 lbm_pop(&ctx->K, &head);
4729 ctx->r = append(head, ctx->r);
4730 ctx->app_cont = true1;
4731}
4732
4733/* Bawden's qq-expand-list implementation
4734(define (qq-expand-list x)
4735 (cond ((tag-comma? x)
4736 `(list ,(tag-data x)))
4737 ((tag-comma-atsign? x)
4738 (tag-data x))
4739 ((tag-backquote? x)
4740 (qq-expand-list
4741 (qq-expand (tag-data x))))
4742 ((pair? x)
4743 `(list
4744 (append
4745 ,(qq-expand-list (car x))
4746 ,(qq-expand (cdr x)))))
4747 (else `'(,x))))
4748*/
4749
4750static void cont_qq_expand_list(eval_context_t* ctx) {
4751 lbm_value l;
4752 lbm_pop(&ctx->K, &l);
4753
4754 ctx->app_cont = true1;
4755 switch(lbm_type_of(l)) {
4756 case LBM_TYPE_CONS0x10000000u: {
4757 lbm_value car_val = get_car(l);
4758 lbm_value cdr_val = get_cdr(l);
4759 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4760 car_val == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) {
4761 lbm_value tl = cons_with_gc(get_car(cdr_val), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4762 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4763 ctx->r = append(ctx->r, tmp);
4764 return;
4765 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL0x00000000u &&
4766 car_val == ENC_SYM_COMMAAT(((0x74) << 4) | 0x00000000u)) {
4767 ctx->r = get_car(cdr_val);
4768 return;
4769 } else {
4770 lbm_value *rptr = stack_reserve(ctx, 7);
4771 rptr[0] = QQ_LIST(((39) << 2) | 0xF8000001u);
4772 rptr[1] = ctx->r;
4773 rptr[2] = QQ_APPEND(((37) << 2) | 0xF8000001u);
4774 rptr[3] = cdr_val;
4775 rptr[4] = QQ_EXPAND(((36) << 2) | 0xF8000001u);
4776 rptr[5] = car_val;
4777 rptr[6] = QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u);
4778 ctx->r = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u);
4779 }
4780
4781 } break;
4782 default: {
4783 lbm_value a_list = cons_with_gc(l, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4784 lbm_value tl = cons_with_gc(a_list, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4785 lbm_value tmp = cons_with_gc(ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u), tl, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4786 ctx->r = append(ctx->r, tmp);
4787 }
4788 }
4789}
4790
4791static void cont_qq_list(eval_context_t *ctx) {
4792 lbm_value val = ctx->r;
4793 lbm_value apnd_app = cons_with_gc(val, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4794 lbm_value tmp = cons_with_gc(ENC_SYM_LIST(((0x20014) << 4) | 0x00000000u), apnd_app, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u));
4795 ctx->r = tmp;
4796 ctx->app_cont = true1;
4797}
4798
4799static void cont_kill(eval_context_t *ctx) {
4800 (void) ctx;
4801 finish_ctx();
4802}
4803
4804static void cont_pop_reader_flags(eval_context_t *ctx) {
4805 lbm_value flags;
4806 lbm_pop(&ctx->K, &flags);
4807 ctx->flags = ctx->flags & ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08);
4808 ctx->flags |= (lbm_dec_as_u32(flags) & EVAL_CPS_CONTEXT_READER_FLAGS_MASK((uint32_t)0x02 | (uint32_t)0x04 | (uint32_t)0x08));
4809 // r is unchanged.
4810 ctx->app_cont = true1;
4811}
4812
4813static void cont_exception_handler(eval_context_t *ctx) {
4814 lbm_value *sptr = pop_stack_ptr(ctx, 2);
4815 lbm_value retval = sptr[0];
4816 lbm_value flags = sptr[1];
4817 lbm_set_car(get_cdr(retval), ctx->r);
4818 ctx->flags = flags;
4819 ctx->r = retval;
4820 ctx->app_cont = true1;
4821}
4822
4823/*********************************************************/
4824/* Continuations table */
4825typedef void (*cont_fun)(eval_context_t *);
4826
4827static const cont_fun continuations[NUM_CONTINUATIONS49] =
4828 { advance_ctx, // CONT_DONE
4829 cont_set_global_env,
4830 cont_bind_to_key_rest,
4831 cont_if,
4832 cont_progn_rest,
4833 cont_application_args,
4834 cont_and,
4835 cont_or,
4836 cont_wait,
4837 cont_match,
4838 cont_application_start,
4839 cont_eval_r,
4840 cont_resume,
4841 cont_closure_application_args,
4842 cont_exit_atomic,
4843 cont_read_next_token,
4844 cont_read_append_continue,
4845 cont_read_eval_continue,
4846 cont_read_expect_closepar,
4847 cont_read_dot_terminate,
4848 cont_read_done,
4849 cont_read_quote_result,
4850 cont_read_commaat_result,
4851 cont_read_comma_result,
4852 cont_read_start_array,
4853 cont_read_append_array,
4854 cont_map,
4855 cont_match_guard,
4856 cont_terminate,
4857 cont_progn_var,
4858 cont_setq,
4859 cont_move_to_flash,
4860 cont_move_val_to_flash_dispatch,
4861 cont_move_list_to_flash,
4862 cont_close_list_in_flash,
4863 cont_qq_expand_start,
4864 cont_qq_expand,
4865 cont_qq_append,
4866 cont_qq_expand_list,
4867 cont_qq_list,
4868 cont_kill,
4869 cont_loop,
4870 cont_loop_condition,
4871 cont_merge_rest,
4872 cont_merge_layer,
4873 cont_closure_args_rest,
4874 cont_move_array_elts_to_flash,
4875 cont_pop_reader_flags,
4876 cont_exception_handler
4877 };
4878
4879/*********************************************************/
4880/* Evaluators lookup table (special forms) */
4881typedef void (*evaluator_fun)(eval_context_t *);
4882
4883static const evaluator_fun evaluators[] =
4884 {
4885 eval_quote,
4886 eval_define,
4887 eval_progn,
4888 eval_lambda,
4889 eval_if,
4890 eval_let,
4891 eval_and,
4892 eval_or,
4893 eval_match,
4894 eval_receive,
4895 eval_receive_timeout,
4896 eval_callcc,
4897 eval_atomic,
4898 eval_selfevaluating, // macro
4899 eval_selfevaluating, // cont
4900 eval_selfevaluating, // closure
4901 eval_cond,
4902 eval_app_cont,
4903 eval_var,
4904 eval_setq,
4905 eval_move_to_flash,
4906 eval_loop,
4907 eval_trap
4908 };
4909
4910
4911/*********************************************************/
4912/* Evaluator step function */
4913
4914static void evaluation_step(void){
4915 eval_context_t *ctx = ctx_running;
4916#ifdef VISUALIZE_HEAP
4917 heap_vis_gen_image();
4918#endif
4919
4920 if (ctx->app_cont) {
4921 lbm_value k;
4922 lbm_pop(&ctx->K, &k);
4923 ctx->app_cont = false0;
4924
4925 lbm_uint decoded_k = DEC_CONTINUATION(k)(((k) & ~0xF8000001u) >> 2);
4926
4927 if (decoded_k < NUM_CONTINUATIONS49) {
4928 continuations[decoded_k](ctx);
4929 } else {
4930 error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u));
4931 }
4932 return;
4933 }
4934
4935 if (lbm_is_symbol(ctx->curr_exp)) {
4936 eval_symbol(ctx);
4937 return;
4938 }
4939 if (lbm_is_cons(ctx->curr_exp)) {
4940 lbm_cons_t *cell = lbm_ref_cell(ctx->curr_exp);
4941 lbm_value h = cell->car;
4942 if (lbm_is_symbol(h) && ((h & ENC_SPECIAL_FORMS_MASK0xFFFFF000) == ENC_SPECIAL_FORMS_BIT0x00001000)) {
4943 lbm_uint eval_index = lbm_dec_sym(h) & SPECIAL_FORMS_INDEX_MASK0x000000FF;
4944 evaluators[eval_index](ctx);
4945 return;
4946 }
4947 /*
4948 * At this point head can be anything. It should evaluate
4949 * into a form that can be applied (closure, symbol, ...) though.
4950 */
4951 lbm_value *reserved = stack_reserve(ctx, 3);
4952 reserved[0] = ctx->curr_env;
4953 reserved[1] = cell->cdr;
4954 reserved[2] = APPLICATION_START(((10) << 2) | 0xF8000001u);
4955 ctx->curr_exp = h; // evaluate the function
4956 return;
4957 }
4958
4959 eval_selfevaluating(ctx);
4960 return;
4961}
4962
4963void lbm_pause_eval(void ) {
4964 eval_cps_next_state_arg = 0;
4965 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4966 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4967}
4968
4969void lbm_pause_eval_with_gc(uint32_t num_free) {
4970 eval_cps_next_state_arg = num_free;
4971 eval_cps_next_state = EVAL_CPS_STATE_PAUSED1;
4972 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4973}
4974
4975void lbm_continue_eval(void) {
4976 eval_cps_next_state = EVAL_CPS_STATE_RUNNING2;
4977 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4978}
4979
4980void lbm_kill_eval(void) {
4981 eval_cps_next_state = EVAL_CPS_STATE_KILL4;
4982 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true1;
4983}
4984
4985uint32_t lbm_get_eval_state(void) {
4986 return eval_cps_run_state;
4987}
4988
4989// Will wake up thread that is sleeping as well.
4990// Not sure this is good behavior.
4991static void handle_event_unblock_ctx(lbm_cid cid, lbm_value v) {
4992 eval_context_t *found = NULL((void*)0);
4993 mutex_lock(&qmutex);
4994
4995 found = lookup_ctx_nm(&blocked, cid);
4996 if (found) {
4997 drop_ctx_nm(&blocked,found);
4998 if (lbm_is_error(v)) {
4999 get_stack_ptr(found, 1)[0] = TERMINATE(((28) << 2) | 0xF8000001u); // replace TOS
5000 found->app_cont = true1;
5001 }
5002 found->r = v;
5003 enqueue_ctx_nm(&queue,found);
5004 }
5005 mutex_unlock(&qmutex);
5006}
5007
5008static void handle_event_define(lbm_value key, lbm_value val) {
5009 lbm_uint dec_key = lbm_dec_sym(key);
5010 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK0x1F;
5011 lbm_value *global_env = lbm_get_global_env();
5012 lbm_uint orig_env = global_env[ix_key];
5013 lbm_value new_env;
5014 // A key is a symbol and should not need to be remembered.
5015 WITH_GC(new_env, lbm_env_set(orig_env,key,val))(new_env) = (lbm_env_set(orig_env,key,val)); if (lbm_is_symbol_merror
((new_env))) { gc(); (new_env) = (lbm_env_set(orig_env,key,val
)); if (lbm_is_symbol_merror((new_env))) { error_ctx((((0x23)
<< 4) | 0x00000000u)); } };
5016
5017 global_env[ix_key] = new_env;
5018}
5019
5020static lbm_value get_event_value(lbm_event_t *e) {
5021 lbm_value v;
5022 if (e->buf_len > 0) {
5023 lbm_flat_value_t fv;
5024 fv.buf = (uint8_t*)e->buf_ptr;
5025 fv.buf_size = e->buf_len;
5026 fv.buf_pos = 0;
5027 if (!lbm_unflatten_value(&fv, &v)) {
5028 lbm_set_flags(LBM_FLAG_HANDLER_EVENT_DELIVERY_FAILED(1 << 1));
5029 v = ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u);
5030 }
5031 // Free the flat value buffer. GC is unaware of its existence.
5032 lbm_free(fv.buf);
5033 } else {
5034 v = (lbm_value)e->buf_ptr;
5035 }
5036 return v;
5037}
5038
5039static void process_events(void) {
5040
5041 if (!lbm_events) return;
5042 lbm_event_t e;
5043
5044 while (lbm_event_pop(&e)) {
5045
5046 lbm_value event_val = get_event_value(&e);
5047 switch(e.type) {
5048 case LBM_EVENT_UNBLOCK_CTX:
5049 handle_event_unblock_ctx((lbm_cid)e.parameter, event_val);
5050 break;
5051 case LBM_EVENT_DEFINE:
5052 handle_event_define((lbm_value)e.parameter, event_val);
5053 break;
5054 case LBM_EVENT_FOR_HANDLER:
5055 if (lbm_event_handler_pid >= 0) {
5056 lbm_find_receiver_and_send(lbm_event_handler_pid, event_val);
5057 }
5058 break;
5059 }
5060 }
5061}
5062
5063/* eval_cps_run can be paused
5064 I think it would be better use a mailbox for
5065 communication between other threads and the run_eval
5066 but for now a set of variables will be used. */
5067void lbm_run_eval(void){
5068
5069 if (setjmp(critical_error_jmp_buf)_setjmp (critical_error_jmp_buf) > 0) {
5070 printf_callback("GC stack overflow!\n");
5071 critical_error_callback();
5072 // terminate evaluation thread.
5073 return;
5074 }
5075
5076 setjmp(error_jmp_buf)_setjmp (error_jmp_buf);
5077
5078 while (eval_running) {
5079 if (eval_cps_state_changed || eval_cps_run_state == EVAL_CPS_STATE_PAUSED1) {
5080 eval_cps_state_changed = false0;
5081 switch (eval_cps_next_state) {
5082 case EVAL_CPS_STATE_PAUSED1:
5083 if (eval_cps_run_state != EVAL_CPS_STATE_PAUSED1) {
5084 if (lbm_heap_num_free() < eval_cps_next_state_arg) {
5085 gc();
5086 }
5087 eval_cps_next_state_arg = 0;
5088 }
5089 eval_cps_run_state = EVAL_CPS_STATE_PAUSED1;
5090 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5091 continue; /* jump back to start of eval_running loop */
5092 case EVAL_CPS_STATE_KILL4:
5093 eval_cps_run_state = EVAL_CPS_STATE_DEAD8;
5094 eval_running = false0;
5095 continue;
5096 default: // running state
5097 eval_cps_run_state = eval_cps_next_state;
5098 break;
5099 }
5100 }
5101 while (true1) {
5102 if (eval_steps_quota && ctx_running) {
5103 eval_steps_quota--;
5104 evaluation_step();
5105 } else {
5106 if (eval_cps_state_changed) break;
5107 eval_steps_quota = eval_steps_refill;
5108 if (is_atomic) {
5109 if (!ctx_running) {
5110 lbm_set_flags(LBM_FLAG_ATOMIC_MALFUNCTION(1 << 0));
5111 is_atomic = 0;
5112 }
5113 } else {
5114 if (gc_requested) {
5115 gc();
5116 }
5117 process_events();
5118 mutex_lock(&qmutex);
5119 if (ctx_running) {
5120 enqueue_ctx_nm(&queue, ctx_running);
5121 ctx_running = NULL((void*)0);
5122 }
5123 wake_up_ctxs_nm();
5124 ctx_running = dequeue_ctx_nm(&queue);
5125 mutex_unlock(&qmutex);
5126 if (!ctx_running) {
5127 lbm_system_sleeping = true1;
5128 //Fixed sleep interval to poll events regularly.
5129 usleep_callback(EVAL_CPS_MIN_SLEEP200);
5130 lbm_system_sleeping = false0;
5131 }
5132 }
5133 }
5134 }
5135 }
5136}
5137
5138lbm_cid lbm_eval_program(lbm_value lisp) {
5139 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), 256, NULL((void*)0));
5140}
5141
5142lbm_cid lbm_eval_program_ext(lbm_value lisp, unsigned int stack_size) {
5143 return lbm_create_ctx(lisp, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), stack_size, NULL((void*)0));
5144}
5145
5146int lbm_eval_init() {
5147 if (!qmutex_initialized) {
5148 mutex_init(&qmutex);
5149 qmutex_initialized = true1;
5150 }
5151 if (!lbm_events_mutex_initialized) {
5152 mutex_init(&lbm_events_mutex);
5153 lbm_events_mutex_initialized = true1;
5154 }
5155 if (!blocking_extension_mutex_initialized) {
5156 mutex_init(&blocking_extension_mutex);
5157 blocking_extension_mutex_initialized = true1;
5158 }
5159
5160 mutex_lock(&qmutex);
5161 mutex_lock(&lbm_events_mutex);
5162
5163 blocked.first = NULL((void*)0);
5164 blocked.last = NULL((void*)0);
5165 queue.first = NULL((void*)0);
5166 queue.last = NULL((void*)0);
5167 ctx_running = NULL((void*)0);
5168
5169 eval_cps_run_state = EVAL_CPS_STATE_RUNNING2;
5170
5171 mutex_unlock(&lbm_events_mutex);
5172 mutex_unlock(&qmutex);
5173
5174 if (!lbm_init_env()) return 0;
5175 eval_running = true1;
5176 return 1;
5177}
5178
5179bool_Bool lbm_eval_init_events(unsigned int num_events) {
5180
5181 mutex_lock(&lbm_events_mutex);
5182 lbm_events = (lbm_event_t*)lbm_malloc(num_events * sizeof(lbm_event_t));
5183 bool_Bool r = false0;
5184 if (lbm_events) {
5185 lbm_events_max = num_events;
5186 lbm_events_head = 0;
5187 lbm_events_tail = 0;
5188 lbm_events_full = false0;
5189 lbm_event_handler_pid = -1;
5190 r = true1;
5191 }
5192 mutex_unlock(&lbm_events_mutex);
5193 return r;
5194}
diff --git a/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/scanview.css b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/scanview.css new file mode 100644 index 00000000..cf8a5a6a --- /dev/null +++ b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/scanview.css @@ -0,0 +1,62 @@ +body { color:#000000; background-color:#ffffff } +body { font-family: Helvetica, sans-serif; font-size:9pt } +h1 { font-size: 14pt; } +h2 { font-size: 12pt; } +table { font-size:9pt } +table { border-spacing: 0px; border: 1px solid black } +th, table thead { + background-color:#eee; color:#666666; + font-weight: bold; cursor: default; + text-align:center; + font-weight: bold; font-family: Verdana; + white-space:nowrap; +} +.W { font-size:0px } +th, td { padding:5px; padding-left:8px; text-align:left } +td.SUMM_DESC { padding-left:12px } +td.DESC { white-space:pre } +td.Q { text-align:right } +td { text-align:left } +tbody.scrollContent { overflow:auto } + +table.form_group { + background-color: #ccc; + border: 1px solid #333; + padding: 2px; +} + +table.form_inner_group { + background-color: #ccc; + border: 1px solid #333; + padding: 0px; +} + +table.form { + background-color: #999; + border: 1px solid #333; + padding: 2px; +} + +td.form_label { + text-align: right; + vertical-align: top; +} +/* For one line entires */ +td.form_clabel { + text-align: right; + vertical-align: center; +} +td.form_value { + text-align: left; + vertical-align: top; +} +td.form_submit { + text-align: right; + vertical-align: top; +} + +h1.SubmitFail { + color: #f00; +} +h1.SubmitOk { +} diff --git a/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/sorttable.js b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/sorttable.js new file mode 100644 index 00000000..32faa078 --- /dev/null +++ b/test_reports/version_0.25.0/scan-build/2024-07-23-152344-239046-1/sorttable.js @@ -0,0 +1,492 @@ +/* + SortTable + version 2 + 7th April 2007 + Stuart Langridge, http://www.kryogenix.org/code/browser/sorttable/ + + Instructions: + Download this file + Add to your HTML + Add class="sortable" to any table you'd like to make sortable + Click on the headers to sort + + Thanks to many, many people for contributions and suggestions. + Licenced as X11: http://www.kryogenix.org/code/browser/licence.html + This basically means: do what you want with it. +*/ + + +var stIsIE = /*@cc_on!@*/false; + +sorttable = { + init: function() { + // quit if this function has already been called + if (arguments.callee.done) return; + // flag this function so we don't do the same thing twice + arguments.callee.done = true; + // kill the timer + if (_timer) clearInterval(_timer); + + if (!document.createElement || !document.getElementsByTagName) return; + + sorttable.DATE_RE = /^(\d\d?)[\/\.-](\d\d?)[\/\.-]((\d\d)?\d\d)$/; + + forEach(document.getElementsByTagName('table'), function(table) { + if (table.className.search(/\bsortable\b/) != -1) { + sorttable.makeSortable(table); + } + }); + + }, + + makeSortable: function(table) { + if (table.getElementsByTagName('thead').length == 0) { + // table doesn't have a tHead. Since it should have, create one and + // put the first table row in it. + the = document.createElement('thead'); + the.appendChild(table.rows[0]); + table.insertBefore(the,table.firstChild); + } + // Safari doesn't support table.tHead, sigh + if (table.tHead == null) table.tHead = table.getElementsByTagName('thead')[0]; + + if (table.tHead.rows.length != 1) return; // can't cope with two header rows + + // Sorttable v1 put rows with a class of "sortbottom" at the bottom (as + // "total" rows, for example). This is B&R, since what you're supposed + // to do is put them in a tfoot. So, if there are sortbottom rows, + // for backward compatibility, move them to tfoot (creating it if needed). + sortbottomrows = []; + for (var i=0; i5' : ' ▴'; + this.appendChild(sortrevind); + return; + } + if (this.className.search(/\bsorttable_sorted_reverse\b/) != -1) { + // if we're already sorted by this column in reverse, just + // re-reverse the table, which is quicker + sorttable.reverse(this.sorttable_tbody); + this.className = this.className.replace('sorttable_sorted_reverse', + 'sorttable_sorted'); + this.removeChild(document.getElementById('sorttable_sortrevind')); + sortfwdind = document.createElement('span'); + sortfwdind.id = "sorttable_sortfwdind"; + sortfwdind.innerHTML = stIsIE ? ' 6' : ' ▾'; + this.appendChild(sortfwdind); + return; + } + + // remove sorttable_sorted classes + theadrow = this.parentNode; + forEach(theadrow.childNodes, function(cell) { + if (cell.nodeType == 1) { // an element + cell.className = cell.className.replace('sorttable_sorted_reverse',''); + cell.className = cell.className.replace('sorttable_sorted',''); + } + }); + sortfwdind = document.getElementById('sorttable_sortfwdind'); + if (sortfwdind) { sortfwdind.parentNode.removeChild(sortfwdind); } + sortrevind = document.getElementById('sorttable_sortrevind'); + if (sortrevind) { sortrevind.parentNode.removeChild(sortrevind); } + + this.className += ' sorttable_sorted'; + sortfwdind = document.createElement('span'); + sortfwdind.id = "sorttable_sortfwdind"; + sortfwdind.innerHTML = stIsIE ? ' 6' : ' ▾'; + this.appendChild(sortfwdind); + + // build an array to sort. This is a Schwartzian transform thing, + // i.e., we "decorate" each row with the actual sort key, + // sort based on the sort keys, and then put the rows back in order + // which is a lot faster because you only do getInnerText once per row + row_array = []; + col = this.sorttable_columnindex; + rows = this.sorttable_tbody.rows; + for (var j=0; j 12) { + // definitely dd/mm + return sorttable.sort_ddmm; + } else if (second > 12) { + return sorttable.sort_mmdd; + } else { + // looks like a date, but we can't tell which, so assume + // that it's dd/mm (English imperialism!) and keep looking + sortfn = sorttable.sort_ddmm; + } + } + } + } + return sortfn; + }, + + getInnerText: function(node) { + // gets the text we want to use for sorting for a cell. + // strips leading and trailing whitespace. + // this is *not* a generic getInnerText function; it's special to sorttable. + // for example, you can override the cell text with a customkey attribute. + // it also gets .value for fields. + + hasInputs = (typeof node.getElementsByTagName == 'function') && + node.getElementsByTagName('input').length; + + if (node.getAttribute("sorttable_customkey") != null) { + return node.getAttribute("sorttable_customkey"); + } + else if (typeof node.textContent != 'undefined' && !hasInputs) { + return node.textContent.replace(/^\s+|\s+$/g, ''); + } + else if (typeof node.innerText != 'undefined' && !hasInputs) { + return node.innerText.replace(/^\s+|\s+$/g, ''); + } + else if (typeof node.text != 'undefined' && !hasInputs) { + return node.text.replace(/^\s+|\s+$/g, ''); + } + else { + switch (node.nodeType) { + case 3: + if (node.nodeName.toLowerCase() == 'input') { + return node.value.replace(/^\s+|\s+$/g, ''); + } + case 4: + return node.nodeValue.replace(/^\s+|\s+$/g, ''); + break; + case 1: + case 11: + var innerText = ''; + for (var i = 0; i < node.childNodes.length; i++) { + innerText += sorttable.getInnerText(node.childNodes[i]); + } + return innerText.replace(/^\s+|\s+$/g, ''); + break; + default: + return ''; + } + } + }, + + reverse: function(tbody) { + // reverse the rows in a tbody + newrows = []; + for (var i=0; i=0; i--) { + tbody.appendChild(newrows[i]); + } + delete newrows; + }, + + /* sort functions + each sort function takes two parameters, a and b + you are comparing a[0] and b[0] */ + sort_numeric: function(a,b) { + aa = parseFloat(a[0].replace(/[^0-9.-]/g,'')); + if (isNaN(aa)) aa = 0; + bb = parseFloat(b[0].replace(/[^0-9.-]/g,'')); + if (isNaN(bb)) bb = 0; + return aa-bb; + }, + sort_alpha: function(a,b) { + if (a[0]==b[0]) return 0; + if (a[0] 0 ) { + var q = list[i]; list[i] = list[i+1]; list[i+1] = q; + swap = true; + } + } // for + t--; + + if (!swap) break; + + for(var i = t; i > b; --i) { + if ( comp_func(list[i], list[i-1]) < 0 ) { + var q = list[i]; list[i] = list[i-1]; list[i-1] = q; + swap = true; + } + } // for + b++; + + } // while(swap) + } +} + +/* ****************************************************************** + Supporting functions: bundled here to avoid depending on a library + ****************************************************************** */ + +// Dean Edwards/Matthias Miller/John Resig + +/* for Mozilla/Opera9 */ +if (document.addEventListener) { + document.addEventListener("DOMContentLoaded", sorttable.init, false); +} + +/* for Internet Explorer */ +/*@cc_on @*/ +/*@if (@_win32) + document.write("