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

[Philip McGrath]

* gnu/packages/chez-and-racket-bootstrap.scm (chez-machine->unthreaded,
chez-machine->upstream-restriction, chez-machine->nix-system,
nix-system->chez-machine): 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-machine->upstream-restriction'.
---
 gnu/packages/chez-and-racket-bootstrap.scm | 142 ++++++++++++++++++++-
 1 file changed, 140 insertions(+), 2 deletions(-)

diff --git a/gnu/packages/chez-and-racket-bootstrap.scm 
b/gnu/packages/chez-and-racket-bootstrap.scm
index 11d570059b..fc1da53178 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,134 @@ (define-module (gnu packages chez-and-racket-bootstrap)
 ;;
 ;; Code:
 
+(define (chez-machine->unthreaded mach)
+  "Given a string MACH naming a Chez Scheme machine type, returns a string
+naming the unthreaded machine type for the same architecture and OS as MACH.
+The returned string may share storage with MACH."
+  (if (eqv? #\t (string-ref mach 0))
+      (substring mach 1)
+      mach))
+(define (chez-machine->threaded mach)
+  "Like @code{chez-machine->unthreaded}, but returns the threaded machine
+type."
+  (if (eqv? #\t (string-ref mach 0))
+      mach
+      (string-append "t" mach)))
+
+;; 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->upstream-restriction mach)
+  "Given a string MACH naming a Chez Scheme machine type, returns a symbol
+naming a restriction on the upstream Chez Scheme implementation compared to
+the Racket variant, or @code{#f} if no such restriction exists.  The
+restriction is reported for the architecture--OS pair, regardless of whether
+MACH specifies a threaded or an unthreaded variant.
+
+Possible restrictions currently include:
+@itemize @bullet
+@item
+@code{'no-threads}: Support for native threads is not available upstream.
+@item
+@code{'no-support}: The upstream release doesn't claim to support this
+architecture--OS combination at all.
+@end itemize
+
+See @code{chez-machine->nix-system} for more details about acceptable values
+for MACH."
+  (let ((mach (chez-machine->unthreaded mach)))
+    (cond
+     ((string-prefix? "arm64" mach)
+      'no-support)
+     ((string-prefix? "arm32" mach)
+      (if (string-suffix? "le" mach)
+          'no-threads
+          'no-support))
+     ((string-prefix? "ppc32" mach)
+      (if (string-suffix? "le" mach)
+          #f
+          'no-support))
+     (else
+      #f))))
+
+(define (chez-machine->nix-system mach)
+  "Return the Nix system type corresponding to the Chez Scheme machine type
+MACH.  If MACH is not a string representing a known machine type, an exception
+is raised.  This function does not distinguish between threaded and unthreaded
+variants of MACH.
+
+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 the 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 ((mach (chez-machine->unthreaded mach)))
+    (let find-arch ((alist %nix-arch-to-chez-alist))
+      (match alist
+        (((nix . chez) . alist)
+         (if (string-prefix? chez mach)
+             (string-append
+              nix "-" (let ((mach-os (substring mach (string-length chez))))
+                        (let find-os ((alist %nix-os-to-chez-alist))
+                          (match alist
+                            (((nix . chez) . alist)
+                             (if (equal? chez mach-os)
+                                 nix
+                                 (find-os alist)))))))
+             (find-arch alist)))))))
+
+(define* (nix-system->chez-machine #:optional (system (%current-system))
+                                   #:key (threads? 'always))
+  "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.
+
+When THREADS? is @code{'always} (the default), the threaded variant of the
+machine type will be returned: note that the package returned by
+@code{chez-scheme-for-system} will always support native threads.  When
+THREADS? is @code{#f}, the unthreaded machine type will be returned.  If
+THREADS? is @code{'upstream} (the default), the threaded variant of the
+machine type will be returned if and only if it is supported by upstream Chez
+Scheme (see @code{chez-machine->upstream-restriction}).  If THREADS? is any
+other value, an exception is raised."
+  (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))
+         (mach (and chez-arch chez-os (string-append chez-arch chez-os))))
+    (and mach
+         (match threads?
+           ('always
+            (chez-machine->threaded mach))
+           (#f
+            mach)
+           ('upstream
+            (if (chez-machine->upstream-restriction mach)
+                mach
+                (chez-machine->threaded mach)))))))
+
+;;
+;; Chez Scheme:
+;;
+
 (define nanopass
   (let ((version "1.9.2"))
     (origin
@@ -264,8 +394,16 @@ (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
+       (lambda (system)
+         (and=> (nix-system->chez-machine system)
+                (lambda (mach)
+                  (not (eq? 'no-support
+                            (chez-machine->upstream-restriction mach))))))
+       %supported-systems)))
     (home-page "https://cisco.github.io/ChezScheme/";)
     (synopsis "R6RS Scheme compiler and run-time")
     (description
-- 
2.32.0