diff --git a/src/goldfish.hpp b/src/goldfish.hpp index 46194bd5..cbca68de 100644 --- a/src/goldfish.hpp +++ b/src/goldfish.hpp @@ -3365,7 +3365,10 @@ 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 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 @@ -3511,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)) { @@ -4247,12 +4250,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] == '-') { @@ -4472,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 f14a16ec..00000000 --- a/tests/goldtest/liii/goldtest.scm +++ /dev/null @@ -1,151 +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) - (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/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