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..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) @@ -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..83d59b71 100644 --- a/src/s7_r7rs.c +++ b/src/s7_r7rs.c @@ -6,13 +6,114 @@ * Bill Schottstaedt, bil@ccrma.stanford.edu */ +#ifdef _MSC_VER + #ifndef HAVE_COMPLEX_NUMBERS + #define HAVE_COMPLEX_NUMBERS 0 + #endif +#else + #ifndef HAVE_COMPLEX_NUMBERS + #if __TINYC__ || (__clang__ && __cplusplus) + #define HAVE_COMPLEX_NUMBERS 0 + #else + #define HAVE_COMPLEX_NUMBERS 1 + #endif + #endif +#endif + #include "s7_r7rs.h" #include #include - -#if WITH_R7RS +#include /* R7RS Scheme code string */ const char r7rs_scm[] = ""; -#endif /* WITH_R7RS */ +/* -------------------------------- sqrt -------------------------------- */ +/* Helper function to check for NaN */ +bool is_NaN(s7_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))); +} diff --git a/src/s7_r7rs.h b/src/s7_r7rs.h index 674d95ce..7b5e44e2 100644 --- a/src/s7_r7rs.h +++ b/src/s7_r7rs.h @@ -15,12 +15,12 @@ extern "C" { #endif -/* R7RS specific symbols */ -extern s7_pointer unlink_symbol, access_symbol, time_symbol, clock_gettime_symbol, - getenvs_symbol, uname_symbol; +/* Helper function to check for NaN */ +bool is_NaN(s7_double x); /* R7RS specific function declarations */ -s7_pointer g_getenvs(s7_scheme *sc, s7_pointer args); +s7_pointer sqrt_p_p(s7_scheme *sc, s7_pointer num); +s7_pointer g_sqrt(s7_scheme *sc, s7_pointer args); /* R7RS Scheme code string */ extern const char r7rs_scm[]; @@ -29,4 +29,4 @@ extern const char r7rs_scm[]; } #endif -#endif /* S7_R7RS_H */ \ No newline at end of file +#endif /* S7_R7RS_H */