guix: Add guile-patched, guile-mingw.

Build it:

    GUIX_PACKAGE_PATH=guix guix build --target=x86_64-w64-mingw32 guile-mingw

Run it:

    WINEPATH=$(guix shell wine64 -- winepath -w                                     \
        $(echo $(guix gc -R                                                         \
                      $(GUIX_PACKAGE_PATH=guix guix build                           \
                                         --target=x86_64-w64-mingw32 guile-mingw))) \
                   | sed 's,$,/bin,g' | tr '\n' ';')                                \
            guix shell wine64 -- wine                                               \
            $(GUIX_PACKAGE_PATH=guix guix build --target=x86_64-w64-mingw32         \
                               guile-mingw)/bin/guile.exe                           \
            -c '(format #t "Hello  ~a world!\n" %host-type)'

* guix/guile-patched.scm,
guix/mingw.scm: New files.

2 files changed, 185 insertions, 0 deletions

diff --git a/guix/guile-patched.scm b/guix/guile-patched.scm
new file mode 100644
index 000000000..bbae5564c
--- /dev/null
+++ b/guix/guile-patched.scm
@@ -0,0 +1,72 @@
+;;; Dezyne --- Dezyne command line tools
+;;;
+;;; Copyright © 2020,2021,2022 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of Dezyne.
+;;;
+;;; Dezyne is free software: you can redistribute it and/or modify it
+;;; under the terms of the GNU Affero General Public License as
+;;; published by the Free Software Foundation, either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; Dezyne 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
+;;; Affero General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Affero General Public
+;;; License along with Dezyne.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guile-patched)
+  #:use-module (gnu packages)
+  #:use-module (gnu packages autotools)
+  #:use-module (gnu packages flex)
+  #:use-module (gnu packages gettext)
+  #:use-module (gnu packages gperf)
+  #:use-module (gnu packages guile)
+  #:use-module (gnu packages pkg-config)
+  #:use-module (gnu packages texinfo)
+  #:use-module (guix build utils)
+  #:use-module (guix git-download)
+  #:use-module (guix packages)
+  #:use-module (guix utils))
+
+(define-public guile-3.0-patched
+  (let ((commit "4b3162a9c3945d532d239b703a434500f45c14c6")
+        (revision "18"))
+    (package
+      (inherit guile-3.0-latest)
+      (name "guile-patched")
+      (version (string-append "3.0.8" "-" revision "." (string-take commit 7)))
+      (native-inputs
+       `(("autoconf" ,autoconf)
+         ("automake" ,automake)
+         ("libtool" ,libtool)
+         ("flex" ,flex)
+         ("texinfo" ,texinfo)
+         ("gettext" ,gettext-minimal)
+         ("gperf" ,gperf)
+         ,@(package-native-inputs guile-3.0-latest)))
+      (source (origin
+                (method git-fetch)
+                (uri (git-reference
+                      (url "https://git.savannah.gnu.org/git/guile.git")
+                      (commit commit)))
+                (file-name (string-append name "-" version "-checkout"))
+                (sha256
+                 (base32
+                  "1ln9qv3r50w8ilv3iw70mqpvgb0gnip7sdxss7i7crg25wwlrs3f"))))
+      (arguments
+       (substitute-keyword-arguments (package-arguments guile-3.0-latest)
+         ((#:phases phases '%standard-phases)
+          `(modify-phases ,phases
+             (add-after 'unpack 'disable-some-tests
+               (lambda _
+                 (delete-file "test-suite/tests/asyncs.test")
+                 (delete-file "test-suite/tests/ftw.test")
+                 (delete-file "test-suite/tests/suspendable-ports.test")
+                 (substitute* "test-suite/standalone/Makefile.am"
+                   (("check_SCRIPTS \\+= test-out-of-memory" all)
+                    (string-append "# " all))
+                   (("TESTS \\+= test-out-of-memory" all)
+                    (string-append "# " all))))))))))))
diff --git a/guix/mingw.scm b/guix/mingw.scm
new file mode 100644
index 000000000..9294808b0
--- /dev/null
+++ b/guix/mingw.scm
@@ -0,0 +1,113 @@
+;;; Dezyne --- Dezyne command line tools
+;;;
+;;; Copyright © 2019,2020,2021,2022 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of Dezyne.
+;;;
+;;; Dezyne is free software: you can redistribute it and/or modify it
+;;; under the terms of the GNU Affero General Public License as
+;;; published by the Free Software Foundation, either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; Dezyne 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
+;;; Affero General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Affero General Public
+;;; License along with Dezyne.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (mingw)
+  #:use-module (srfi srfi-1)
+  #:use-module (guix build-system gnu)
+  #:use-module (guix gexp)
+  #:use-module (guix download)
+  #:use-module (guix git-download)
+  #:use-module ((guix licenses) #:prefix license:)
+  #:use-module (guix packages)
+  #:use-module (guix utils)
+  #:use-module (gnu packages)
+  #:use-module (gnu packages bdw-gc)
+  #:use-module (gnu packages gcc)
+  #:use-module (gnu packages hurd)
+  #:use-module (gnu packages mingw)
+  #:use-module (gnu packages multiprecision)
+  #:use-module (gnu packages pkg-config)
+  #:use-module (guile-patched))
+
+(define-public libatomic-ops-mingw
+  (package
+    (inherit libatomic-ops)
+    (name "libatomic-ops-mingw")
+    (arguments
+     '(#:configure-flags '("--enable-shared")))))
+
+(define-public libgc-mingw
+  (package
+    (inherit libgc)
+    (name "libgc-mingw")
+    (arguments
+     `(#:strip-binaries? #f
+       #:configure-flags
+       (list
+        ;; Install gc_cpp.h et al.
+        "--enable-cplusplus"
+
+        ;; Work around <https://github.com/ivmai/bdwgc/issues/353>.
+        "--disable-munmap"
+
+        ;; In GNU/Hurd systems during the 'Check' phase,
+        ;; there is a deadlock caused by the 'gctest' test.
+        ;; To disable the error set "--disable-gcj-support"
+        ;; to configure script. See bug report and discussion:
+        ;; <https://lists.opendylan.org/pipermail/bdwgc/2017-April/006275.html>
+        ;; <https://lists.gnu.org/archive/html/bug-hurd/2017-01/msg00008.html>
+        ,@(if (target-hurd? (or (%current-system)
+                                (%current-target-system)))
+              '("--disable-gcj-support")
+              '()))
+       #:phases (modify-phases %standard-phases
+                  (add-after 'unpack 'adjust-pc-file
+                    (lambda* (#:key inputs #:allow-other-keys)
+                      (let ((libatomic-ops (assoc-ref inputs "libatomic-ops-mingw")))
+                        ;; GC 7.6.10 and later includes -latomic_ops in the
+                        ;; pkg-config file.  To avoid propagation, insert an
+                        ;; absolute reference so dependent programs can find it.
+                        (substitute* "bdw-gc.pc.in"
+                          (("@ATOMIC_OPS_LIBS@" match)
+                           (string-append "-L" libatomic-ops "/lib "
+                                          match)))
+                        #t))))))
+    (native-inputs (list pkg-config))
+    (inputs (list libatomic-ops-mingw))))
+
+(define-public guile-3.0-mingw
+  (package
+    (inherit guile-3.0-patched)
+    (name "guile-mingw")
+    (native-inputs
+     `(("self" ,guile-3.0-patched)
+       ,@(alist-delete "self" (package-native-inputs guile-3.0-patched))))
+    (propagated-inputs
+     `(("bdw-gc" ,libgc-mingw)
+       ,@(alist-delete "bwd-gc" (package-propagated-inputs guile-3.0-patched))))
+    (arguments
+     `(#:tests? #f
+       #:strip-binaries? #f
+       ,@(if (%current-target-system)
+             (substitute-keyword-arguments (package-arguments guile-3.0-patched)
+               ((#:configure-flags flags '())
+                `(cons* "--disable-lto" ;breaks with binutils > 2.35.2
+                        "--disable-jit"
+                        "--enable-mini-gmp"
+                        ,flags))
+               ((#:phases phases '%standard-phases)
+                `(modify-phases ,phases
+                   (add-after 'unpack 'bootstrap
+                     (lambda _
+                       (invoke "sh" "autogen.sh")))
+                   (add-after 'unpack 'patch-version-gen
+                     (lambda _
+                       (substitute* "build-aux/git-version-gen"
+                         (("#!/bin/sh") (string-append "#! " (which "sh")))))))))
+             (package-arguments guile-3.0-patched))))))