Squashed 'lispBM/lispBM/' changes from 186807fd..37274020

37274020 small tweaks and some addition of extension programming helpers from vedderb/bldc

git-subtree-dir: lispBM/lispBM
git-subtree-split: 37274020afda6c6dbb691a8f5ab8fc213d34c676

include/extensions.h

@@ -23,6 +23,7 @@
 #include "symrepr.h"
 #include "heap.h"
 #include "lbm_types.h"
+#include "lbm_constants.h"
 
 #ifdef __cplusplus
 extern "C" {
@@ -75,6 +76,36 @@ static inline bool lbm_is_extension(lbm_value exp) {
           (lbm_get_extension(lbm_dec_sym(exp)) != NULL));
 }
 
+
+/** Check if a value is the symbol t or the symbol nil
+ * \param v The value.
+ * \return true if the value is t or nil otherwise false.
+ */
+bool lbm_check_true_false(lbm_value v);
+/** Check if all arguments are numbers. Sets error-reason if result is false.
+ * \param args The argument array.
+ * \param argn The number of arguments.
+ * \return true if all arguments are numbers, false otherwise.
+ */
+bool lbm_check_number_all(lbm_value *args, lbm_uint argn);
+/** Check if the number of arguments is n. Sets error-reason if result is false.
+ * \param argn number of arguments.
+ * \param n number of expected arguments.
+ * \return true if the number of arguments is correct. false otherwise
+ */
+bool lbm_check_argn(lbm_uint argn, lbm_uint n);
+/** Check if all arguments are numbers and that there is n of them. Sets error-reason if result is false.
+ * \param args The argument array.
+ * \param argn The number of arguments.
+ * \param n The expected number of arguments.
+ * \return true or false.
+ */
+bool lbm_check_argn_number(lbm_value *args, lbm_uint argn, lbm_uint n);
+
+#define LBM_CHECK_NUMBER_ALL() if (!lbm_check_number_all(args, argn)) {return ENC_SYM_EERROR;}
+#define LBM_CHECK_ARGN(n) if (!lbm_check_argn(argn, n)) {return ENC_SYM_EERROR;}
+#define LBM_CHECK_ARGN_NUMBER(n) if (!lbm_check_argn_number(args, argn, n)) {return ENC_SYM_EERROR;}
+
 #ifdef __cplusplus
 }
 #endif

include/lbm_constants.h

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

src/eval_cps.c

@@ -74,12 +74,14 @@
 #define FM_NO_MATCH      -2
 #define FM_PATTERN_ERROR -3
 
