From 93475e5f281a65d6f19480e9e3a98bf51919feff Mon Sep 17 00:00:00 2001
From: AwesomeAdam54321 <[email protected]>
Date: Fri, 15 May 2026 16:33:04 +0800
Subject: [PATCH 1/1] runtime: srfi-64: Introduce basic SRFI-64 testing
functionality.
Ideally, a robust SRFI-64 implementation could be ported to MIT
Scheme, but for now this will have to do.
Alternatively, this implementation could be fixed to fully support
SRFI-64.
---
src/runtime/runtime.pkg | 15 ++++++
src/runtime/srfi-64.scm | 108 ++++++++++++++++++++++++++++++++++++++++
2 files changed, 123 insertions(+)
create mode 100644 src/runtime/srfi-64.scm
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 9cf05475..4549b321 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3497,6 +3497,21 @@ USA.
unzip5
zip))
+(define-package (runtime srfi-64)
+ (files "srfi-64")
+ (parent (runtime))
+ (export ()
+ *group-stack*
+ *skipped*
+ *expected-passes*
+ *actual-passes*
+ test-group
+ test-begin test-end
+ test-assert
+ test-equal
+ test-approximate
+ test-suite-summary))
+
(define-package (runtime load)
(files "load")
(parent (runtime))
diff --git a/src/runtime/srfi-64.scm b/src/runtime/srfi-64.scm
new file mode 100644
index 00000000..8e210663
--- /dev/null
+++ b/src/runtime/srfi-64.scm
@@ -0,0 +1,108 @@
+#| -*-Scheme-*-
+
+Copyright © 2026 Adam Faiz <[email protected]>
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; SRFI-64: A Scheme API for test suites
+
+;;; NOTE: This implementation is still very incomplete.
+;;; It should be fixed to be fully compliant with the specification.
+
+(define *group-stack* '())
+(define *skipped* '())
+(define *expected-passes* 0)
+(define *actual-passes* 0)
+
+(define-syntax test-group
+ (syntax-rules ()
+ ((_ group expr expr* ...)
+ (when (not (member group *skipped*))
+ (dynamic-wind
+ (lambda () (test-begin group))
+ (lambda () expr expr* ...)
+ (lambda ()
+ (test-end group)
+ (when (null? *group-stack*) (test-suite-summary))))))))
+
+(define-syntax boost!
+ (syntax-rules ()
+ ((_ var)
+ (set! var (1+ var)))))
+
+(define-syntax push!
+ (syntax-rules ()
+ ((_ item lst)
+ (set! lst (cons item lst)))))
+
+(define-syntax pop!
+ (syntax-rules ()
+ ((_ lst)
+ (set! lst (cdr lst)))))
+
+(define (test-skip name) (push! name *skipped*))
+
+;; TODO: Figure out why `(import (runtime format) format)`
+;; in runtime.pkg doesn't work.
+(define (test-begin name)
+ (display "*** Entering test group: ")
+ (display name)
+ (display " ***\n")
+ (push! name *group-stack*))
+
+(define (test-end name)
+ (display "*** Leaving test group: ")
+ (display name)
+ (display " ***\n")
+ (let ((top (car *group-stack*)))
+ (if (equal? top name)
+ (pop! *group-stack*)
+ (error "Mismatched test group" name top))))
+
+(define (pass name)
+ (display "* PASS: ")(display name)(newline))
+(define (fail name)
+ (display"* FAIL: ")(display name)(newline))
+
+(define (test-assert name asserted?)
+ (boost! *expected-passes*)
+ (cond (asserted?
+ (pass name)
+ (boost! *actual-passes*))
+ (else (fail name))))
+
+(define (test-equal name expected actual)
+ (test-assert name (equal? actual expected)))
+
+(define (test-approximate name expected actual error)
+ (test-assert name
+ (and (>= actual (- expected error))
+ (<= actual (+ expected error)))))
+
+(define (test-suite-summary)
+ (display "*** Test suite finished. ***\n")
+ (display "*** # of expected passes : ")
+ (display *actual-passes*)(newline)
+ (let ((xfails (- *expected-passes* *actual-passes*)))
+ (when (positive? xfails)
+ (display "*** # of unexpected failures: ")
+ (display xfails)(newline)))
+ (set! *expected-passes* 0)
+ (set! *actual-passes* 0))
--
2.52.0
