[bug#53878] [PATCH v2 04/15] gnu: chez-and-racket-bootstrap: Add utilities for Chez machine types.

[Philip McGrath]

* gnu/packages/chez-and-racket-bootstrap.scm (chez-machine->nonthreaded,
chez-machine->threaded, chez-machine->nix-system, nix-system->chez-machine,
chez-upstream-features-for-system): New private functions.
(%nix-arch-to-chez-alist, %nix-os-to-chez-alist): New private constants.
(chez-scheme)[supported-systems]: Compute based on
'nix-system->chez-machine' and 'chez-upstream-features-for-system'.
---
 gnu/packages/chez-and-racket-bootstrap.scm | 118 ++++++++++++++++++++-
 1 file changed, 116 insertions(+), 2 deletions(-)

diff --git a/gnu/packages/chez-and-racket-bootstrap.scm 
b/gnu/packages/chez-and-racket-bootstrap.scm
index 11d570059b..1a923fe62d 100644
--- a/gnu/packages/chez-and-racket-bootstrap.scm
+++ b/gnu/packages/chez-and-racket-bootstrap.scm
@@ -28,7 +28,9 @@ (define-module (gnu packages chez-and-racket-bootstrap)
   #:use-module (guix utils)
   #:use-module (guix gexp)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
   #:use-module (guix build-system gnu)
   #:use-module (gnu packages)
   #:use-module (gnu packages compression)
@@ -61,6 +63,115 @@ (define-module (gnu packages chez-and-racket-bootstrap)
 ;;
 ;; Code:
 
+(define (chez-machine->nonthreaded machine)
+  "Given a string MACHINE naming a Chez Scheme machine type, returns a string
+naming the nonthreaded machine type for the same architecture and OS as
+MACHINE.  The returned string may share storage with MACHINE."
+  ;; Chez Scheme documentation consistently uses "nonthreaded" rather than
+  ;; e.g. "unthreaded"
+  (if (eqv? #\t (string-ref machine 0))
+      (substring machine 1)
+      machine))
+(define (chez-machine->threaded machine)
+  "Like @code{chez-machine->nonthreaded}, but returns the threaded machine
+type."
+  (if (eqv? #\t (string-ref machine 0))
+      machine
+      (string-append "t" machine)))
+
+;; Based on the implementation from raco-cross-lib/private/cross/platform.rkt
+;; in https://github.com/racket/raco-cross.
+;; For supported platforms, refer to release_notes/release_notes.stex in the
+;; upstream Chez Scheme repository or to racket/src/ChezScheme/README.md
+;; in https://github.com/racket/racket.
+(define %nix-arch-to-chez-alist
+  `(("x86_64" . "a6")
+    ("i386" . "i3")
+    ("aarch64" . "arm64")
+    ("armhf" . "arm32") ;; Chez supports ARM v6+
+    ("ppc" . "ppc32")))
+(define %nix-os-to-chez-alist
+  `(("w64-mingw32" . "nt")
+    ("darwin" . "osx")
+    ("linux" . "le")
+    ("freebsd" . "fb")
+    ("openbsd" . "ob")
+    ("netbsd" . "nb")
+    ("solaris" . "s2")))
+
+(define (chez-machine->nix-system machine)
+  "Return the Nix system type corresponding to the Chez Scheme machine type
+MACHINE.  If MACHINE is not a string representing a known machine type, an
+exception is raised.  This function does not distinguish between threaded and
+nonthreaded variants of MACHINE.
+
+Note that this function only handles Chez Scheme machine types in the
+strictest sense, not other kinds of descriptors sometimes used in place of a
+Chez Scheme machine type by Racket, such as @code{\"pb\"}, @code{#f}, or
+@code{\"racket\"}.  (When using such extensions, the Chez Scheme machine type
+for the host system is often still relevant.)"
+  (let ((machine (chez-machine->nonthreaded machine)))
+    (let find-arch ((alist %nix-arch-to-chez-alist))
+      (match alist
+        (((nix . chez) . alist)
+         (if (string-prefix? chez machine)
+             (string-append
+              nix "-" (let ((machine-os
+                             (substring machine (string-length chez))))
+                        (let find-os ((alist %nix-os-to-chez-alist))
+                          (match alist
+                            (((nix . chez) . alist)
+                             (if (equal? chez machine-os)
+                                 nix
+                                 (find-os alist)))))))
+             (find-arch alist)))))))
+
+(define* (nix-system->chez-machine #:optional
+                                   (system (or (%current-target-system)
+                                               (%current-system))))
+  "Return the Chez Scheme machine type corresponding to the Nix system
+identifier SYSTEM, or @code{#f} if the translation of SYSTEM to a Chez Scheme
+machine type is undefined.
+
+It is unspecified whether the resulting string will name a threaded or a
+nonthreaded machine type: when the distinction is relevant, use
+@code{chez-machine->nonthreaded} or @code{chez-machine->threaded} to adjust
+the result."
+  (let* ((hyphen (string-index system #\-))
+         (nix-arch (substring system 0 hyphen))
+         (nix-os (substring system (+ 1 hyphen)))
+         (chez-arch (assoc-ref %nix-arch-to-chez-alist nix-arch))
+         (chez-os (assoc-ref %nix-os-to-chez-alist nix-os)))
+    (and chez-arch chez-os (string-append chez-arch chez-os))))
+
+(define* (chez-upstream-features-for-system #:optional
+                                            (system
+                                             (or (%current-target-system)
+                                                 (%current-system))))
+  "Return a list of symbols naming features supported by upstream Chez Scheme
+for the Nix system identifier SYSTEM, or @code{#f} if upstream Chez Scheme
+does not support SYSTEM at all.
+
+If native threads are supported, the returned list will include
+@code{'threads}.  Other feature symbols may be added in the future."
+  (cond
+   ((not (nix-system->chez-machine system))
+    #f)
+   ((target-aarch64? system)
+    #f)
+   ((target-arm32? system)
+    (and (target-linux? system)
+         '()))
+   ((target-ppc32? system)
+    (and (target-linux? system)
+         '(threads)))
+   (else
+    '(threads))))
+
+;;
+;; Chez Scheme:
+;;
+
 (define nanopass
   (let ((version "1.9.2"))
     (origin
@@ -264,8 +375,11 @@ (define* (stex-make #:optional (suffix ""))
     ;; We should too. It is the Chez machine type arm32le
     ;; (no threaded version upstream yet, though there is in
     ;; Racket's fork), more specifically (per the release notes) ARMv6.
-    (supported-systems (fold delete %supported-systems
-                             '("mips64el-linux" "armhf-linux")))
+    (supported-systems
+     (delete
+      "armhf-linux" ;; <-- should work, but reportedly broken
+      (filter chez-upstream-features-for-system
+              %supported-systems)))
     (home-page "https://cisco.github.io/ChezScheme/";)
     (synopsis "R6RS Scheme compiler and run-time")
     (description
-- 
2.32.0