-static const char* parse_error_eof = "End of parse stream";
-static const char* parse_error_token = "Malformed token";
-static const char* parse_error_dot = "Incorrect usage of '.'";
-static const char* parse_error_close = "Expected closing parenthesis";
-static const char* num_args_error = "Incorrect number of arguments";
-static const char* forbidden_in_atomic = "Operation is forbidden in an atomic block";
+const char* lbm_error_str_parse_eof = "End of parse stream.";
+const char* lbm_error_str_parse_token = "Malformed token.";
+const char* lbm_error_str_parse_dot = "Incorrect usage of '.'.";
+const char* lbm_error_str_parse_close = "Expected closing parenthesis.";
+const char* lbm_error_str_num_args = "Incorrect number of arguments.";
+const char* lbm_error_str_forbidden_in_atomic = "Operation is forbidden in an atomic block.";
+const char* lbm_error_str_no_number = "Argument(s) must be a number.";
+const char* lbm_error_str_not_a_boolean = "Argument must be t or nil (true or false).";
 
 #define CHECK_STACK(x)                          \
   if (!(x)) {                                   \
@@ -1437,7 +1439,7 @@ static void eval_match(eval_context_t *ctx) {
 static void eval_receive(eval_context_t *ctx) {
 
   if (is_atomic) {
-    lbm_set_error_reason((char*)forbidden_in_atomic);
+    lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
     error_ctx(ENC_SYM_EERROR);
     return;
   }
@@ -1650,7 +1652,7 @@ static void apply_read_program(lbm_value *args, lbm_uint nargs, eval_context_t *
     ctx->r = ENC_SYM_NIL;
     ctx->app_cont = true;
   } else {
-    lbm_set_error_reason((char*)num_args_error);
+    lbm_set_error_reason((char*)lbm_error_str_num_args);
     error_ctx(ENC_SYM_EERROR);
   }
 }
@@ -1720,7 +1722,7 @@ static void apply_spawn_trap(lbm_value *args, lbm_uint nargs, eval_context_t *ct
 
 static void apply_yield(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
   if (is_atomic) {
-    lbm_set_error_reason((char*)forbidden_in_atomic);
+    lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
     error_ctx(ENC_SYM_EERROR);
     return;
   }
@@ -1751,7 +1753,7 @@ static void apply_eval(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
     ctx->curr_exp = args[1];
     lbm_stack_drop(&ctx->K, nargs+1);
   } else {
-    lbm_set_error_reason((char*)num_args_error);
+    lbm_set_error_reason((char*)lbm_error_str_num_args);
     error_ctx(ENC_SYM_EERROR);
   }
 }
@@ -1784,7 +1786,7 @@ static void apply_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *
     ctx->program = lbm_cdr(new_prg);
     ctx->curr_exp = lbm_car(new_prg);
   } else {
-    lbm_set_error_reason((char*)num_args_error);
+    lbm_set_error_reason((char*)lbm_error_str_num_args);
     error_ctx(ENC_SYM_EERROR);
   }
 }
@@ -1803,7 +1805,7 @@ static void apply_send(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
     ctx->r = status;
     ctx->app_cont = true;
   } else {
-    lbm_set_error_reason((char*)num_args_error);
+    lbm_set_error_reason((char*)lbm_error_str_num_args);
     error_ctx(ENC_SYM_EERROR);
   }
 }
@@ -1884,7 +1886,7 @@ static void apply_map(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
       error_ctx(ENC_SYM_FATAL_ERROR);
     }
   } else {
-    lbm_set_error_reason((char*)num_args_error);
+    lbm_set_error_reason((char*)lbm_error_str_num_args);
     error_ctx(ENC_SYM_EERROR);
   }
 }
