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 adadcfbb..46194bd5 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 (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 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/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/") 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 new file mode 100644 index 00000000..f14a16ec --- /dev/null +++ b/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 failed 0) -1 0)) + ) ;let + ) ;let + ) ;if + ) ;let +) ;define 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 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