[200_21] 将 sqrt 从 s7.c 迁移至 s7_r7rs.c

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

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);

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 <string.h>
 #include <time.h>
-
-#if WITH_R7RS
+#include <math.h>
 
 /* 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)));
+}

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 */
+#endif /* S7_R7RS_H */