@@ -1950,7 +1952,7 @@ static void application(eval_context_t *ctx, lbm_value *fun_args, lbm_uint arg_c
     if (arg_count == 1) {
       arg = fun_args[1];
     } else if (arg_count > 1) {
-      lbm_set_error_reason((char*)num_args_error);
+      lbm_set_error_reason((char*)lbm_error_str_num_args);
       error_ctx(ENC_SYM_EERROR);
       return;
     }
@@ -2050,7 +2052,7 @@ static void cont_closure_application_args(eval_context_t *ctx) {
     ctx->app_cont = false;
   } else if (!a_nil && p_nil) {
     // Application with extra arguments
-    lbm_set_error_reason((char*)num_args_error);
+    lbm_set_error_reason((char*)lbm_error_str_num_args);
     error_ctx(ENC_SYM_EERROR);
   } else if (a_nil && !p_nil) {
     // Ran out of arguments, but there are still parameters.
@@ -2430,7 +2432,7 @@ static void read_process_token(eval_context_t *ctx, lbm_value stream, lbm_value
     switch (lbm_dec_sym(tok)) {
     case SYM_TOKENIZER_RERROR:
       lbm_channel_reader_close(str);
-      lbm_set_error_reason((char*)parse_error_token);
+      lbm_set_error_reason((char*)lbm_error_str_parse_token);
       read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
       done_reading(ctx->id);
       return;
@@ -2467,7 +2469,7 @@ static void read_process_token(eval_context_t *ctx, lbm_value stream, lbm_value
         ctx->app_cont = true;
       } else {
         /* Parsing failed */
-        lbm_set_error_reason((char*)parse_error_eof);
+        lbm_set_error_reason((char*)lbm_error_str_parse_eof);
         read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
         done_reading(ctx->id);
       }
@@ -2737,7 +2739,7 @@ static void cont_read_expect_closepar(eval_context_t *ctx) {
     ctx->r = res;
     ctx->app_cont = true;
   } else {
-    lbm_set_error_reason((char*)parse_error_close);
+    lbm_set_error_reason((char*)lbm_error_str_parse_close);
     read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
     done_reading(ctx->id);
   }
@@ -2766,7 +2768,7 @@ static void cont_read_dot_terminate(eval_context_t *ctx) {
   if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL &&
       (lbm_dec_sym(ctx->r) == SYM_CLOSEPAR ||
        lbm_dec_sym(ctx->r) == SYM_DOT)) {
-    lbm_set_error_reason((char*)parse_error_dot);
+    lbm_set_error_reason((char*)lbm_error_str_parse_dot);
     read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
     done_reading(ctx->id);
     return;
@@ -2781,7 +2783,7 @@ static void cont_read_dot_terminate(eval_context_t *ctx) {
       CHECK_STACK(lbm_push_2(&ctx->K, stream, READ_NEXT_TOKEN));
       ctx->app_cont = true;
     } else {
-      lbm_set_error_reason((char*)parse_error_dot);
+      lbm_set_error_reason((char*)lbm_error_str_parse_dot);
       read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
       done_reading(ctx->id);
       return;
@@ -2807,7 +2809,7 @@ static void cont_read_done(eval_context_t *ctx) {
      see if the tokenizer feels it is done here. */
   lbm_channel_reader_close(str);
   if (tok != ENC_SYM_TOKENIZER_DONE) {
-    lbm_set_error_reason((char*)parse_error_eof);
+    lbm_set_error_reason((char*)lbm_error_str_parse_eof);
     read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
   } else {
     ctx->app_cont = true;

src/extensions.c

@@ -21,6 +21,7 @@
 #include <stdlib.h>
 #include <stdbool.h>
 #include <string.h>
+#include <eval_cps.h>
 
 #include "extensions.h"
 
@@ -88,3 +89,49 @@ bool lbm_add_extension(char *sym_str, extension_fptr ext) {
   return true;
 }
 
+
+// Helpers for extension developers:
+
+static bool lbm_is_number_all(lbm_value *args, lbm_uint argn) {
+  for (lbm_uint i = 0;i < argn;i++) {
+    if (!lbm_is_number(args[i])) {
+      return false;
+    }
+  }
+  return true;
+}
+
+bool lbm_check_true_false(lbm_value v) {
+  bool res = lbm_is_symbol_true(v) || lbm_is_symbol_nil(v);
+  lbm_set_error_reason((char*)lbm_error_str_not_a_boolean);
+  return res;
+}
+
+bool lbm_check_number_all(lbm_value *args, lbm_uint argn) {
+  if (!lbm_is_number_all(args, argn)) {
+    lbm_set_error_reason((char*)lbm_error_str_no_number);
+    return false;
+  }
+  return true;
+}
+
+bool lbm_check_argn(lbm_uint argn, lbm_uint n) {
+  if (argn != n) {
+    lbm_set_error_reason((char*)lbm_error_str_num_args);
+    return false;
+  } else {
+    return true;
+  }
+}
+
+bool lbm_check_argn_number(lbm_value *args, lbm_uint argn, lbm_uint n) {
+  if (!lbm_is_number_all(args, argn)) {
+    lbm_set_error_reason((char*)lbm_error_str_no_number);
+    return false;
+  } else if (argn != n) {
+    lbm_set_error_reason((char*)lbm_error_str_num_args);
+    return false;
+  } else {
+    return true;
+  }
+}