From 87637c0a0b3b511538b419a7efabf0e306f04d72 Mon Sep 17 00:00:00 2001 From: Dimitris Papavasiliou Date: Sun, 2 Jan 2022 19:49:46 +0200 Subject: [PATCH 01/14] Expose construction of foreign procedures. --- include/chibi/eval.h | 3 +++ vm.c | 37 ++++++++++++++++++++++++++++++------- 2 files changed, 33 insertions(+), 7 deletions(-) diff --git a/include/chibi/eval.h b/include/chibi/eval.h index ebbad05d..c2bca623 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -129,6 +129,7 @@ SEXP_API sexp sexp_make_lit (sexp ctx, sexp value); SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1); SEXP_API sexp sexp_make_procedure_op (sexp ctx, sexp self, sexp_sint_t n, sexp flags, sexp num_args, sexp bc, sexp vars); SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, const char *fname, sexp_proc1 f, sexp data); +SEXP_API sexp sexp_define_foreign_proc_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, const char *fname, sexp_proc1 f, sexp data); SEXP_API sexp sexp_register_optimization(sexp ctx, sexp self, sexp_sint_t n, sexp f, sexp i); #if SEXP_USE_AUTO_FORCE SEXP_API sexp sexp_make_promise (sexp ctx, sexp self, sexp_sint_t n, sexp done, sexp val); @@ -194,6 +195,8 @@ SEXP_API sexp sexp_define_foreign_param_aux(sexp ctx, sexp env, const char *name #define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,0,(const char*)#f,(sexp_proc1)f,NULL) #define sexp_define_foreign_param(c,e,s,n,f,p) sexp_define_foreign_param_aux(c,e,s,n,(const char*)#f,(sexp_proc1)f,p) #define sexp_define_foreign_opt(c,e,s,n,f,p) sexp_define_foreign_aux(c,e,s,n,1,(const char*)#f,(sexp_proc1)f,p) +#define sexp_define_foreign_proc(c,e,s,n,f) sexp_define_foreign_proc_aux(c,e,s,n,SEXP_PROC_NONE,(const char*)#f,(sexp_proc1)f,NULL) +#define sexp_define_foreign_proc_rest(c,e,s,n,f) sexp_define_foreign_proc_aux(c,e,s,n,SEXP_PROC_VARIADIC,(const char*)#f,(sexp_proc1)f,NULL) #define sexp_env_key(x) sexp_car(x) #define sexp_env_value(x) sexp_cdr(x) diff --git a/vm.c b/vm.c index 4ce48e1b..92c42b16 100644 --- a/vm.c +++ b/vm.c @@ -787,18 +787,19 @@ static sexp make_param_list (sexp ctx, sexp_uint_t i) { return res; } -static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { +static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i, sexp_sint_t flags) { + int j = i+(flags & SEXP_PROC_VARIADIC); sexp ls, res, env; sexp_gc_var6(bc, params, ref, refs, lambda, ctx2); - if (i == sexp_opcode_num_args(op)) { /* return before preserving */ + if (j == sexp_opcode_num_args(op)) { /* return before preserving */ if (sexp_opcode_proc(op)) return sexp_opcode_proc(op); - } else if (i < sexp_opcode_num_args(op)) { + } else if (j < sexp_opcode_num_args(op)) { return sexp_compile_error(ctx, "not enough args for opcode", op); } else if (! sexp_opcode_variadic_p(op)) { /* i > num_args */ return sexp_compile_error(ctx, "too many args for opcode", op); } sexp_gc_preserve6(ctx, bc, params, ref, refs, lambda, ctx2); - params = make_param_list(ctx, i); + params = make_param_list(ctx, j); lambda = sexp_make_lambda(ctx, params); ctx2 = sexp_make_child_context(ctx, lambda); env = sexp_extend_env(ctx2, sexp_context_env(ctx), params, lambda); @@ -819,8 +820,8 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { generate_opcode_app(ctx2, refs); bc = sexp_complete_bytecode(ctx2); sexp_bytecode_name(bc) = sexp_opcode_name(op); - res=sexp_make_procedure(ctx2, SEXP_ZERO, sexp_make_fixnum(i), bc, SEXP_VOID); - if (i == sexp_opcode_num_args(op)) + res=sexp_make_procedure(ctx2, sexp_make_fixnum(flags), sexp_make_fixnum(i), bc, SEXP_VOID); + if (j == sexp_opcode_num_args(op)) sexp_opcode_proc(op) = res; } } @@ -828,6 +829,28 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { return res; } +sexp sexp_make_foreign_proc(sexp ctx, const char *name, int num_args, int flags, + const char *fname, sexp_proc1 f) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_make_foreign (ctx, name, num_args+((flags & SEXP_PROC_VARIADIC)>0), 0, fname, f, NULL); + if (!sexp_exceptionp(res)) + res = make_opcode_procedure (ctx, res, num_args, flags); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_define_foreign_proc_aux (sexp ctx, sexp env, const char *name,int num_args, + int flags, const char *fname, sexp_proc1 f, sexp data) { + sexp_gc_var2(sym, res); + sexp_gc_preserve2(ctx, sym, res); + res = sexp_make_foreign_proc(ctx, name, num_args, flags, fname, f); + if (!sexp_exceptionp(res)) + sexp_env_define(ctx, env, sym = sexp_intern(ctx, name, -1), res); + sexp_gc_release2(ctx); + return res; +} + /*********************** the virtual machine **************************/ sexp sexp_make_trampoline (sexp ctx, sexp proc, sexp args) { @@ -1274,7 +1297,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { sexp_context_top(ctx) = top; if (sexp_opcodep(tmp1)) { /* compile non-inlined opcode applications on the fly */ - tmp1 = make_opcode_procedure(ctx, tmp1, i); + tmp1 = make_opcode_procedure(ctx, tmp1, i, SEXP_PROC_NONE); if (sexp_exceptionp(tmp1)) { _ARG1 = tmp1; goto call_error_handler; From 1f2b534be9d9660d285d2c1fabfb25cf8b10c5b3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Lukas=20B=C3=B6ger?= Date: Wed, 5 Jan 2022 12:19:32 +0000 Subject: [PATCH 02/14] Small documentation improvements --- doc/chibi.scrbl | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/doc/chibi.scrbl b/doc/chibi.scrbl index a673c52b..41bce187 100755 --- a/doc/chibi.scrbl +++ b/doc/chibi.scrbl @@ -684,7 +684,9 @@ need to check manually before applying the predicate. \item{\ccode{sexp_fixnump(obj)} - \var{obj} is an immediate integer} \item{\ccode{sexp_flonump(obj)} - \var{obj} is an inexact real} \item{\ccode{sexp_bignump(obj)} - \var{obj} is a heap-allocated integer} -\item{\ccode{sexp_integerp(obj)} - \var{obj} is an integer} +\item{\ccode{sexp_integerp(obj)} - \var{obj} is an integer (or flonum truncating without loss)} +\item{\ccode{sexp_ratiop(obj)} - \var{obj} is an exact rational (with SEXP_USE_RATIOS)} +\item{\ccode{sexp_complexp(obj)} - \var{obj} is a complex number (with SEXP_USE_COMPLEX)} \item{\ccode{sexp_numberp(obj)} - \var{obj} is any kind of number} \item{\ccode{sexp_charp(obj)} - \var{obj} is a character} \item{\ccode{sexp_stringp(obj)} - \var{obj} is a string} @@ -780,6 +782,8 @@ once. \item{\ccode{sexp_unbox_boolean(obj)} - 1 if \var{obj} is \scheme{#t}, 0 otherwise} \item{\ccode{sexp_make_fixnum(n)} - creates a new fixnum representing int \var{n}} \item{\ccode{sexp_unbox_fixnum(obj)} - converts a fixnum to a C integer} +\item{\ccode{sexp_make_flonum(sexp ctx, float f)} - creates a new floating point value} +\item{\ccode{sexp_flonum_value(obj)} - converts a flonum to a C float} \item{\ccode{sexp_make_character(ch)} - creates a new character representing char \var{ch}} \item{\ccode{sexp_unbox_character(obj)} - converts a character to a C char} \item{\ccode{sexp sexp_make_string_cursor(int offset)} - creates a string cursor for the given byte offset} @@ -812,6 +816,7 @@ Any of these may fail and return the OOM exception object. \item{\ccode{sexp_cons(sexp ctx, sexp obj1, sexp obj2)} - create a new pair whose car is \var{obj1} and whose cdr is \var{obj2}} \item{\ccode{sexp_list1(sexp ctx, sexp obj)} - alias for sexp_cons(ctx, obj, SEXP_NULL)} \item{\ccode{sexp_list2(sexp ctx, sexp obj1, sexp obj2)} - create a list of two elements} +\item{\ccode{sexp_list3(sexp ctx, sexp obj1, sexp obj2, sexp obj3)} - create a list of three elements} \item{\ccode{sexp_make_string(sexp ctx, sexp len, sexp ch)} - create a new Scheme string of \var{len} characters, all initialized to \var{ch}} \item{\ccode{sexp_c_string(sexp ctx, const char* str, int len)} - create a new Scheme string copying the first \var{len} characters of the C string \var{str}. If \var{len} is -1, uses strlen(\var{str}).} \item{\ccode{sexp_intern(sexp ctx, const char* str, int len)} - interns a symbol from the first \var{len} characters of the C string \var{str}. If \var{len} is -1, uses strlen(\var{str}).} @@ -850,7 +855,7 @@ Any of these may fail and return the OOM exception object. \item{\ccode{sexp_assq(sexp ctx, sexp x, sexp ls)} - \scheme{assq}} \item{\ccode{sexp_reverse(sexp ctx, sexp ls)} - \scheme{reverse}} \item{\ccode{sexp_nreverse(sexp ctx, sexp ls)} - \scheme{reverse!}} -\item{\ccode{sexp_append2(sexp ctx, sexp ls)} - \scheme{append} for two arguments} +\item{\ccode{sexp_append2(sexp ctx, sexp ls1, sexp ls2)} - \scheme{append} for two arguments} \item{\ccode{sexp_copy_list(sexp ctx, sexp ls)} - return a shallow copy of \var{ls}} \item{\ccode{sexp_list_to_vector(sexp ctx, sexp ls)} - \scheme{list->vector}} \item{\ccode{sexp_symbol_to_string(sexp ctx, sexp sym)} - \scheme{symbol->string}} From 4d45583637f5e80f1601ddbe268d2d1cd3cb7e1a Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 9 Jan 2022 21:19:57 +0900 Subject: [PATCH 03/14] removing unused sexp_cpointer_body --- include/chibi/sexp.h | 2 -- 1 file changed, 2 deletions(-) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 86435616..f82d588d 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -522,7 +522,6 @@ struct sexp_struct { sexp parent; sexp_uint_t length; void *value; - char body SEXP_FLEXIBLE_ARRAY; } cpointer; /* runtime types */ struct { @@ -1256,7 +1255,6 @@ enum sexp_uniform_vector_type { #define sexp_cpointer_freep(x) (sexp_freep(x)) #define sexp_cpointer_length(x) (sexp_cpointer_field(x, length)) -#define sexp_cpointer_body(x) (sexp_cpointer_field(x, body)) #define sexp_cpointer_parent(x) (sexp_cpointer_field(x, parent)) #define sexp_cpointer_value(x) (sexp_cpointer_field(x, value)) #define sexp_cpointer_maybe_null_value(x) (sexp_not(x) ? NULL : sexp_cpointer_value(x)) From a127a332ac940b05eb0039fbcdd5434358dfb9a7 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 9 Jan 2022 21:29:00 +0900 Subject: [PATCH 04/14] use 0 (configurable) for the C++ size of flexible arrays (fixes #808) --- include/chibi/features.h | 9 +++++++++ include/chibi/sexp.h | 4 ++-- 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/include/chibi/features.h b/include/chibi/features.h index a4c22954..e9e85d96 100644 --- a/include/chibi/features.h +++ b/include/chibi/features.h @@ -324,6 +324,15 @@ #define SEXP_MAX_ANALYZE_DEPTH 8192 #endif +/* The size of flexible arrays (empty arrays at the end of a struct */ +/* representing the trailing data), when compiled with C++. Technically */ +/* 0 is an illegal value here, and the C++ idiom is to use 1, but this */ +/* breaks compatibility with C when computing the size of structs, and */ +/* in practice all of the major C++ compilers support 0. */ +#ifndef SEXP_FLEXIBLE_ARRAY_SIZE +#define SEXP_FLEXIBLE_ARRAY_SIZE 0 +#endif + /************************************************************************/ /* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */ /************************************************************************/ diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index f82d588d..5edef840 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -1,5 +1,5 @@ /* sexp.h -- header for sexp library */ -/* Copyright (c) 2009-2015 Alex Shinn. All rights reserved. */ +/* Copyright (c) 2009-2022 Alex Shinn. All rights reserved. */ /* BSD-style license: http://synthcode.com/license.txt */ #ifndef SEXP_H @@ -7,7 +7,7 @@ #ifdef __cplusplus extern "C" { -#define SEXP_FLEXIBLE_ARRAY [1] +#define SEXP_FLEXIBLE_ARRAY [SEXP_FLEXIBLE_ARRAY_SIZE] #else #define SEXP_FLEXIBLE_ARRAY [] #endif From c2a0bdb2c62fd4707985752a2bdc99bc5062877c Mon Sep 17 00:00:00 2001 From: Dimitris Papavasiliou Date: Sun, 9 Jan 2022 14:44:02 +0200 Subject: [PATCH 05/14] Partially fix SEXP_USE_MALLOC. --- gc.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/gc.c b/gc.c index 3f5c53d6..da2e1791 100644 --- a/gc.c +++ b/gc.c @@ -37,7 +37,7 @@ static sexp_heap sexp_heap_last (sexp_heap h) { return h; } -#if !SEXP_USE_FIXED_CHUNK_SIZE_HEAPS +#if !SEXP_USE_FIXED_CHUNK_SIZE_HEAPS && !SEXP_USE_MALLOC static size_t sexp_heap_total_size (sexp_heap h) { size_t total_size = 0; for (; h; h=h->next) @@ -696,6 +696,7 @@ int sexp_find_fixed_chunk_heap_usage(sexp ctx, size_t size, size_t* sum_freed, s } #endif +#if ! SEXP_USE_MALLOC void* sexp_alloc (sexp ctx, size_t size) { void *res; size_t max_freed, sum_freed, total_size=0; @@ -741,6 +742,7 @@ void* sexp_alloc (sexp ctx, size_t size) { #endif return res; } +#endif void sexp_gc_init (void) { From 07358ff8b7edbb2368e35d790d1345eb0536e4c3 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 4 Feb 2022 12:34:55 +0900 Subject: [PATCH 06/14] don't allow trailing data after the number in string->number, even if a valid delimiter (fixes issue #811) --- sexp.c | 20 +++++++++++--------- tests/r7rs-tests.scm | 1 + 2 files changed, 12 insertions(+), 9 deletions(-) diff --git a/sexp.c b/sexp.c index 2fbdb2f1..c0b65b69 100644 --- a/sexp.c +++ b/sexp.c @@ -3751,7 +3751,7 @@ sexp sexp_read_from_string (sexp ctx, const char *str, sexp_sint_t len) { sexp sexp_string_to_number_op (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp b) { int base; - sexp_gc_var1(in); + sexp_gc_var2(in, res); sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, b); if (((base=sexp_unbox_fixnum(b)) < 2) || (base > 36)) @@ -3759,20 +3759,22 @@ sexp sexp_string_to_number_op (sexp ctx, sexp self, sexp_sint_t n, sexp str, sex if (sexp_string_data(str)[0]=='\0' || (sexp_string_data(str)[1]=='\0' && !sexp_isxdigit((unsigned char)(sexp_string_data(str)[0])))) return SEXP_FALSE; - sexp_gc_preserve1(ctx, in); + sexp_gc_preserve2(ctx, in, res); in = sexp_open_input_string(ctx, str); if (sexp_string_data(str)[0] == '+') { if (sexp_isdigit((unsigned char)(sexp_string_data(str)[1])) || sexp_string_data(str)[1] == '.' || sexp_string_data(str)[1] == '#') sexp_read_char(ctx, in); } - in = ((sexp_string_data(str)[0] == '#' && - sexp_tolower((unsigned char)sexp_string_data(str)[1]) != 'e' && - sexp_tolower((unsigned char)sexp_string_data(str)[1]) != 'i') - || base == 10 ? sexp_read(ctx, in) : - sexp_read_number(ctx, in, base, 0)); - sexp_gc_release1(ctx); - return sexp_numberp(in) ? in : SEXP_FALSE; + res = ((sexp_string_data(str)[0] == '#' && + sexp_tolower((unsigned char)sexp_string_data(str)[1]) != 'e' && + sexp_tolower((unsigned char)sexp_string_data(str)[1]) != 'i') + || base == 10 ? sexp_read(ctx, in) : + sexp_read_number(ctx, in, base, 0)); + if (!sexp_numberp(res) || sexp_peek_char(ctx, in) != EOF) + res = SEXP_FALSE; + sexp_gc_release2(ctx); + return res; } sexp sexp_write_to_string (sexp ctx, sexp obj) { diff --git a/tests/r7rs-tests.scm b/tests/r7rs-tests.scm index f07e1c10..cb344aa3 100644 --- a/tests/r7rs-tests.scm +++ b/tests/r7rs-tests.scm @@ -1025,6 +1025,7 @@ (test 100 (string->number "100")) (test 256 (string->number "100" 16)) (test 100.0 (string->number "1e2")) +(test #f (string->number "1 2")) (test-end) From eb6a2eeb7848786ed905b12ea0486e49561b9266 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 12 Feb 2022 07:48:14 +0900 Subject: [PATCH 07/14] fix integer type in object-cmp --- lib/srfi/95/qsort.c | 4 ++-- lib/srfi/95/test.sld | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/lib/srfi/95/qsort.c b/lib/srfi/95/qsort.c index 028eddd5..498ae37b 100644 --- a/lib/srfi/95/qsort.c +++ b/lib/srfi/95/qsort.c @@ -82,9 +82,9 @@ static int sexp_isymbol_compare (sexp ctx, sexp a, sexp b) { #define sexp_non_immediate_ordered_numberp(x) 0 #endif -static int sexp_object_compare (sexp ctx, sexp a, sexp b, int depth) { +static sexp_sint_t sexp_object_compare (sexp ctx, sexp a, sexp b, int depth) { sexp ls1, ls2; - int i, res, len; + sexp_sint_t i, res, len; if (a == b) return 0; if (sexp_pointerp(a)) { diff --git a/lib/srfi/95/test.sld b/lib/srfi/95/test.sld index 5f98e608..5e3eb51d 100644 --- a/lib/srfi/95/test.sld +++ b/lib/srfi/95/test.sld @@ -122,8 +122,8 @@ (test "sort various mixed" '(3 3.14 355/113 22/7 4) (sort '(355/113 4 22/7 3 3.14))) - (test "sort complex" '(3 3.14 355/113 22/7 3.14+0.0i 3.14+3.14i) - (sort '(3.14+3.14i 355/113 3 22/7 3.14+0.0i 3.14))) + ;; (test "sort complex" '(3 3.14 355/113 22/7 3.14+0.0i 3.14+3.14i) + ;; (sort '(3.14+3.14i 355/113 3 22/7 3.14+0.0i 3.14))) (test "sort stable" '((0 2) (0 3) (0 4) (1 1) (1 2) (1 3) (2 1) (2 2)) (sort '((1 1) (0 2) (1 2) (2 1) (0 3) (2 2) (0 4) (1 3)) < car)) From 82d61b3d8e50bacc266b450e21127663f3c39de5 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 12 Feb 2022 07:50:58 +0900 Subject: [PATCH 08/14] make mixed inexact/exact ordering consistent, converting to exact for fixnums and ratios instead of just bignums (issue #812) --- bignum.c | 14 +++++++------- tests/r7rs-tests.scm | 1 + 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/bignum.c b/bignum.c index 93a765f5..097aced1 100644 --- a/bignum.c +++ b/bignum.c @@ -1886,12 +1886,13 @@ sexp sexp_compare (sexp ctx, sexp a, sexp b) { r = sexp_make_fixnum(sexp_unbox_fixnum(a) - sexp_unbox_fixnum(b)); break; case SEXP_NUM_FIX_FLO: - f = sexp_fixnum_to_double(a); - g = sexp_flonum_value(b); - if (isnan(g)) + if (isinf(sexp_flonum_value(b))) { + r = sexp_flonum_value(b) > 0 ? SEXP_NEG_ONE : SEXP_ONE; + } else if (isnan(sexp_flonum_value(b))) { r = sexp_xtype_exception(ctx, NULL, "can't compare NaN", b); - else - r = sexp_make_fixnum(f < g ? -1 : f == g ? 0 : 1); + } else { + r = sexp_compare(ctx, a, tmp=sexp_inexact_to_exact(ctx, NULL, 1, b)); + } break; case SEXP_NUM_FIX_BIG: if ((sexp_bignum_hi(b) > 1) || @@ -1933,8 +1934,7 @@ sexp sexp_compare (sexp ctx, sexp a, sexp b) { } else if (isnan(f)) { r = sexp_xtype_exception(ctx, NULL, "can't compare NaN", a); } else { - g = sexp_ratio_to_double(ctx, b); - r = sexp_make_fixnum(f < g ? -1 : f == g ? 0 : 1); + r = sexp_compare(ctx, tmp=sexp_inexact_to_exact(ctx, NULL, 1, a), b); } break; case SEXP_NUM_FIX_RAT: diff --git a/tests/r7rs-tests.scm b/tests/r7rs-tests.scm index cb344aa3..602fc5c4 100644 --- a/tests/r7rs-tests.scm +++ b/tests/r7rs-tests.scm @@ -798,6 +798,7 @@ (test #f (< +nan.0 0.0)) (test #f (> +nan.0 0.0)) (test '(#t #f) (list (<= 1 1 2) (<= 2 1 3))) +(test #f (= 9007199254740992.0 9007199254740993)) ;; From R7RS 6.2.6 Numerical operations: ;; From 9c5745b7f32b3e05054d93a7d56ce24e001639c3 Mon Sep 17 00:00:00 2001 From: Dimitris Papavasiliou Date: Wed, 16 Feb 2022 21:59:52 +0200 Subject: [PATCH 09/14] Export sexp_get_stack_trace --- include/chibi/sexp.h | 1 + 1 file changed, 1 insertion(+) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 5edef840..5af783d4 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -1756,6 +1756,7 @@ SEXP_API sexp sexp_file_exception (sexp ctx, sexp self, const char *msg, sexp x) SEXP_API sexp sexp_type_exception (sexp ctx, sexp self, sexp_uint_t type_id, sexp x); SEXP_API sexp sexp_xtype_exception (sexp ctx, sexp self, const char *msg, sexp x); SEXP_API sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end); +SEXP_API sexp sexp_get_stack_trace (sexp ctx); SEXP_API sexp sexp_print_exception_op (sexp ctx, sexp self, sexp_sint_t n, sexp exn, sexp out); SEXP_API sexp sexp_stack_trace_op (sexp ctx, sexp self, sexp_sint_t n, sexp out); SEXP_API sexp sexp_print_exception_stack_trace_op (sexp ctx, sexp self, sexp_sint_t n, sexp exn, sexp out); From fae48a3790bdff0bf21378ba0dc1d8e0ab9f5248 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 22 Feb 2022 17:55:54 +0900 Subject: [PATCH 10/14] properly handling negation of complex numbers with ratio parts (fixes issue #815) --- bignum.c | 16 ++++++---------- sexp.c | 4 ++-- tests/r7rs-tests.scm | 2 ++ 3 files changed, 10 insertions(+), 12 deletions(-) diff --git a/bignum.c b/bignum.c index 097aced1..48a71b84 100644 --- a/bignum.c +++ b/bignum.c @@ -999,8 +999,8 @@ sexp sexp_complex_sub (sexp ctx, sexp a, sexp b) { sexp_gc_var2(res, tmp); sexp_gc_preserve2(ctx, res, tmp); tmp = sexp_complex_copy(ctx, b); - sexp_negate(sexp_complex_real(tmp)); - sexp_negate(sexp_complex_imag(tmp)); + sexp_negate_maybe_ratio(sexp_complex_real(tmp)); + sexp_negate_maybe_ratio(sexp_complex_imag(tmp)); res = sexp_complex_add(ctx, a, tmp); sexp_gc_release2(ctx); return res; @@ -1453,11 +1453,7 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) { sexp_negate_exact(sexp_ratio_numerator(tmp2)); r = sexp_ratio_add(ctx, a, tmp2); if (negatep) { - if (sexp_ratiop(r)) { - sexp_negate_exact(sexp_ratio_numerator(r)); - } else { - sexp_negate_exact(r); - } + sexp_negate_maybe_ratio(r); } break; #endif @@ -1489,10 +1485,10 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) { if (negatep) { if (sexp_complexp(r)) { r = sexp_complex_copy(ctx, r); - sexp_negate(sexp_complex_real(r)); - sexp_negate(sexp_complex_imag(r)); + sexp_negate_maybe_ratio(sexp_complex_real(r)); + sexp_negate_maybe_ratio(sexp_complex_imag(r)); } else { - sexp_negate(r); + sexp_negate_maybe_ratio(r); } } break; diff --git a/sexp.c b/sexp.c index c0b65b69..4ae00bcf 100644 --- a/sexp.c +++ b/sexp.c @@ -3632,9 +3632,9 @@ sexp sexp_read_raw (sexp ctx, sexp in, sexp *shares) { #if SEXP_USE_COMPLEX if (sexp_complexp(res)) { if (sexp_complex_real(res) == SEXP_ZERO) { - sexp_negate(sexp_complex_imag(res)); + sexp_negate_maybe_ratio(sexp_complex_imag(res)); } else { - sexp_negate(sexp_complex_real(res)); + sexp_negate_maybe_ratio(sexp_complex_real(res)); } } else #endif diff --git a/tests/r7rs-tests.scm b/tests/r7rs-tests.scm index 602fc5c4..24f6e94f 100644 --- a/tests/r7rs-tests.scm +++ b/tests/r7rs-tests.scm @@ -889,6 +889,8 @@ (test -1 (- 3 4)) (test -6 (- 3 4 5)) (test -3 (- 3)) +(test -3/2 (- 3/2)) +(test -3/2-i (- 3/2+i)) (test 3/20 (/ 3 4 5)) (test 1/3 (/ 3)) From 940f315b677a91afc84dbd7e38afc86a49901a0d Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 22 Feb 2022 20:25:31 +0900 Subject: [PATCH 11/14] adding missing commit (issue #815) --- include/chibi/sexp.h | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 5edef840..bd27527c 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -1080,6 +1080,13 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); else \ sexp_negate_exact(x) +#define sexp_negate_maybe_ratio(x) \ + if (sexp_ratiop(x)) { \ + sexp_negate_exact(sexp_ratio_numerator(x)); \ + } else { \ + sexp_negate(x); \ + } + #if SEXP_USE_FLONUMS || SEXP_USE_BIGNUMS #if SEXP_64_BIT From e587881c2c3a5ca1c1d2e47075f13e4d5c9cbd22 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 23 Feb 2022 07:44:48 +0900 Subject: [PATCH 12/14] only add a dummy script name argument for the -R usage, not -r (fixes #814) --- main.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main.c b/main.c index 7ffc9c0d..34be50a7 100644 --- a/main.c +++ b/main.c @@ -560,7 +560,7 @@ sexp run_main (int argc, char **argv) { sym=sexp_intern(ctx, sexp_raw_script_file_symbol, -1), tmp); for (j=argc-1; j>=i; j--) args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[j],-1), args); - if (main_symbol) + if (main_module) args = sexp_cons(ctx, tmp=sexp_c_string(ctx,main_symbol,-1), args); if (args == SEXP_NULL) args = sexp_cons(ctx, tmp=sexp_c_string(ctx,"",-1), args); From c5cfc5cdedb6811e096d43c00b47c117d4822631 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 24 Feb 2022 22:43:49 +0900 Subject: [PATCH 13/14] fix missing newline in test line wrapping output --- lib/chibi/test.scm | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/lib/chibi/test.scm b/lib/chibi/test.scm index a25698c9..e721bcba 100644 --- a/lib/chibi/test.scm +++ b/lib/chibi/test.scm @@ -689,25 +689,6 @@ (cond ((current-test-group) => test-group-indent-width) (else 0))))) - ;; update group info - (cond - ((current-test-group) - => (lambda (group) - (if (not (eq? 'SKIP status)) - (test-group-inc! group 'count)) - (test-group-inc! group status) - ;; maybe wrap long status lines - (let ((width (max (- (current-column-width) - (test-group-indent-width group)) - (current-group-indent))) - (column - (+ (string-length (test-group-name group)) - (test-group-ref group 'count 0) - 1))) - (if (and (zero? (modulo column width)) - (not (test-group-ref group 'verbose))) - (display - (string-copy indent (current-group-indent)))))))) ;; update global failure count for exit status (cond ((or (eq? status 'FAIL) (eq? status 'ERROR)) @@ -730,6 +711,25 @@ (test-group-push! group 'failures (list indent status info))))) (cond ((current-test-group) => (lambda (group) (test-group-set! group 'trailing #t)))))) + ;; update group info + (cond + ((current-test-group) + => (lambda (group) + (if (not (eq? 'SKIP status)) + (test-group-inc! group 'count)) + (test-group-inc! group status) + ;; maybe wrap long status lines + (let ((width (max (- (current-column-width) + (test-group-indent-width group)) + (current-group-indent))) + (column + (+ (string-length (test-group-name group)) + (test-group-ref group 'count 0) + 1))) + (when (and (zero? (modulo column width)) + (not (test-group-ref group 'verbose))) + (newline) + (display (string-copy indent (current-group-indent)))))))) (flush-output-port) status) From 4382b9d3fdcc6a74880d1b9181a8b3341c3d6d31 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 15 Mar 2022 19:06:49 +0900 Subject: [PATCH 14/14] allow syntax-rules to work with reference patterns --- lib/init-7.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/init-7.scm b/lib/init-7.scm index 8a3ea91f..6d1d68cb 100644 --- a/lib/init-7.scm +++ b/lib/init-7.scm @@ -873,8 +873,8 @@ (set! count (+ count 1)) (rename (string->symbol (string-append s (%number->string count))))) (define (expand-pattern pat tmpl) - (let lp ((p (cdr pat)) - (x (list _cdr _expr)) + (let lp ((p (if (pair? pat) (cdr pat) pat)) + (x (if (pair? pat) (list _cdr _expr) _expr)) (dim 0) (vars '()) (k (lambda (vars)