From 247b75c25479d53efc77a5652e0c816ef259fa1f Mon Sep 17 00:00:00 2001 From: Da Shen Date: Sat, 14 Feb 2026 00:05:50 +0800 Subject: [PATCH 1/3] wip --- devel/200_21.md | 35 ++---------- src/s7.c | 139 +----------------------------------------------- src/s7_r7rs.c | 99 ++++++++++++++++++++++++++++++++++ src/s7_r7rs.h | 5 +- 4 files changed, 106 insertions(+), 172 deletions(-) diff --git a/devel/200_21.md b/devel/200_21.md index 713e8faa..a83b1cfc 100644 --- a/devel/200_21.md +++ b/devel/200_21.md @@ -13,39 +13,10 @@ xmake build bin/goldfish tests/test_all.scm ``` -## 2026/02/13 移除 file-exists? 在 s7.c 中的相关代码 -### Why -- `file-exists?` 已在 `goldfish/scheme/boot.scm` 中使用 `g_access` 重新实现 -- 避免 s7.c 和 boot.scm 中的重复实现 -- 保持 s7.c 的精简，将 R7RS 相关功能移到 Scheme 层实现 +## 2026/02/14 将 sqrt 从 s7.c 迁移至 s7_r7rs.c -### How -1. 从 s7.c 中删除 `g_file_exists` 和 `file_exists_b_7p` 函数实现 -2. 从 s7.c 中删除 `sc->file_exists_symbol` 相关的变量声明、初始化和函数选择器设置 -3. `file-exists?` 功能完全由 `goldfish/scheme/boot.scm` 中的 Scheme 实现提供 +## 2026/02/13 移除 file-exists? 在 s7.c 中的相关代码 ## 2026/02/13 移除 getenv 在 s7.c 中的相关代码 -### Why -- R7RS 标准定义的 `get-environment-variable` 函数与 s7.c 中原生实现的 `getenv` 行为有所不同 -- 使用 tbox 的 `tb_environment_*` API 重新实现，可以更好地处理跨平台环境变量获取（包括 Windows 和 Unix-like 系统） -- 将 R7RS 相关功能从 s7.c 核心解释器中分离，保持 s7.c 的精简 -- 原生 `getenv` 返回字符串，而 R7RS `get-environment-variable` 在变量不存在时应返回 `#f`，需要重新实现以符合标准 - -### How -1. 从 s7.c 中删除 `g_getenv` 函数实现（位于 `#if WITH_R7RS || WITH_SYSTEM_EXTRAS` 条件块内） -2. 从 s7.c 中删除 `sc->getenv_symbol` 相关的变量声明和初始化 -3. 确保 `WITH_R7RS` 或 `WITH_SYSTEM_EXTRAS` 宏下的 getenv 功能完全由外部（goldfish.hpp）提供 - -## 2026/02/13 拆分 s7_r7rs.c 并重新实现 get-environment-variables -### What -1. 从 `s7.c` 中提取 getenvs 到新文件 `s7_r7rs.c` -2. 创建 `s7_r7rs.h` 头文件，包含 R7RS 相关的函数声明和定义 -3. 更新 `s7.c` 和 `s7.h`，移除 R7RS 相关代码，改为包含 `s7_r7rs.h` -4. 更新 `xmake.lua` 构建配置，将 `s7_r7rs.c` 添加到源文件列表 -### Why -- 减少 `s7.c` 的文件大小，提高代码可维护性 -- 分离关注点，使 R7RS 相关功能模块化 -- 便于后续单独测试和优化 R7RS 功能 -- 符合模块化设计原则 -- **支持 vibe coding**：拆分后 `s7.c` 文件变小，更适合在编辑器中快速浏览和修改，提升开发体验 +## 2026/02/13 拆分 s7_r7rs.c 并重新实现 get-environment-variables \ No newline at end of file diff --git a/src/s7.c b/src/s7.c index 8a9f2965..2e37fc71 100644 --- a/src/s7.c +++ b/src/s7.c @@ -18813,143 +18813,6 @@ static s7_pointer g_atanh(s7_scheme *sc, s7_pointer args) } -/* -------------------------------- sqrt -------------------------------- */ -static s7_pointer sqrt_p_p(s7_scheme *sc, s7_pointer num) -{ - switch (type(num)) - { - case T_INTEGER: - { - s7_double sqx; - if (integer(num) >= 0) - { - s7_int ix; -#if WITH_GMP - mpz_set_si(sc->mpz_1, integer(num)); - mpz_sqrtrem(sc->mpz_1, sc->mpz_2, sc->mpz_1); - if (mpz_cmp_ui(sc->mpz_2, 0) == 0) - return(make_integer(sc, mpz_get_si(sc->mpz_1))); - mpfr_set_si(sc->mpfr_1, integer(num), MPFR_RNDN); - mpfr_sqrt(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); -#endif - sqx = sqrt((s7_double)integer(num)); - ix = (s7_int)sqx; - return(((ix * ix) == integer(num)) ? make_integer(sc, ix) : make_real(sc, sqx)); - /* Mark Weaver notes that (zero? (- (sqrt 9007199136250226) 94906265.0)) -> #t - * but (* 94906265 94906265) -> 9007199136250225 -- oops - * if we use bigfloats, we're ok: - * (* (sqrt 9007199136250226.0) (sqrt 9007199136250226.0)) -> 9.007199136250226000000000000000000000026E15 - * at least we return a real here, not an incorrect integer and (sqrt 9007199136250225) -> 94906265 - */ - } -#if HAVE_COMPLEX_NUMBERS -#if WITH_GMP - mpc_set_si(sc->mpc_1, integer(num), MPC_RNDNN); - mpc_sqrt(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - sqx = (s7_double)integer(num); /* we're trying to protect against (sqrt -9223372036854775808) where we can't negate the integer argument */ - return(make_complex_not_0i(sc, 0.0, sqrt((s7_double)(-sqx)))); -#else - out_of_range_error_nr(sc, sc->sqrt_symbol, int_one, num, no_complex_numbers_string); -#endif - } - - case T_RATIO: - if (numerator(num) > 0) /* else it's complex, so it can't be a ratio */ - { - s7_int nm = (s7_int)sqrt(numerator(num)); - if (nm * nm == numerator(num)) - { - s7_int dn = (s7_int)sqrt(denominator(num)); - if (dn * dn == denominator(num)) - return(make_ratio(sc, nm, dn)); - } - return(make_real(sc, sqrt((s7_double)fraction(num)))); - } -#if HAVE_COMPLEX_NUMBERS - return(make_complex(sc, 0.0, sqrt((s7_double)(-fraction(num))))); -#else - out_of_range_error_nr(sc, sc->sqrt_symbol, int_one, num, no_complex_numbers_string); -#endif - - case T_REAL: - if (is_NaN(real(num))) return(num); /* needed because otherwise (sqrt +nan.0) -> 0.0-nan.0i ?? */ - if (real(num) >= 0.0) - return(make_real(sc, sqrt(real(num)))); - return(make_complex_not_0i(sc, 0.0, sqrt(-real(num)))); - - case T_COMPLEX: /* (* inf.0 (sqrt -1)) -> -nan+infi, but (sqrt -inf.0) -> 0+infi */ -#if HAVE_COMPLEX_NUMBERS - return(c_complex_to_s7(sc, csqrt(to_c_complex(num)))); /* sqrt(+inf.0+1.0i) -> +inf.0 */ -#else - out_of_range_error_nr(sc, sc->sqrt_symbol, int_one, num, no_complex_numbers_string); -#endif - -#if WITH_GMP - case T_BIG_INTEGER: - if (mpz_cmp_ui(big_integer(num), 0) >= 0) - { - mpz_sqrtrem(sc->mpz_1, sc->mpz_2, big_integer(num)); - if (mpz_cmp_ui(sc->mpz_2, 0) == 0) - return(mpz_to_integer(sc, sc->mpz_1)); - mpfr_set_z(sc->mpfr_1, big_integer(num), MPFR_RNDN); - mpfr_sqrt(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } - mpc_set_z(sc->mpc_1, big_integer(num), MPC_RNDNN); - mpc_sqrt(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - - case T_BIG_RATIO: /* if big ratio, check both num and den for squares */ - if (mpq_cmp_ui(big_ratio(num), 0, 1) < 0) - { - mpc_set_q(sc->mpc_1, big_ratio(num), MPC_RNDNN); - mpc_sqrt(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - } - mpz_sqrtrem(sc->mpz_1, sc->mpz_2, mpq_numref(big_ratio(num))); - if (mpz_cmp_ui(sc->mpz_2, 0) == 0) - { - mpz_sqrtrem(sc->mpz_3, sc->mpz_2, mpq_denref(big_ratio(num))); - if (mpz_cmp_ui(sc->mpz_2, 0) == 0) - { - mpq_set_num(sc->mpq_1, sc->mpz_1); - mpq_set_den(sc->mpq_1, sc->mpz_3); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - }} - mpfr_set_q(sc->mpfr_1, big_ratio(num), MPFR_RNDN); - mpfr_sqrt(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - - case T_BIG_REAL: - if (mpfr_cmp_ui(big_real(num), 0) < 0) - { - mpc_set_fr(sc->mpc_1, big_real(num), MPC_RNDNN); - mpc_sqrt(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - } - mpfr_sqrt(sc->mpfr_1, big_real(num), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - - case T_BIG_COMPLEX: - mpc_sqrt(sc->mpc_1, big_complex(num), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_p(sc, num, sc->sqrt_symbol, a_number_string)); - } -} - -static s7_pointer g_sqrt(s7_scheme *sc, s7_pointer args) -{ - #define H_sqrt "(sqrt z) returns the square root of z" - #define Q_sqrt sc->pl_nn - return(sqrt_p_p(sc, car(args))); -} - - /* -------------------------------- expt -------------------------------- */ static s7_int int_to_int(s7_int x, s7_int n) { @@ -100607,7 +100470,7 @@ static void init_rootlet(s7_scheme *sc) sc->asinh_symbol = defun("asinh", asinh, 1, 0, false); sc->acosh_symbol = defun("acosh", acosh, 1, 0, false); sc->atanh_symbol = defun("atanh", atanh, 1, 0, false); - sc->sqrt_symbol = defun("sqrt", sqrt, 1, 0, false); + sc->sqrt_symbol = s7_define_typed_function(sc, "sqrt", g_sqrt, 1, 0, false, "(sqrt z) returns the square root of z", sc->pl_nn); sc->floor_symbol = defun("floor", floor, 1, 0, false); set_is_translucent(sc->floor_symbol); sc->ceiling_symbol = defun("ceiling", ceiling, 1, 0, false); set_is_translucent(sc->ceiling_symbol); sc->truncate_symbol = defun("truncate", truncate, 1, 0, false); set_is_translucent(sc->truncate_symbol); diff --git a/src/s7_r7rs.c b/src/s7_r7rs.c index dfdddba7..116a0726 100644 --- a/src/s7_r7rs.c +++ b/src/s7_r7rs.c @@ -6,13 +6,112 @@ * Bill Schottstaedt, bil@ccrma.stanford.edu */ +#ifndef HAVE_COMPLEX_NUMBERS + #if __TINYC__ || (__clang__ && __cplusplus) + #define HAVE_COMPLEX_NUMBERS 0 + #else + #define HAVE_COMPLEX_NUMBERS 1 + #endif +#endif + #include "s7_r7rs.h" #include #include +#include #if WITH_R7RS /* R7RS Scheme code string */ const char r7rs_scm[] = ""; +/* -------------------------------- sqrt -------------------------------- */ +/* Helper to check if a double is NaN */ +static bool is_nan(double x) +{ + return x != x; +} + +/* Helper to create complex number with 0 imaginary part optimized */ +static s7_pointer make_complex_not_0i(s7_scheme *sc, double r, double i) +{ + if (i == 0.0) return s7_make_real(sc, r); + return s7_make_complex(sc, r, i); +} + +s7_pointer sqrt_p_p(s7_scheme *sc, s7_pointer num) +{ + if (s7_is_integer(num)) + { + s7_int iv = s7_integer(num); + if (iv >= 0) + { + double sqx = sqrt((double)iv); + s7_int ix = (s7_int)sqx; + if ((ix * ix) == iv) + return s7_make_integer(sc, ix); + return s7_make_real(sc, sqx); + } +#if HAVE_COMPLEX_NUMBERS + return make_complex_not_0i(sc, 0.0, sqrt((double)(-iv))); +#else + return s7_out_of_range_error(sc, "sqrt", 1, num, "no complex numbers"); +#endif + } + + if (s7_is_rational(num) && !s7_is_integer(num)) + { + s7_int numr = s7_numerator(num); + if (numr > 0) + { + s7_int nm = (s7_int)sqrt((double)numr); + if (nm * nm == numr) + { + s7_int den = s7_denominator(num); + s7_int dn = (s7_int)sqrt((double)den); + if (dn * dn == den) + return s7_make_ratio(sc, nm, dn); + } + double frac = (double)numr / (double)s7_denominator(num); + return s7_make_real(sc, sqrt(frac)); + } +#if HAVE_COMPLEX_NUMBERS + double frac = (double)numr / (double)s7_denominator(num); + return s7_make_complex(sc, 0.0, sqrt(-frac)); +#else + return s7_out_of_range_error(sc, "sqrt", 1, num, "no complex numbers"); +#endif + } + + if (s7_is_real(num)) + { + double rv = s7_real(num); + if (is_nan(rv)) return num; + if (rv >= 0.0) + return s7_make_real(sc, sqrt(rv)); + return make_complex_not_0i(sc, 0.0, sqrt(-rv)); + } + + if (s7_is_complex(num)) + { +#if HAVE_COMPLEX_NUMBERS + double r = s7_real_part(num); + double i = s7_imag_part(num); + s7_complex z = r + i * _Complex_I; + s7_complex result = csqrt(z); + return s7_make_complex(sc, creal(result), cimag(result)); +#else + return s7_out_of_range_error(sc, "sqrt", 1, num, "no complex numbers"); +#endif + } + + return s7_wrong_type_arg_error(sc, "sqrt", 1, num, "a number"); +} + +s7_pointer g_sqrt(s7_scheme *sc, s7_pointer args) +{ + #define H_sqrt "(sqrt z) returns the square root of z" + #define Q_sqrt sc->pl_nn + return(sqrt_p_p(sc, s7_car(args))); +} + #endif /* WITH_R7RS */ diff --git a/src/s7_r7rs.h b/src/s7_r7rs.h index 674d95ce..e918b5cc 100644 --- a/src/s7_r7rs.h +++ b/src/s7_r7rs.h @@ -17,10 +17,11 @@ extern "C" { /* R7RS specific symbols */ extern s7_pointer unlink_symbol, access_symbol, time_symbol, clock_gettime_symbol, - getenvs_symbol, uname_symbol; + getenvs_symbol, uname_symbol, sqrt_symbol; /* R7RS specific function declarations */ -s7_pointer g_getenvs(s7_scheme *sc, s7_pointer args); +s7_pointer g_sqrt(s7_scheme *sc, s7_pointer args); +s7_pointer sqrt_p_p(s7_scheme *sc, s7_pointer num); /* R7RS Scheme code string */ extern const char r7rs_scm[]; From bf114063830e61a68f03e64510b84fba1e6db329 Mon Sep 17 00:00:00 2001 From: Da Shen Date: Sat, 14 Feb 2026 00:14:44 +0800 Subject: [PATCH 2/3] =?UTF-8?q?[200=5F21]=20=E5=B0=86=20is=5FNaN=20?= =?UTF-8?q?=E5=87=BD=E6=95=B0=E4=BB=8E=20s7.c=20=E8=BF=81=E7=A7=BB?= =?UTF-8?q?=E5=88=B0=20s7=5Fr7rs.h/c?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/s7.c | 2 +- src/s7_r7rs.c | 20 +++++++++++++------- src/s7_r7rs.h | 3 +++ 3 files changed, 17 insertions(+), 8 deletions(-) diff --git a/src/s7.c b/src/s7.c index 2e37fc71..6749c882 100644 --- a/src/s7.c +++ b/src/s7.c @@ -13197,7 +13197,7 @@ static bool is_positive(s7_scheme *sc, s7_pointer x); static bool is_negative(s7_scheme *sc, s7_pointer x); static s7_pointer make_ratio(s7_scheme *sc, s7_int a, s7_int b); -static bool is_NaN(s7_double x) {return(x != x);} +/* is_NaN is declared in s7_r7rs.h and defined in s7_r7rs.c */ /* callgrind says this is faster than isnan, I think (very confusing data...) */ #if defined(__sun) && defined(__SVR4) diff --git a/src/s7_r7rs.c b/src/s7_r7rs.c index 116a0726..e1153b90 100644 --- a/src/s7_r7rs.c +++ b/src/s7_r7rs.c @@ -6,11 +6,17 @@ * Bill Schottstaedt, bil@ccrma.stanford.edu */ -#ifndef HAVE_COMPLEX_NUMBERS - #if __TINYC__ || (__clang__ && __cplusplus) +#ifdef _MSC_VER + #ifndef HAVE_COMPLEX_NUMBERS #define HAVE_COMPLEX_NUMBERS 0 - #else - #define HAVE_COMPLEX_NUMBERS 1 + #endif +#else + #ifndef HAVE_COMPLEX_NUMBERS + #if __TINYC__ || (__clang__ && __cplusplus) + #define HAVE_COMPLEX_NUMBERS 0 + #else + #define HAVE_COMPLEX_NUMBERS 1 + #endif #endif #endif @@ -25,8 +31,8 @@ const char r7rs_scm[] = ""; /* -------------------------------- sqrt -------------------------------- */ -/* Helper to check if a double is NaN */ -static bool is_nan(double x) +/* Helper function to check for NaN */ +bool is_NaN(s7_double x) { return x != x; } @@ -85,7 +91,7 @@ s7_pointer sqrt_p_p(s7_scheme *sc, s7_pointer num) if (s7_is_real(num)) { double rv = s7_real(num); - if (is_nan(rv)) return num; + if (is_NaN(rv)) return num; if (rv >= 0.0) return s7_make_real(sc, sqrt(rv)); return make_complex_not_0i(sc, 0.0, sqrt(-rv)); diff --git a/src/s7_r7rs.h b/src/s7_r7rs.h index e918b5cc..3fb50e08 100644 --- a/src/s7_r7rs.h +++ b/src/s7_r7rs.h @@ -23,6 +23,9 @@ extern s7_pointer unlink_symbol, access_symbol, time_symbol, clock_gettime_symbo s7_pointer g_sqrt(s7_scheme *sc, s7_pointer args); s7_pointer sqrt_p_p(s7_scheme *sc, s7_pointer num); +/* Helper function to check for NaN */ +bool is_NaN(s7_double x); + /* R7RS Scheme code string */ extern const char r7rs_scm[]; From 51faf17ad156cfc3d4aa6b5c1066cadf31b0306a Mon Sep 17 00:00:00 2001 From: Da Shen Date: Sat, 14 Feb 2026 00:19:51 +0800 Subject: [PATCH 3/3] =?UTF-8?q?[200=5F21]=20=E6=B8=85=E7=90=86=20s7=5Fr7rs?= =?UTF-8?q?.h/c=EF=BC=8C=E7=A7=BB=E9=99=A4=E5=A4=9A=E4=BD=99=E7=9A=84?= =?UTF-8?q?=E6=9D=A1=E4=BB=B6=E7=BC=96=E8=AF=91=E5=92=8C=E7=AC=A6=E5=8F=B7?= =?UTF-8?q?=E5=A3=B0=E6=98=8E?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/s7_r7rs.c | 4 ---- src/s7_r7rs.h | 12 ++++-------- 2 files changed, 4 insertions(+), 12 deletions(-) diff --git a/src/s7_r7rs.c b/src/s7_r7rs.c index e1153b90..83d59b71 100644 --- a/src/s7_r7rs.c +++ b/src/s7_r7rs.c @@ -25,8 +25,6 @@ #include #include -#if WITH_R7RS - /* R7RS Scheme code string */ const char r7rs_scm[] = ""; @@ -119,5 +117,3 @@ s7_pointer g_sqrt(s7_scheme *sc, s7_pointer args) #define Q_sqrt sc->pl_nn return(sqrt_p_p(sc, s7_car(args))); } - -#endif /* WITH_R7RS */ diff --git a/src/s7_r7rs.h b/src/s7_r7rs.h index 3fb50e08..7b5e44e2 100644 --- a/src/s7_r7rs.h +++ b/src/s7_r7rs.h @@ -15,16 +15,12 @@ extern "C" { #endif -/* R7RS specific symbols */ -extern s7_pointer unlink_symbol, access_symbol, time_symbol, clock_gettime_symbol, - getenvs_symbol, uname_symbol, sqrt_symbol; +/* Helper function to check for NaN */ +bool is_NaN(s7_double x); /* R7RS specific function declarations */ -s7_pointer g_sqrt(s7_scheme *sc, s7_pointer args); s7_pointer sqrt_p_p(s7_scheme *sc, s7_pointer num); - -/* Helper function to check for NaN */ -bool is_NaN(s7_double x); +s7_pointer g_sqrt(s7_scheme *sc, s7_pointer args); /* R7RS Scheme code string */ extern const char r7rs_scm[]; @@ -33,4 +29,4 @@ extern const char r7rs_scm[]; } #endif -#endif /* S7_R7RS_H */ \ No newline at end of file +#endif /* S7_R7RS_H */