From 5b2bc2d146e7b58f15e1bc653291b71d8376b763 Mon Sep 17 00:00:00 2001
From: Arun Isaac
Date: Mon, 17 Nov 2025 18:15:10 +0000
Subject: Use cond-expand to find the right match library.
---
.guix/run64-package.scm | 69 ++-----------------------------------------------
bin/run64 | 26 ++++++++++---------
2 files changed, 16 insertions(+), 79 deletions(-)
diff --git a/.guix/run64-package.scm b/.guix/run64-package.scm
index 44a1380..fde9f6f 100644
--- a/.guix/run64-package.scm
+++ b/.guix/run64-package.scm
@@ -17,58 +17,13 @@
;;; along with run64. If not, see .
(define-module (run64-package)
- #:use-module ((gnu packages base) #:select (gnu-make))
- #:use-module ((gnu packages emacs) #:select (emacs-minimal))
- #:use-module ((gnu packages guile) #:select (guile-3.0))
- #:use-module ((gnu packages scheme) #:select (chibi-scheme))
#:use-module (guix build-system gnu)
- #:use-module (guix build-system guile)
#:use-module (guix gexp)
#:use-module (guix git-download)
#:use-module ((guix licenses) #:prefix license:)
#:use-module (guix packages)
#:use-module (guix utils))
-(define-public guile-chibi-match
- (package
- (name "guile-chibi-match")
- (version (package-version chibi-scheme))
- (source (package-source chibi-scheme))
- (build-system guile-build-system)
- (arguments
- (list #:modules '((guix build guile-build-system)
- (guix build utils)
- (ice-9 ftw))
- #:phases
- #~(modify-phases %standard-phases
- (add-after 'unpack 'rearrange-files
- (lambda _
- ;; Delete and rearrange files so that (chibi match)
- ;; is in the expected directory hierarchy.
- (chdir "lib/chibi")
- (rename-file "match" "chibi")
- (for-each (lambda (file)
- (unless (member file (list "." ".." "chibi"))
- (delete-file-recursively file)))
- (scandir "."))
- (substitute* "chibi/match.scm"
- ((";; 2006/12/01[^\n]*" line)
- (string-append line
- "\n(define-module (chibi match)
-#:export (match match-lambda match-lambda* match-let match-letrec match-let*))"))))))))
- (inputs
- (list guile-3.0))
- (home-page "https://synthcode.com/scheme/chibi/lib/chibi/match.html")
- (synopsis "Portable hygienic pattern matcher")
- (description "@code{guile-chibi-match} is a portable hygienic
-pattern matcher for Scheme. This is a full superset of the popular
-match package by Andrew Wright, written in fully portable syntax-rules
-and thus preserving hygiene. The most notable extensions are the
-ability to use non-linear patterns---patterns in which the same
-identifier occurs multiple times, tail patterns after ellipsis, and
-the experimental tree patterns.")
- (license (package-license chibi-scheme))))
-
(define-public run64
(package
(name "run64")
@@ -81,29 +36,9 @@ the experimental tree patterns.")
(build-system gnu-build-system)
(arguments
(list #:make-flags #~(list (string-append "prefix=" #$output))
- #:modules `(((guix build guile-build-system)
- #:select (target-guile-effective-version))
- ,@%default-gnu-imported-modules)
#:phases
- (with-imported-modules `((guix build guile-build-system)
- ,@%default-gnu-imported-modules)
- #~(modify-phases %standard-phases
- (delete 'configure)
- (add-after 'install 'wrap
- (lambda* (#:key inputs outputs #:allow-other-keys)
- (let ((out (assoc-ref outputs "out"))
- (effective-version (target-guile-effective-version)))
- (wrap-program (string-append out "/bin/guile-run64")
- `("GUILE_LOAD_PATH" prefix
- (,(string-append out "/share/guile/site/" effective-version)
- ,(getenv "GUILE_LOAD_PATH")))
- `("GUILE_LOAD_COMPILED_PATH" prefix
- (,(string-append out "/lib/guile/"
- effective-version "/site-ccache")
- ,(getenv "GUILE_LOAD_COMPILED_PATH")))))))))))
- (inputs
- (list guile-3.0
- guile-chibi-match))
+ #~(modify-phases %standard-phases
+ (delete 'configure))))
(home-page "https://run64.systemreboot.net")
(synopsis "SRFI-64 test runner for Scheme")
(description "run64 is a SRFI-64 test runner for Scheme.")
diff --git a/bin/run64 b/bin/run64
index c38682f..3c98ec0 100755
--- a/bin/run64
+++ b/bin/run64
@@ -22,12 +22,14 @@
(rnrs programs)
(rnrs records syntactic)
(srfi srfi-1)
- (srfi srfi-64)
- ;; We prefix (chibi match) imports with chibi: so as to not
- ;; conflict with match bindings provided by the
- ;; implementation. We should find a better solution, if at all
- ;; possible.
- (prefix (chibi match) chibi:))
+ (srfi srfi-64))
+
+;; We prefix match imports with run64: so as to not conflict with match bindings
+;; provided by the implementation. We should find a better solution, if at all
+;; possible.
+(cond-expand
+ (guile (import (prefix (ice-9 match) run64:)))
+ (else (import (prefix (chibi match) run64:))))
(define-record-type ( highlit highlit?)
(fields (immutable contents highlit-contents)))
@@ -35,7 +37,7 @@
(define-record-type ( nothing nothing?))
(define (assq-ref alist key)
- (chibi:match (assq key alist)
+ (run64:match (assq key alist)
((_ . value) value)
(#f #f)))
@@ -125,7 +127,7 @@ given string in an ANSI escape code."
;; Open the list.
(display opener)
(let ((child-column (+ (string-length opener) column)))
- (chibi:match lst
+ (run64:match lst
;; If an empty list, close without doing anything else.
(()
(display ")"))
@@ -207,11 +209,11 @@ given string in an ANSI escape code."
"Like @code{map}, but does not stop when the end of the shortest list is reached.
@var{proc} calls beyond the end of shorter lists are passed a @code{}
object instead of the list element."
- (let ((heads (map (chibi:match-lambda
+ (let ((heads (map (run64:match-lambda
((head _ ...) head)
(() (nothing)))
lists))
- (tails (map (chibi:match-lambda
+ (tails (map (run64:match-lambda
((_ tail ...) tail)
(() '()))
lists)))
@@ -251,7 +253,7 @@ object instead of the list element."
(headline "test session starts" bold)
(test-with-runner runner
(for-each load
- (chibi:match args
+ (run64:match args
((_ files ...) files))))
(newline)
(unless (zero? (test-runner-fail-count runner))
@@ -260,7 +262,7 @@ object instead of the list element."
(let ((name (assq-ref failure 'test-name))
(file (assq-ref failure 'source-file))
(line (assq-ref failure 'source-line))
- (test-type (chibi:match (assq-ref failure 'source-form)
+ (test-type (run64:match (assq-ref failure 'source-form)
(('test-assert _ ...) 'assert)
(('test-eq _ ...) 'eq)
(('test-eqv _ ...) 'eqv)
--
cgit 1.4.1