From 213e43f9eafe32a632ee737edcd5b3677c7d5c47 Mon Sep 17 00:00:00 2001 From: Da Shen Date: Sat, 21 Mar 2026 12:57:11 +0800 Subject: [PATCH 01/11] wip --- src/goldfish.hpp | 66 ++++++++++++ tests/goldtest/liii/goldtest.scm | 167 +++++++++++++++++++++++++++++++ tools/goldtest/liii/goldtest.scm | 138 +++++++++++++++++++++++++ xmake.lua | 1 + 4 files changed, 372 insertions(+) create mode 100644 tests/goldtest/liii/goldtest.scm create mode 100644 tools/goldtest/liii/goldtest.scm diff --git a/src/goldfish.hpp b/src/goldfish.hpp index adadcfbb..91fcfa25 100644 --- a/src/goldfish.hpp +++ b/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 (tests/test_all.scm or all *-test.scm files)" << 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 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; diff --git a/tests/goldtest/liii/goldtest.scm b/tests/goldtest/liii/goldtest.scm new file mode 100644 index 00000000..bc4669ac --- /dev/null +++ b/tests/goldtest/liii/goldtest.scm @@ -0,0 +1,167 @@ + +; +; 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) +) ;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 (http-test-enabled?) + (let ((env-var (getenv "GOLDFISH_TEST_HTTP"))) + (and env-var (not (equal? env-var "0"))) + ) ;let +) ;define + +(define (should-run-test? entry) + (if (string-contains entry "http-test") + (http-test-enabled?) + #t + ) ;if +) ;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") + (should-run-test? entry)) + (set! files (cons full-path files)) + ) ; + ) ;cond + ) ;let + ) ;lambda + entries + ) ;for-each + ) ;let + ) ;when + files + ) ;let +) ;define + +(define (goldfish-cmd) + (if (os-windows?) + "bin\\gf -m r7rs " + "bin/gf -m r7rs " + ) ;if +) ;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 failed 0) -1 0)) + ) ;let + ) ;let + ) ;if + ) ;let +) ;define diff --git a/tools/goldtest/liii/goldtest.scm b/tools/goldtest/liii/goldtest.scm new file mode 100644 index 00000000..868e66f1 --- /dev/null +++ b/tools/goldtest/liii/goldtest.scm @@ -0,0 +1,138 @@ + +; +; 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. +; + +(define-library (liii goldtest) + (export run-goldtest) + (import (scheme base) + (scheme process-context) + (liii list) + (liii string) + (liii os) + (liii path)) + (begin + + (define ESC (string #\escape #\[)) + + (define (color code) + (string-append ESC (number->string code) "m")) + + (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))))))) + + (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-with? entry "-test.scm")) + (set! files (cons full-path files)))))) + entries))) + files)) + + (define (goldfish-cmd) + (if (os-windows?) + "bin\\gf -m r7rs " + "bin/gf -m r7rs ")) + + (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)))) + + (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)))) + (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))) + (newline))) + test-results) + (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)) + (newline) + failed)) + + (define (run-goldtest) + (let ((test-all-path (test-path-join "tests" "test_all.scm"))) + (if (path-file? test-all-path) + ; 如果存在 test_all.scm，则运行它 + (begin + (display (string-append YELLOW "Found test_all.scm, running it..." RESET)) + (newline) + (newline) + (let ((cmd (string-append (goldfish-cmd) test-all-path))) + (display cmd) (newline) + (let ((result (os-call cmd))) + (newline) + (display "=== Summary ===") (newline) + (display " test_all.scm ... ") + (if (zero? result) + (display (string-append GREEN "PASS" RESET)) + (display (string-append RED "FAIL" RESET))) + (newline) + (exit result)))) + ; 否则运行所有 xxx-test.scm 文件 + (let ((test-files (sort (find-test-files "tests") string failed 0) -1 0))))))))) +) diff --git a/xmake.lua b/xmake.lua index 3653b805..5453d0b5 100644 --- a/xmake.lua +++ b/xmake.lua @@ -160,6 +160,7 @@ target ("goldfish") do add_installfiles("$(projectdir)/goldfish/(guenchi/*.scm)", {prefixdir = "share/goldfish"}) add_installfiles("$(projectdir)/tools/goldfix/main.scm", {prefixdir = "share/goldfish/tools/goldfix"}) add_installfiles("$(projectdir)/tools/goldfix/(liii/*.scm)", {prefixdir = "share/goldfish/tools/goldfix"}) + add_installfiles("$(projectdir)/tools/liii/goldtest.scm", {prefixdir = "share/goldfish/tools/liii"}) end if is_plat("wasm") then From 68b7a7c7bb15e54bb9e160da352128ead02a6eb7 Mon Sep 17 00:00:00 2001 From: Da Shen Date: Sat, 21 Mar 2026 13:00:57 +0800 Subject: [PATCH 02/11] =?UTF-8?q?[200=5F39]=20=E6=96=B0=E5=A2=9E=20gf=20te?= =?UTF-8?q?st=20=E5=AD=90=E5=91=BD=E4=BB=A4=E5=92=8C=E6=B5=8B=E8=AF=95?= =?UTF-8?q?=E7=9B=B8=E5=85=B3=E6=94=B9=E8=BF=9B?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - 新增 gf test 子命令，自动运行 tests 目录下所有 *-test.scm 文件 - 添加 tests/goldtest/liii/goldtest.scm 测试运行器 - test 命令使用 (liii sys) 中的 (executable) 获取可执行路径 - 添加 http-test 和 srfi-78-simple-stacktrace-test 环境变量控制 - GOLDFISH_TEST_HTTP 控制 http 测试 - GOLDFISH_TEST_STACKTRACE 控制 stacktrace 测试 - 默认关闭上述测试，需要设置环境变量才运行 Co-Authored-By: Claude Opus 4.6 --- .../srfi/srfi-78-simple-stacktrace-test.scm | 18 ++- tests/goldtest/liii/goldtest.scm | 6 +- tests/test_all.scm | 124 ------------------ 3 files changed, 14 insertions(+), 134 deletions(-) delete mode 100644 tests/test_all.scm diff --git a/tests/goldfish/srfi/srfi-78-simple-stacktrace-test.scm b/tests/goldfish/srfi/srfi-78-simple-stacktrace-test.scm index da27faea..43931d39 100644 --- a/tests/goldfish/srfi/srfi-78-simple-stacktrace-test.scm +++ b/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) \ No newline at end of file + (check-report) +) ;when \ No newline at end of file diff --git a/tests/goldtest/liii/goldtest.scm b/tests/goldtest/liii/goldtest.scm index bc4669ac..b3a6760e 100644 --- a/tests/goldtest/liii/goldtest.scm +++ b/tests/goldtest/liii/goldtest.scm @@ -21,6 +21,7 @@ (liii string) (liii os) (liii path) + (liii sys) ) ;import (define ESC (string #\escape #\[)) @@ -92,10 +93,7 @@ ) ;define (define (goldfish-cmd) - (if (os-windows?) - "bin\\gf -m r7rs " - "bin/gf -m r7rs " - ) ;if + (string-append (executable) " -m r7rs ") ) ;define (define (run-test-file test-file) diff --git a/tests/test_all.scm b/tests/test_all.scm deleted file mode 100644 index 8135adfe..00000000 --- a/tests/test_all.scm +++ /dev/null @@ -1,124 +0,0 @@ -; -; 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 (liii list) - (liii string) - (liii os) - (liii path) -) ;import - -(define enable-http-tests? - (let ((env-var (getenv "GOLDFISH_TEST_HTTP"))) - (and env-var (not (equal? env-var "0"))) - ) ;let -) ;define - -(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 level1-tests - (let* ((test-root (test-path-join "tests" "goldfish")) - (subdirs (filter path-dir? (map (lambda (x) (test-path-join test-root x)) - (listdir test-root))) - ) ;subdirs - (all-files (flat-map (lambda (dir) - (map (lambda (f) (test-path-join dir f)) - (listdir dir)) - ) ;map - subdirs) - ) ;all-files - (test-files (filter path-file? all-files))) - (filter (lambda (file-path) - (and (not (string-contains file-path "srfi-78")) - (or enable-http-tests? - (not (string-contains file-path "http-test"))) - ) ;or - ) ;and - test-files - ) ;filter - ) ;let* -) ;define - -(define (all-tests) - level1-tests -) ;define - -(define (goldfish-cmd) - (if (os-windows?) - "bin\\gf -m r7rs " - "bin/gf -m r7rs " - ) ;if -) ;define - -(define ESC (string #\escape #\[)) -(define (color code) - (string-append ESC - (number->string code) - "m" - ) ;string-append -) ;define - -(define GREEN (color 32)) -(define RED (color 31)) -(define RESET (color 0)) - -(let ((test-results - (fold (lambda (test-file acc) - (let ((cmd (string-append (goldfish-cmd) test-file))) - (newline) - (display "----------->") (newline) - (display cmd) (newline) - (let ((result (os-call cmd))) - (cons (cons cmd result) acc)) - ) ;let - ) ;let - (list) - (all-tests))) - ) ;fold - (newline) - (display "=== Summary ===") (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 - (when (any (lambda (x) (not (zero? (cdr x)))) test-results) - (exit -1) - ) ;when -) ;let From 2504d0a917223162cb9745b399ff0f92b81307db Mon Sep 17 00:00:00 2001 From: Da Shen Date: Sat, 21 Mar 2026 13:05:42 +0800 Subject: [PATCH 03/11] =?UTF-8?q?[200=5F39]=20=E6=9B=B4=E6=96=B0=20CI=20?= =?UTF-8?q?=E9=85=8D=E7=BD=AE=E4=BD=BF=E7=94=A8=20gf=20test=20=E5=AD=90?= =?UTF-8?q?=E5=91=BD=E4=BB=A4?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - 将 GitHub Actions 中的测试命令从 bin/gf tests/test_all.scm 改为 bin/gf test - 更新 test 子命令帮助描述 Co-Authored-By: Claude Opus 4.6 --- .github/workflows/ci-debian.yml | 2 +- .github/workflows/ci-fedora.yml | 2 +- .github/workflows/ci-macos.yml | 2 +- .github/workflows/ci-windows.yml | 2 +- src/goldfish.hpp | 2 +- 5 files changed, 5 insertions(+), 5 deletions(-) diff --git a/.github/workflows/ci-debian.yml b/.github/workflows/ci-debian.yml index f475189a..568cbc3a 100644 --- a/.github/workflows/ci-debian.yml +++ b/.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 diff --git a/.github/workflows/ci-fedora.yml b/.github/workflows/ci-fedora.yml index 9358cc31..a1dd76c7 100644 --- a/.github/workflows/ci-fedora.yml +++ b/.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 diff --git a/.github/workflows/ci-macos.yml b/.github/workflows/ci-macos.yml index c747cf71..a0eaebe8 100644 --- a/.github/workflows/ci-macos.yml +++ b/.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 diff --git a/.github/workflows/ci-windows.yml b/.github/workflows/ci-windows.yml index fac0fa0a..379542f9 100644 --- a/.github/workflows/ci-windows.yml +++ b/.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 diff --git a/src/goldfish.hpp b/src/goldfish.hpp index 91fcfa25..46194bd5 100644 --- a/src/goldfish.hpp +++ b/src/goldfish.hpp @@ -3365,7 +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 (tests/test_all.scm or all *-test.scm files)" << endl; + cout << " test Run tests (all *-test.scm files under tests/)" << endl; #ifdef GOLDFISH_WITH_REPL cout << " repl Enter interactive REPL mode" << endl; #endif From 93249677bcdf5481c63e282eeee0d6f041d2a79e Mon Sep 17 00:00:00 2001 From: Da Shen Date: Sat, 21 Mar 2026 13:13:21 +0800 Subject: [PATCH 04/11] =?UTF-8?q?[200=5F39]=20=E5=AE=8C=E5=96=84=20goldtes?= =?UTF-8?q?t.scm=20=E7=8E=AF=E5=A2=83=E5=8F=98=E9=87=8F=E6=8E=A7=E5=88=B6?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - 添加 stacktrace-test-enabled? 函数 - 更新 should-run-test? 使用 cond 同时检查 http-test 和 srfi-78-simple-stacktrace 测试 - 格式化 goldtest.scm Co-Authored-By: Claude Opus 4.6 --- tests/goldtest/liii/goldtest.scm | 21 +++++++++++++++++---- 1 file changed, 17 insertions(+), 4 deletions(-) diff --git a/tests/goldtest/liii/goldtest.scm b/tests/goldtest/liii/goldtest.scm index b3a6760e..2b09a867 100644 --- a/tests/goldtest/liii/goldtest.scm +++ b/tests/goldtest/liii/goldtest.scm @@ -58,11 +58,24 @@ ) ;let ) ;define +(define (stacktrace-test-enabled?) + (let ((env-var (getenv "GOLDFISH_TEST_STACKTRACE"))) + (and env-var (not (equal? env-var "0"))) + ) ;let +) ;define + (define (should-run-test? entry) - (if (string-contains entry "http-test") - (http-test-enabled?) - #t - ) ;if + (cond + ((string-contains entry "http-test") + (http-test-enabled?) + ) ; + ((string-contains entry "srfi-78-simple-stacktrace") + (stacktrace-test-enabled?) + ) ; + (else + #t + ) ;else + ) ;cond ) ;define (define (find-test-files dir) From 3aa7853eb65ab4d0e3f6c0691b2f3f0a0a736caa Mon Sep 17 00:00:00 2001 From: Da Shen Date: Sat, 21 Mar 2026 13:15:50 +0800 Subject: [PATCH 05/11] =?UTF-8?q?[200=5F39]=20=E7=A7=BB=E9=99=A4=20goldtes?= =?UTF-8?q?t.scm=20=E4=B8=AD=E7=9A=84=E7=89=B9=E6=AE=8A=E5=88=A4=E6=96=AD?= =?UTF-8?q?=E9=80=BB=E8=BE=91?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - 移除 http-test-enabled?、stacktrace-test-enabled? 函数 - 移除 should-run-test? 特殊判断函数 - find-test-files 恢复为通用实现，运行所有 *-test.scm 文件 - 特殊测试控制逻辑放在测试文件本身处理 Co-Authored-By: Claude Opus 4.6 --- tests/goldtest/liii/goldtest.scm | 29 +---------------------------- 1 file changed, 1 insertion(+), 28 deletions(-) diff --git a/tests/goldtest/liii/goldtest.scm b/tests/goldtest/liii/goldtest.scm index 2b09a867..f14a16ec 100644 --- a/tests/goldtest/liii/goldtest.scm +++ b/tests/goldtest/liii/goldtest.scm @@ -52,32 +52,6 @@ ) ;let ) ;define -(define (http-test-enabled?) - (let ((env-var (getenv "GOLDFISH_TEST_HTTP"))) - (and env-var (not (equal? env-var "0"))) - ) ;let -) ;define - -(define (stacktrace-test-enabled?) - (let ((env-var (getenv "GOLDFISH_TEST_STACKTRACE"))) - (and env-var (not (equal? env-var "0"))) - ) ;let -) ;define - -(define (should-run-test? entry) - (cond - ((string-contains entry "http-test") - (http-test-enabled?) - ) ; - ((string-contains entry "srfi-78-simple-stacktrace") - (stacktrace-test-enabled?) - ) ; - (else - #t - ) ;else - ) ;cond -) ;define - (define (find-test-files dir) (let ((files '())) (when (path-dir? dir) @@ -90,8 +64,7 @@ (set! files (append files (find-test-files full-path))) ) ; ((and (path-file? full-path) - (string-ends? entry "-test.scm") - (should-run-test? entry)) + (string-ends? entry "-test.scm")) (set! files (cons full-path files)) ) ; ) ;cond From dc72b1547cd2b65c0e94c4fb308c388fcea7551d Mon Sep 17 00:00:00 2001 From: Da Shen Date: Sat, 21 Mar 2026 13:20:17 +0800 Subject: [PATCH 06/11] =?UTF-8?q?[200=5F39]=20=E4=BC=98=E5=8C=96=20goldtes?= =?UTF-8?q?t.scm=20=E4=BB=A3=E7=A0=81=E7=BB=93=E6=9E=84?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - test-path-join: let 改为 let* - find-test-files: 使用 flat-map 替代 set! 和 for-each - run-test-file: let 改为 let* - display-summary: let 改为 let*，简化 failed 计算 - run-goldtest: 使用 let* 合并嵌套 let Co-Authored-By: Claude Opus 4.6 --- tests/goldtest/liii/goldtest.scm | 106 ++++++++++++------------------- 1 file changed, 42 insertions(+), 64 deletions(-) diff --git a/tests/goldtest/liii/goldtest.scm b/tests/goldtest/liii/goldtest.scm index f14a16ec..26558f7d 100644 --- a/tests/goldtest/liii/goldtest.scm +++ b/tests/goldtest/liii/goldtest.scm @@ -36,7 +36,7 @@ (define RESET (color 0)) (define (test-path-join . parts) - (let ((sep (string (os-sep)))) + (let* ((sep (string (os-sep)))) (let loop ((result "") (rest parts)) (if (null? rest) @@ -53,51 +53,38 @@ ) ;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 + (if (path-dir? dir) + (let ((entries (listdir dir))) + (flat-map + (lambda (entry) + (let ((full-path (test-path-join dir entry))) + (cond + ((path-dir? full-path) + (find-test-files full-path)) + ((and (path-file? full-path) + (string-ends? entry "-test.scm")) + (list full-path)) + (else '())))) + entries)) + '())) (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 + (let* ((cmd (string-append (goldfish-cmd) test-file)) + (result (begin + (display "----------->") (newline) + (display cmd) (newline) + (os-call cmd)))) + (cons test-file result)) ) ;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 + (let* ((total (length test-results)) + (passed (count (lambda (x) (zero? (cdr x))) test-results)) + (failed (- total passed))) (newline) (display "=== Test Summary ===") (newline) (newline) @@ -108,44 +95,35 @@ (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 + (display (string-append RED "FAIL" RESET))) + (newline))) + test-results) (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 + (display (string-append " " RED "Failed: " (number->string failed) RESET)) (newline)) (newline) - failed - ) ;let + failed)) ) ;define (define (run-goldtest) - (let ((test-files (list-sort string failed 0) -1 0)) - ) ;let - ) ;let - ) ;if - ) ;let + (exit 0)) + (exit (if (> failed 0) -1 0)))) ) ;define From d36adcdc2a6fd9e831506962d804d60dc336f0ca Mon Sep 17 00:00:00 2001 From: Da Shen Date: Sat, 21 Mar 2026 13:22:24 +0800 Subject: [PATCH 07/11] =?UTF-8?q?Revert=20"[200=5F39]=20=E4=BC=98=E5=8C=96?= =?UTF-8?q?=20goldtest.scm=20=E4=BB=A3=E7=A0=81=E7=BB=93=E6=9E=84"?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This reverts commit dc72b1547cd2b65c0e94c4fb308c388fcea7551d. --- tests/goldtest/liii/goldtest.scm | 106 +++++++++++++++++++------------ 1 file changed, 64 insertions(+), 42 deletions(-) diff --git a/tests/goldtest/liii/goldtest.scm b/tests/goldtest/liii/goldtest.scm index 26558f7d..f14a16ec 100644 --- a/tests/goldtest/liii/goldtest.scm +++ b/tests/goldtest/liii/goldtest.scm @@ -36,7 +36,7 @@ (define RESET (color 0)) (define (test-path-join . parts) - (let* ((sep (string (os-sep)))) + (let ((sep (string (os-sep)))) (let loop ((result "") (rest parts)) (if (null? rest) @@ -53,38 +53,51 @@ ) ;define (define (find-test-files dir) - (if (path-dir? dir) - (let ((entries (listdir dir))) - (flat-map - (lambda (entry) - (let ((full-path (test-path-join dir entry))) - (cond - ((path-dir? full-path) - (find-test-files full-path)) - ((and (path-file? full-path) - (string-ends? entry "-test.scm")) - (list full-path)) - (else '())))) - entries)) - '())) + (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)) - (result (begin - (display "----------->") (newline) - (display cmd) (newline) - (os-call cmd)))) - (cons test-file result)) + (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 (- total passed))) + (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) @@ -95,35 +108,44 @@ (display (string-append " " test-file " ... ")) (if (zero? exit-code) (display (string-append GREEN "PASS" RESET)) - (display (string-append RED "FAIL" RESET))) - (newline))) - test-results) + (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)) + (display (string-append " " RED "Failed: " (number->string failed) RESET)) (newline) + ) ;when (newline) - failed)) + failed + ) ;let ) ;define (define (run-goldtest) - (let* ((test-files (list-sort string failed 0) -1 0)))) + (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 From 1dc8effa21ec7804e378a1df1620a648aa323d0f Mon Sep 17 00:00:00 2001 From: Da Shen Date: Sat, 21 Mar 2026 13:27:03 +0800 Subject: [PATCH 08/11] wip --- tests/goldfish/liii/http-test.scm | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/tests/goldfish/liii/http-test.scm b/tests/goldfish/liii/http-test.scm index 0072ad61..da29fa00 100644 --- a/tests/goldfish/liii/http-test.scm +++ b/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/") From 1daa289a55d66c40f5e406d70357e6ebcf4107a4 Mon Sep 17 00:00:00 2001 From: Da Shen Date: Sat, 21 Mar 2026 13:45:46 +0800 Subject: [PATCH 09/11] =?UTF-8?q?[200=5F39]=20=E4=B8=BA=20gf=20test=20?= =?UTF-8?q?=E5=AD=90=E5=91=BD=E4=BB=A4=E6=B7=BB=E5=8A=A0=20--only=20?= =?UTF-8?q?=E5=8F=82=E6=95=B0=E6=94=AF=E6=8C=81?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - goldtest.scm: 添加 parse-only-filter 和 filter-test-files 函数 - goldtest.scm: 使用 (scheme process-context) 获取 (command-line) - goldtest.scm: 支持 --only PATTERN 参数过滤测试文件 - src/goldfish.hpp: 允许 test 子命令使用 --only 选项 - src/goldfish.hpp: 更新 test 子命令帮助信息，显示 --only 选项 示例用法: gf test --only json (运行 json-test.scm 和 njson-test.scm) gf test --only sicp (运行 sicp-test.scm) Co-Authored-By: Claude Opus 4.6 --- src/goldfish.hpp | 11 ++++-- tests/goldtest/liii/goldtest.scm | 68 +++++++++++++++++++++++++------- 2 files changed, 61 insertions(+), 18 deletions(-) diff --git a/src/goldfish.hpp b/src/goldfish.hpp index 46194bd5..54da59f1 100644 --- a/src/goldfish.hpp +++ b/src/goldfish.hpp @@ -3365,7 +3365,9 @@ 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; + cout << " test [options] Run tests (all *-test.scm files under tests/)" << endl; + cout << " Options:" << endl; + cout << " --only PATTERN Run only tests matching PATTERN" << endl; #ifdef GOLDFISH_WITH_REPL cout << " repl Enter interactive REPL mode" << endl; #endif @@ -4247,12 +4249,13 @@ repl_for_community_edition (s7_scheme* sc, int argc, char** argv) { // 解析 mode 选项 std::string mode= parse_mode_option (argc, argv); - // 检查是否是 fix 子命令（它有自己特殊的选项处理） + // 检查是否是 fix/test 子命令（它们有自己特殊的选项处理） bool is_fix_command= (argc > 1) && (string (argv[1]) == "fix"); + bool is_test_command= (argc > 1) && (string (argv[1]) == "test"); // 检查无效的全局选项（除了 --mode 之外的其他选项都不再支持） - // fix 子命令有自己的选项解析逻辑，这里跳过对 fix 命令选项的检查 - if (!is_fix_command) { + // fix/test 子命令有自己的选项解析逻辑，这里跳过对它们的选项检查 + if (!is_fix_command && !is_test_command) { for (int i= 1; i < argc; ++i) { string arg= argv[i]; if (arg.length () > 0 && arg[0] == '-') { diff --git a/tests/goldtest/liii/goldtest.scm b/tests/goldtest/liii/goldtest.scm index f14a16ec..34e09f42 100644 --- a/tests/goldtest/liii/goldtest.scm +++ b/tests/goldtest/liii/goldtest.scm @@ -16,6 +16,7 @@ ; (import (scheme base) + (scheme process-context) (liii sort) (liii list) (liii string) @@ -127,25 +128,64 @@ ) ;let ) ;define +(define (parse-only-filter args) + (let loop ((remaining args) + (filter #f)) + (if (null? remaining) + filter + (if (and (equal? (car remaining) "--only") + (not (null? (cdr remaining)))) + (loop (cddr remaining) (cadr remaining)) + (loop (cdr remaining) filter) + ) ;if + ) ;if + ) ;let +) ;define + +(define (filter-test-files test-files only-pattern) + (if only-pattern + (filter (lambda (file) (string-contains file only-pattern)) test-files) + test-files + ) ;if +) ;define + (define (run-goldtest) - (let ((test-files (list-sort string failed 0) -1 0)) + (begin + (when only-pattern + (display (string-append "Running tests matching: " only-pattern)) + (newline) + (newline) + ) ;when + (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 - ) ;let + ) ;begin ) ;if - ) ;let + ) ;let* ) ;define From 573acedf466568f419217ba67570924bca68a171 Mon Sep 17 00:00:00 2001 From: Da Shen Date: Sat, 21 Mar 2026 13:55:57 +0800 Subject: [PATCH 10/11] =?UTF-8?q?[200=5F39]=20=E7=AE=80=E5=8C=96=20only-pa?= =?UTF-8?q?ttern=20=E8=BE=93=E5=87=BA=E6=A0=BC=E5=BC=8F?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - 移除多余的 newline，只保留一个 Co-Authored-By: Claude Opus 4.6 --- tests/goldtest/liii/goldtest.scm | 1 - 1 file changed, 1 deletion(-) diff --git a/tests/goldtest/liii/goldtest.scm b/tests/goldtest/liii/goldtest.scm index 34e09f42..3d225bb2 100644 --- a/tests/goldtest/liii/goldtest.scm +++ b/tests/goldtest/liii/goldtest.scm @@ -172,7 +172,6 @@ (when only-pattern (display (string-append "Running tests matching: " only-pattern)) (newline) - (newline) ) ;when (let ((test-results (fold (lambda (test-file acc) From 704e818ed663d8d9ea034d27b60cdb5eb129f24f Mon Sep 17 00:00:00 2001 From: Da Shen Date: Sat, 21 Mar 2026 14:07:56 +0800 Subject: [PATCH 11/11] wip --- src/goldfish.hpp | 9 +- tests/goldtest/liii/goldtest.scm | 190 --------------------- tools/goldtest/liii/goldtest.scm | 283 +++++++++++++++++++------------ xmake.lua | 2 +- 4 files changed, 180 insertions(+), 304 deletions(-) delete mode 100644 tests/goldtest/liii/goldtest.scm diff --git a/src/goldfish.hpp b/src/goldfish.hpp index 54da59f1..cbca68de 100644 --- a/src/goldfish.hpp +++ b/src/goldfish.hpp @@ -3367,7 +3367,8 @@ display_help () { cout << " --dry-run Print formatted result to stdout" << endl; cout << " test [options] Run tests (all *-test.scm files under tests/)" << endl; cout << " Options:" << endl; - cout << " --only PATTERN Run only tests matching PATTERN" << endl; + cout << " --only PATTERN Run tests matching PATTERN" << endl; + cout << " (e.g. json, sicp, list-test.scm)" << endl; #ifdef GOLDFISH_WITH_REPL cout << " repl Enter interactive REPL mode" << endl; #endif @@ -3513,7 +3514,7 @@ find_goldfix_tool_root (const char* gf_lib) { static string find_goldtest_tool_root (const char* gf_lib) { std::error_code ec; - vector candidates= {fs::path (gf_lib) / "tests" / "goldtest", fs::path (gf_lib).parent_path () / "tests" / "goldtest"}; + vector candidates= {fs::path (gf_lib) / "tools" / "goldtest", fs::path (gf_lib).parent_path () / "tools" / "goldtest"}; for (const auto& candidate : candidates) { if (fs::is_directory (candidate, ec)) { @@ -4475,10 +4476,10 @@ repl_for_community_edition (s7_scheme* sc, int argc, char** argv) { // 处理 test 子命令 if (command == "test") { - // 添加 tests/goldtest 目录到 load path (用于加载 (liii goldtest) 模块) + // 添加 tools/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; + cerr << "Error: tools/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); diff --git a/tests/goldtest/liii/goldtest.scm b/tests/goldtest/liii/goldtest.scm deleted file mode 100644 index 3d225bb2..00000000 --- a/tests/goldtest/liii/goldtest.scm +++ /dev/null @@ -1,190 +0,0 @@ - -; -; 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) - (scheme process-context) - (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 (parse-only-filter args) - (let loop ((remaining args) - (filter #f)) - (if (null? remaining) - filter - (if (and (equal? (car remaining) "--only") - (not (null? (cdr remaining)))) - (loop (cddr remaining) (cadr remaining)) - (loop (cdr remaining) filter) - ) ;if - ) ;if - ) ;let -) ;define - -(define (filter-test-files test-files only-pattern) - (if only-pattern - (filter (lambda (file) (string-contains file only-pattern)) test-files) - test-files - ) ;if -) ;define - -(define (run-goldtest) - (let* ((args (command-line)) - (only-pattern (parse-only-filter args)) - (all-test-files (list-sort string failed 0) -1 0)) - ) ;let - ) ;let - ) ;begin - ) ;if - ) ;let* -) ;define diff --git a/tools/goldtest/liii/goldtest.scm b/tools/goldtest/liii/goldtest.scm index 868e66f1..d4b81941 100644 --- a/tools/goldtest/liii/goldtest.scm +++ b/tools/goldtest/liii/goldtest.scm @@ -15,124 +15,189 @@ ; under the License. ; -(define-library (liii goldtest) - (export run-goldtest) - (import (scheme base) - (scheme process-context) - (liii list) - (liii string) - (liii os) - (liii path)) - (begin +(import (scheme base) + (scheme process-context) + (liii sort) + (liii list) + (liii string) + (liii os) + (liii path) + (liii sys) +) ;import - (define ESC (string #\escape #\[)) +(define ESC (string #\escape #\[)) - (define (color code) - (string-append ESC (number->string code) "m")) +(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 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))))))) +(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-with? entry "-test.scm")) - (set! files (cons full-path files)))))) - entries))) - files)) +(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) - (if (os-windows?) - "bin\\gf -m r7rs " - "bin/gf -m r7rs ")) +(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)))) +(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)))) - (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))) - (newline))) - test-results) - (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)) - (newline) - failed)) +(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 (parse-only-filter args) + (let loop ((remaining args) + (filter #f)) + (if (null? remaining) + filter + (if (and (equal? (car remaining) "--only") + (not (null? (cdr remaining)))) + (loop (cddr remaining) (cadr remaining)) + (loop (cdr remaining) filter) + ) ;if + ) ;if + ) ;let +) ;define - (define (run-goldtest) - (let ((test-all-path (test-path-join "tests" "test_all.scm"))) - (if (path-file? test-all-path) - ; 如果存在 test_all.scm，则运行它 +(define (filter-test-files test-files only-pattern) + (if only-pattern + (if (string-ends? only-pattern ".scm") + ; 如果以 .scm 结尾，直接匹配文件名 + (filter (lambda (file) (string=? (path-name file) only-pattern)) test-files) + ; 否则使用 string-contains 进行模糊匹配 + (filter (lambda (file) (string-contains file only-pattern)) test-files) + ) ;if + test-files + ) ;if +) ;define + +(define (run-goldtest) + (let* ((args (command-line)) + (only-pattern (parse-only-filter args)) + (all-test-files (list-sort string failed 0) -1 0))))))))) -) + ) ;begin + ) ;if + (exit 0) + ) ;begin + (begin + (when only-pattern + (if (string-ends? only-pattern ".scm") + (begin + (display (string-append "Run test with file name: " only-pattern)) + (newline) + ) ;begin + (begin + (display (string-append "Running tests matching: " only-pattern)) + (newline) + ) ;begin + ) ;if + ) ;when + (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 + ) ;begin + ) ;if + ) ;let* +) ;define diff --git a/xmake.lua b/xmake.lua index 5453d0b5..dc10e937 100644 --- a/xmake.lua +++ b/xmake.lua @@ -160,7 +160,7 @@ target ("goldfish") do add_installfiles("$(projectdir)/goldfish/(guenchi/*.scm)", {prefixdir = "share/goldfish"}) add_installfiles("$(projectdir)/tools/goldfix/main.scm", {prefixdir = "share/goldfish/tools/goldfix"}) add_installfiles("$(projectdir)/tools/goldfix/(liii/*.scm)", {prefixdir = "share/goldfish/tools/goldfix"}) - add_installfiles("$(projectdir)/tools/liii/goldtest.scm", {prefixdir = "share/goldfish/tools/liii"}) + add_installfiles("$(projectdir)/tools/goldtest/liii/goldtest.scm", {prefixdir = "share/goldfish/tools/goldtest/liii"}) end if is_plat("wasm") then