[200_39] gf test

.github/workflows/ci-debian.yml

@@ -69,5 +69,5 @@ jobs:
       - name: build
         run: xmake build --yes -vD goldfish
       - name: run tests
-        run: bin/gf tests/test_all.scm
+        run: bin/gf test
 

.github/workflows/ci-fedora.yml

@@ -65,5 +65,5 @@ jobs:
         run: xmake build --yes -vD goldfish
 
       - name: run tests
-        run: bin/gf tests/test_all.scm
+        run: bin/gf test
 

.github/workflows/ci-macos.yml

@@ -63,5 +63,5 @@ jobs:
         run: xmake build --yes -vD goldfish
 
       - name: run tests
-        run: bin/gf tests/test_all.scm
+        run: bin/gf test
 

.github/workflows/ci-windows.yml

@@ -45,5 +45,5 @@ jobs:
       - name: build
         run: xmake build --yes -vD goldfish
       - name: test
-        run: bin/gf tests/test_all.scm
+        run: bin/gf test
 

src/goldfish.hpp

@@ -3365,6 +3365,7 @@ display_help () {
   cout << "  fix [options] PATH Format PATH (PATH can be a .scm file or directory)" << endl;
   cout << "                     Options:" << endl;
   cout << "                       --dry-run  Print formatted result to stdout" << endl;
+  cout << "  test               Run tests (all *-test.scm files under tests/)" << endl;
 #ifdef GOLDFISH_WITH_REPL
   cout << "  repl               Enter interactive REPL mode" << endl;
 #endif
@@ -3507,6 +3508,21 @@ find_goldfix_tool_root (const char* gf_lib) {
   return "";
 }
 
+static string
+find_goldtest_tool_root (const char* gf_lib) {
+  std::error_code ec;
+  vector<fs::path> candidates= {fs::path (gf_lib) / "tests" / "goldtest", fs::path (gf_lib).parent_path () / "tests" / "goldtest"};
+
+  for (const auto& candidate : candidates) {
+    if (fs::is_directory (candidate, ec)) {
+      return candidate.string ();
+    }
+    ec.clear ();
+  }
+
+  return "";
+}
+
 static void
 add_goldfix_load_path_if_present (s7_scheme* sc, const char* gf_lib) {
   string tool_root= find_goldfix_tool_root (gf_lib);
@@ -4454,6 +4470,56 @@ repl_for_community_edition (s7_scheme* sc, int argc, char** argv) {
 #endif
   }
 
+  // 处理 test 子命令
+  if (command == "test") {
+    // 添加 tests/goldtest 目录到 load path (用于加载 (liii goldtest) 模块)
+    string goldtest_root = find_goldtest_tool_root (gf_lib);
+    if (goldtest_root.empty ()) {
+      cerr << "Error: tests/goldtest directory not found." << endl;
+      s7_close_output_port (sc, s7_current_error_port (sc));
+      s7_set_current_error_port (sc, old_port);
+      if (gc_loc != -1) s7_gc_unprotect_at (sc, gc_loc);
+      exit (1);
+    }
+    s7_add_to_load_path (sc, goldtest_root.c_str ());
+
+    // Load the goldtest.scm file
+    string goldtest_scm = goldtest_root + "/liii/goldtest.scm";
+    s7_pointer load_result = s7_load (sc, goldtest_scm.c_str ());
+    if (!load_result) {
+      cerr << "Error: Failed to load " << goldtest_scm << endl;
+      s7_close_output_port (sc, s7_current_error_port (sc));
+      s7_set_current_error_port (sc, old_port);
+      if (gc_loc != -1) s7_gc_unprotect_at (sc, gc_loc);
+      exit (1);
+    }
+    errmsg = s7_get_output_string (sc, s7_current_error_port (sc));
+    if ((errmsg) && (*errmsg)) {
+      cerr << "Error loading goldtest.scm: " << errmsg << endl;
+      s7_close_output_port (sc, s7_current_error_port (sc));
+      s7_set_current_error_port (sc, old_port);
+      if (gc_loc != -1) s7_gc_unprotect_at (sc, gc_loc);
+      exit (1);
+    }
+
+    // Get the run-goldtest function
+    s7_pointer run_goldtest = s7_name_to_value (sc, "run-goldtest");
+    if ((!run_goldtest) || (!s7_is_procedure (run_goldtest))) {
+      cerr << "Error: Failed to find run-goldtest function." << endl;
+      s7_close_output_port (sc, s7_current_error_port (sc));
+      s7_set_current_error_port (sc, old_port);
+      if (gc_loc != -1) s7_gc_unprotect_at (sc, gc_loc);
+      exit (1);
+    }
+    s7_call (sc, run_goldtest, s7_nil (sc));
+    errmsg = s7_get_output_string (sc, s7_current_error_port (sc));
+    if ((errmsg) && (*errmsg)) cout << errmsg;
+    s7_close_output_port (sc, s7_current_error_port (sc));
+    s7_set_current_error_port (sc, old_port);
+    if (gc_loc != -1) s7_gc_unprotect_at (sc, gc_loc);
+    return 0;
+  }
+
   // 处理直接执行文件（以 .scm 结尾或存在的文件）
   // 检查是否是文件
   std::error_code ec;

tests/goldfish/liii/http-test.scm

@@ -1,6 +1,7 @@
 (import (liii check)
         (liii http)
         (liii string)
+        (liii os)
         (liii rich-json)
         (only (liii lang) display*)
         (only (liii base) let1)
@@ -9,6 +10,10 @@
 
 (check-set-mode! 'report-failed)
 
+(let ((env (getenv "GOLDFISH_TEST_HTTP")))
+  (when (not env) (exit 0))
+) ;let
+
 (let1 r (http-head "https://httpbin.org")
   (check (r 'status-code) => 200)
   (check (r 'url) => "https://httpbin.org/")

tests/goldfish/srfi/srfi-78-simple-stacktrace-test.scm

@@ -1,9 +1,15 @@
-(import (liii check))
+(import (liii check)
+        (liii os)
+) ;import
 
-;; Simple test for stacktrace display on failure
-(check-set-mode! 'report-failed)
+;; Only run this test when GOLDFISH_TEST_STACKTRACE is set
+(when (let ((env (getenv "GOLDFISH_TEST_STACKTRACE")))
+        (and env (not (equal? env "0"))))
+  ;; Simple test for stacktrace display on failure
+  (check-set-mode! 'report-failed)
 
-;; Test basic failure
-(check (+ 1 1) => 3)  ; Should show stacktrace
+  ;; Test basic failure
+  (check (+ 1 1) => 3)  ; Should show stacktrace
 
-(check-report)
+  (check-report)
+) ;when

tests/goldtest/liii/goldtest.scm

@@ -0,0 +1,151 @@
+
+;
+; Copyright (C) 2024 The Goldfish Scheme Authors
+;
+; Licensed under the Apache License, Version 2.0 (the "License");
+; you may not use this file except in compliance with the License.
+; You may obtain a copy of the License at
+;
+; http://www.apache.org/licenses/LICENSE-2.0
+;
+; Unless required by applicable law or agreed to in writing, software
+; distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
+; WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
+; License for the specific language governing permissions and limitations
+; under the License.
+;
+
+(import (scheme base)
+        (liii sort)
+        (liii list)
+        (liii string)
+        (liii os)
+        (liii path)
+        (liii sys)
+) ;import
+
+(define ESC (string #\escape #\[))
+
+(define (color code)
+  (string-append ESC (number->string code) "m")
+) ;define
+
+(define GREEN (color 32))
+(define RED (color 31))
+(define YELLOW (color 33))
+(define RESET (color 0))
+
+(define (test-path-join . parts)
+  (let ((sep (string (os-sep))))
+    (let loop ((result "")
+               (rest parts))
+      (if (null? rest)
+        result
+        (let ((part (car rest)))
+          (if (string-null? result)
+            (loop part (cdr rest))
+            (loop (string-append result sep part) (cdr rest))
+          ) ;if
+        ) ;let
+      ) ;if
+    ) ;let
+  ) ;let
+) ;define
+
+(define (find-test-files dir)
+  (let ((files '()))
+    (when (path-dir? dir)
+      (let ((entries (listdir dir)))
+        (for-each
+          (lambda (entry)
+            (let ((full-path (test-path-join dir entry)))
+              (cond
+                ((path-dir? full-path)
+                 (set! files (append files (find-test-files full-path)))
+                ) ;
+                ((and (path-file? full-path)
+                      (string-ends? entry "-test.scm"))
+                 (set! files (cons full-path files))
+                ) ;
+              ) ;cond
+            ) ;let
+          ) ;lambda
+          entries
+        ) ;for-each
+      ) ;let
+    ) ;when
+    files
+  ) ;let
+) ;define
+
+(define (goldfish-cmd)
+  (string-append (executable) " -m r7rs ")
+) ;define
+
+(define (run-test-file test-file)
+  (let ((cmd (string-append (goldfish-cmd) test-file)))
+    (display "----------->") (newline)
+    (display cmd) (newline)
+    (let ((result (os-call cmd)))
+      (cons test-file result)
+    ) ;let
+  ) ;let
+) ;define
+
+(define (display-summary test-results)
+  (let ((total (length test-results))
+        (passed (count (lambda (x) (zero? (cdr x))) test-results))
+        (failed (- (length test-results)
+                   (count (lambda (x) (zero? (cdr x))) test-results)))
+        ) ;failed
+    (newline)
+    (display "=== Test Summary ===") (newline)
+    (newline)
+    (for-each
+      (lambda (test-result)
+        (let ((test-file (car test-result))
+              (exit-code (cdr test-result)))
+          (display (string-append "  " test-file " ... "))
+          (if (zero? exit-code)
+            (display (string-append GREEN "PASS" RESET))
+            (display (string-append RED "FAIL" RESET))
+          ) ;if
+          (newline)
+        ) ;let
+      ) ;lambda
+      test-results
+    ) ;for-each
+    (newline)
+    (display "=== Summary ===") (newline)
+    (display (string-append "  Total:  " (number->string total))) (newline)
+    (display (string-append "  " GREEN "Passed: " (number->string passed) RESET)) (newline)
+    (when (> failed 0)
+      (display (string-append "  " RED "Failed: " (number->string failed) RESET)) (newline)
+    ) ;when
+    (newline)
+    failed
+  ) ;let
+) ;define
+
+(define (run-goldtest)
+  (let ((test-files (list-sort string<? (find-test-files "tests"))))
+    (if (null? test-files)
+      (begin
+        (display (string-append YELLOW "No test files found in tests directory" RESET))
+        (newline)
+        (exit 0)
+      ) ;begin
+      (let ((test-results
+              (fold (lambda (test-file acc)
+                      (newline)
+                      (cons (run-test-file test-file) acc))
+                    (list)
+                    test-files))
+              ) ;fold
+        (let ((failed (display-summary test-results)))
+          (exit (if (> failed 0) -1 0))
+        ) ;let
+      ) ;let
+    ) ;if
+  ) ;let
+) ;define