0001-Get-latest-poll-module-from-gnulib-to-fix-compilatio.patch

From 5ce32fcfbeca6c4f647303f4ccf0b1e1c7688901 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hannes=20M=C3=BCller?= <h.c.f.mueller@gmx.de>
Date: Tue, 2 Jul 2019 08:25:40 +0200
Subject: [PATCH] Get latest poll module from gnulib to fix compilation error
 on mingw-w64

mainly struct pollfd definition caused compilation failure on mingw-w64
* lib/Makefile.am: update target poll.h:
* lib/poll.c:
* lib/poll.in.h:
* m4/poll.m4:
* m4/poll_h.m4: update from gnulib git
---
 lib/Makefile.am |  1 +
 lib/poll.c      | 49 ++++++++++++++++++++++++++++++++++++++-----------
 lib/poll.in.h   | 32 +++++++++++++++++++++++++++-----
 m4/poll.m4      | 26 +++++++++++++++-----------
 m4/poll_h.m4    |  6 ++++--
 5 files changed, 85 insertions(+), 29 deletions(-)

diff --git a/lib/Makefile.am b/lib/Makefile.am
index f1b83a13b..fcaabccb6 100644
--- a/lib/Makefile.am
+++ b/lib/Makefile.am
@@ -1741,6 +1741,7 @@ poll.h: poll.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(WARN_ON_USE_H)
 	      -e 's|@''PRAGMA_COLUMNS''@|@PRAGMA_COLUMNS@|g' \
 	      -e 's|@''NEXT_POLL_H''@|$(NEXT_POLL_H)|g' \
 	      -e 's/@''GNULIB_POLL''@/$(GNULIB_POLL)/g' \
+	      -e 's|@''HAVE_WINSOCK2_H''@|$(HAVE_WINSOCK2_H)|g' \
 	      -e 's|@''HAVE_POLL''@|$(HAVE_POLL)|g' \
 	      -e 's|@''REPLACE_POLL''@|$(REPLACE_POLL)|g' \
 	      -e '/definitions of _GL_FUNCDECL_RPL/r $(CXXDEFS_H)' \
diff --git a/lib/poll.c b/lib/poll.c
index e700ac358..2b590bd42 100644
--- a/lib/poll.c
+++ b/lib/poll.c
@@ -1,22 +1,22 @@
 /* Emulation for poll(2)
    Contributed by Paolo Bonzini.
 
-   Copyright 2001-2003, 2006-2017 Free Software Foundation, Inc.
+   Copyright 2001-2003, 2006-2019 Free Software Foundation, Inc.
 
    This file is part of gnulib.
 
    This program is free software; you can redistribute it and/or modify
-   it under the terms of the GNU Lesser General Public License as published by
+   it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2, or (at your option)
    any later version.
 
    This program 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 Lesser General Public License for more details.
+   GNU General Public License for more details.
 
-   You should have received a copy of the GNU Lesser General Public License along
-   with this program; if not, see <http://www.gnu.org/licenses/>.  */
+   You should have received a copy of the GNU General Public License along
+   with this program; if not, see <https://www.gnu.org/licenses/>.  */
 
 /* Tell gcc not to warn about the (nfd < 0) tests, below.  */
 #if (__GNUC__ == 4 && 3 <= __GNUC_MINOR__) || 4 < __GNUC__
@@ -34,14 +34,18 @@
 #include <errno.h>
 #include <limits.h>
 
-#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+#if defined _WIN32 && ! defined __CYGWIN__
 # define WINDOWS_NATIVE
 # include <winsock2.h>
 # include <windows.h>
 # include <io.h>
 # include <stdio.h>
 # include <conio.h>
-# include "msvc-nothrow.h"
+# if GNULIB_MSVC_NOTHROW
+#  include "msvc-nothrow.h"
+# else
+#  include <io.h>
+# endif
 #else
 # include <sys/time.h>
 # include <unistd.h>
@@ -72,6 +76,29 @@
 
 #ifdef WINDOWS_NATIVE
 
+/* Do *not* use the function WSAPoll
+   <https://docs.microsoft.com/en-us/windows/desktop/api/winsock2/nf-winsock2-wsapoll>
+   because there is a bug named “Windows 8 Bugs 309411 - WSAPoll does not
+   report failed connections” that Microsoft won't fix.
+   See Daniel Stenberg: "WASPoll is broken"
+   <https://daniel.haxx.se/blog/2012/10/10/wsapoll-is-broken/>.  */
+
+/* Here we need the recv() function from Windows, that takes a SOCKET as
+   first argument, not any possible gnulib override.  */
+# undef recv
+
+/* Here we need the select() function from Windows, because we pass bit masks
+   of SOCKETs, not bit masks of FDs.  */
+# undef select
+
+/* Here we need timeval from Windows since this is what the select() function
+   from Windows requires.  */
+# undef timeval
+
+/* Avoid warnings from gcc -Wcast-function-type.  */
+# define GetProcAddress \
+   (void *) GetProcAddress
+
 static BOOL IsConsoleHandle (HANDLE h)
 {
   DWORD mode;
@@ -335,13 +362,13 @@ poll (struct pollfd *pfd, nfds_t nfd, int timeout)
   int maxfd, rc;
   nfds_t i;
 
-  if (nfd < 0)
+  if (nfd > INT_MAX)
     {
       errno = EINVAL;
       return -1;
     }
-  /* Don't check directly for NFD too large.  Any practical use of a
-     too-large NFD is caught by one of the other checks below, and
+  /* Don't check directly for NFD greater than OPEN_MAX.  Any practical use
+     of a too-large NFD is caught by one of the other checks below, and
      checking directly for getdtablesize is too much of a portability
      and/or performance and/or correctness hassle.  */
 
@@ -433,7 +460,7 @@ poll (struct pollfd *pfd, nfds_t nfd, int timeout)
   int rc = 0;
   nfds_t i;
 
-  if (nfd < 0 || timeout < -1)
+  if (nfd > INT_MAX || timeout < -1)
     {
       errno = EINVAL;
       return -1;
diff --git a/lib/poll.in.h b/lib/poll.in.h
index e9b141d8f..0b115dcb3 100644
--- a/lib/poll.in.h
+++ b/lib/poll.in.h
@@ -1,22 +1,22 @@
 /* Header for poll(2) emulation
    Contributed by Paolo Bonzini.
 
-   Copyright 2001-2003, 2007, 2009-2017 Free Software Foundation, Inc.
+   Copyright 2001-2003, 2007, 2009-2019 Free Software Foundation, Inc.
 
    This file is part of gnulib.
 
    This program is free software; you can redistribute it and/or modify
-   it under the terms of the GNU Lesser General Public License as published by
+   it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2, or (at your option)
    any later version.
 
    This program 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 Lesser General Public License for more details.
+   GNU General Public License for more details.
 
-   You should have received a copy of the GNU Lesser General Public License along
-   with this program; if not, see <http://www.gnu.org/licenses/>.  */
+   You should have received a copy of the GNU General Public License along
+   with this program; if not, see <https://www.gnu.org/licenses/>.  */
 
 #ifndef _@GUARD_PREFIX@_POLL_H
 
@@ -33,6 +33,13 @@
 #ifndef _@GUARD_PREFIX@_POLL_H
 #define _@GUARD_PREFIX@_POLL_H
 
+/* On native Windows, get the 'struct pollfd' type and the POLL* macro
+   definitions before we override them.  mingw defines them in <winsock2.h>
+   if _WIN32_WINNT >= 0x0600.  */
+#if @HAVE_WINSOCK2_H@
+# include <winsock2.h>
+#endif
+
 
 /* The definitions of _GL_FUNCDECL_RPL etc. are copied here.  */
 
@@ -41,6 +48,21 @@
 
 #if !@HAVE_POLL_H@
 
+# if @HAVE_WINSOCK2_H@
+/* Override the definitions from <winsock2.h>.  */
+#  undef POLLIN
+#  undef POLLPRI
+#  undef POLLOUT
+#  undef POLLERR
+#  undef POLLHUP
+#  undef POLLNVAL
+#  undef POLLRDNORM
+#  undef POLLRDBAND
+#  undef POLLWRNORM
+#  undef POLLWRBAND
+#  define pollfd rpl_pollfd
+# endif
+
 /* fake a poll(2) environment */
 # define POLLIN      0x0001      /* any readable data available   */
 # define POLLPRI     0x0002      /* OOB/Urgent readable data      */
diff --git a/m4/poll.m4 b/m4/poll.m4
index 5706ab514..354d1666b 100644
--- a/m4/poll.m4
+++ b/m4/poll.m4
@@ -1,5 +1,5 @@
-# poll.m4 serial 17
-dnl Copyright (c) 2003, 2005-2007, 2009-2017 Free Software Foundation, Inc.
+# poll.m4 serial 19
+dnl Copyright (c) 2003, 2005-2007, 2009-2019 Free Software Foundation, Inc.
 dnl This file is free software; the Free Software Foundation
 dnl gives unlimited permission to copy and/or distribute it,
 dnl with or without modifications, as long as this notice is preserved.
@@ -8,6 +8,7 @@ AC_DEFUN([gl_FUNC_POLL],
 [
   AC_REQUIRE([gl_POLL_H])
   AC_REQUIRE([gl_SOCKETS])
+  AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
   if test $ac_cv_header_poll_h = no; then
     ac_cv_func_poll=no
     gl_cv_func_poll=no
@@ -53,16 +54,19 @@ AC_DEFUN([gl_FUNC_POLL],
 #if (defined(__APPLE__) && defined(__MACH__)) || defined(_AIX)
 This is MacOSX or AIX
 #endif
-], [gl_cv_func_poll=no], [gl_cv_func_poll=yes])])])
-  fi
-  if test $gl_cv_func_poll != yes; then
-    AC_CHECK_FUNC([poll], [ac_cv_func_poll=yes], [ac_cv_func_poll=no])
-    if test $ac_cv_func_poll = no; then
-      HAVE_POLL=0
-    else
-      REPLACE_POLL=1
-    fi
+], [gl_cv_func_poll="guessing no"], [gl_cv_func_poll="guessing yes"])])])
   fi
+  case "$gl_cv_func_poll" in
+    *yes) ;;
+    *)
+      AC_CHECK_FUNC([poll], [ac_cv_func_poll=yes], [ac_cv_func_poll=no])
+      if test $ac_cv_func_poll = no; then
+        HAVE_POLL=0
+      else
+        REPLACE_POLL=1
+      fi
+      ;;
+  esac
   if test $HAVE_POLL = 0 || test $REPLACE_POLL = 1; then
     :
   else
diff --git a/m4/poll_h.m4 b/m4/poll_h.m4
index b3d6dab5a..8f0e10528 100644
--- a/m4/poll_h.m4
+++ b/m4/poll_h.m4
@@ -1,5 +1,5 @@
-# poll_h.m4 serial 2
-dnl Copyright (C) 2010-2017 Free Software Foundation, Inc.
+# poll_h.m4 serial 3
+dnl Copyright (C) 2010-2019 Free Software Foundation, Inc.
 dnl This file is free software; the Free Software Foundation
 dnl gives unlimited permission to copy and/or distribute it,
 dnl with or without modifications, as long as this notice is preserved.
@@ -23,6 +23,8 @@ AC_DEFUN([gl_POLL_H],
   dnl <poll.h> is always overridden, because of GNULIB_POSIXCHECK.
   gl_CHECK_NEXT_HEADERS([poll.h])
 
+  gl_PREREQ_SYS_H_WINSOCK2 dnl for HAVE_WINSOCK2_H
+
   dnl Check for declarations of anything we want to poison if the
   dnl corresponding gnulib module is not in use.
   gl_WARN_ON_USE_PREPARE([[#include <poll.h>]],
-- 
2.22.0

0002-Fix-error-missing-netinet-tcp_h-on-mingw-w64.patch

From 88729a1d3d136013419c60cb022255af6112208a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hannes=20M=C3=BCller?= <h.c.f.mueller@gmx.de>
Date: Wed, 3 Jul 2019 11:33:21 +0200
Subject: [PATCH] Fix compilation error for missing <netinet/tcp.h> on
 mingw-w64

* libguile/socket.c: exclude <netinet/tcp.h> on mingw-w64
---
 libguile/socket.c | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

diff --git a/libguile/socket.c b/libguile/socket.c
index 64354f1f1..f080cb8a0 100644
--- a/libguile/socket.c
+++ b/libguile/socket.c
@@ -40,7 +40,9 @@
 #include <sys/un.h>
 #endif
 #include <netinet/in.h>
-#include <netinet/tcp.h>
+#ifndef __MINGW32__
+# include <netinet/tcp.h>
+#endif
 #include <netdb.h>
 #include <arpa/inet.h>
 
-- 
2.22.0

0004-Fix-posix.c-for-mingw-w64.patch

From d0fa92bc6f44c27a483521a9aa08d719763efcc5 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hannes=20M=C3=BCller?= <h.c.f.mueller@gmx.de>
Date: Thu, 11 Jul 2019 09:49:33 +0200
Subject: [PATCH] Fix posix.c for mingw-w64

Fix warning "Please include winsock2.h before windows.h" on i686
Fix link error with gethostname on x86_64
* libguile/posix.c: for mingw-w64 add #undef gethostname
  directly after unitstd.h which otherwise is
  gethostname_used_without_requesting_gnulib_module_gethostname
  on x86_64 and causes an link error
  also add #include <winsock2.h> to fix warning on i686
---
 libguile/posix.c | 5 +++++
 1 file changed, 5 insertions(+)

diff --git a/libguile/posix.c b/libguile/posix.c
index 728b18b67..c4ed4e6b6 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -33,6 +33,11 @@
 #include <uniconv.h>
 #include <unistd.h>
 
+#ifdef __MINGW32__
+# undef gethostname
+# include <winsock2.h>
+#endif
+
 #ifdef HAVE_SCHED_H
 # include <sched.h>
 #endif
-- 
2.22.0

0006-vm-Don-t-call-madvise-when-using-MinGW.patch

From 7dba825b8275cc1f6efacd1ae6189afb24156e70 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson@vistahigherlearning.com>
Date: Thu, 25 Jul 2019 14:52:39 -0400
Subject: [PATCH] vm: Don't call madvise when using MinGW.

---
 libguile/vm.c | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/libguile/vm.c b/libguile/vm.c
index d7b1788d8..6e4f0a3d1 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -628,6 +628,7 @@ scm_i_vm_prepare_stack (struct scm_vm *vp)
 static void
 return_unused_stack_to_os (struct scm_vm *vp)
 {
+#ifndef __MINGW32__
 #if HAVE_SYS_MMAN_H
   uintptr_t lo = (uintptr_t) vp->stack_bottom;
   uintptr_t hi = (uintptr_t) vp->sp;
@@ -657,6 +658,7 @@ return_unused_stack_to_os (struct scm_vm *vp)

   vp->sp_min_since_gc = vp->sp;
 #endif
+#endif /* __MINGW32__ */
 }

 #define SLOT_MAP_CACHE_SIZE 32U
--
2.17.1

guile.scm

;;; Copyright © 2019 David Thompson <davet@gnu.org>
;;;
;;; This code 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 3 of the License,
;;; or (at your option) any later version.
;;;
;;; This code 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 this code.  If not, see <http://www.gnu.org/licenses/>.

;;;
;;; Instructions:
;;;

;; To build this binary bundle for Windows, run:
;;
;;     guix build --target=i686-w64-mingw32 -f guile.scm

(use-modules (ice-9 match)
             (guix build-system gnu)
             (guix build-system trivial)
             (guix download)
             (guix git-download)
             ((guix licenses) #:prefix license:)
             (guix packages)
             (guix utils)
             (gnu packages)
             (gnu packages autotools)
             (gnu packages base)
             (gnu packages bdw-gc)
             (gnu packages cross-base)
             (gnu packages compression)
             (gnu packages gettext)
             (gnu packages guile)
             (gnu packages libffi)
             (gnu packages libunistring)
             (gnu packages mingw)
             (gnu packages multiprecision)
             (gnu packages pkg-config)
             (gnu packages texinfo)
             (srfi srfi-1))

(define (patch-files . patches)
  (let ((dir (dirname (current-filename))))
    (map (lambda (patch)
           (string-append dir "/" patch))
         patches)))

(define pthreads-win32
  (package
   (name "pthreads-win32")
   (version "2.9.1")
   (source (origin
            (method url-fetch)
            (uri "ftp://sourceware.org/pub/pthreads-win32/pthreads-w32-2-9-1-release.tar.gz")
            (sha256
             (base32
              "0kgvjny6cyvwmiiy5x539g77l2pclc73mjqbb34djcyym2pagb76"))))
   (build-system gnu-build-system)
   (arguments
    `(#:make-flags
      '("GC"
        ,(string-append "CROSS=" (or (%current-target-system) (%current-system)) "-"))
      #:phases
      (modify-phases %standard-phases
        (delete 'configure)
        (replace 'build
          (lambda* (#:key (make-flags '()) (parallel-build? #t) #:allow-other-keys)
            (apply invoke "make" "clean"
                   `(,@(if parallel-build?
                           `("-j" ,(number->string (parallel-job-count)))
                           '())
                     ,@make-flags))))
        (replace 'install
          (lambda* (#:key outputs #:allow-other-keys)
            (let* ((out (assoc-ref outputs "out"))
                   (bindir (string-append out "/bin"))
                   (libdir (string-append out "/lib"))
                   (includedir (string-append out "/include")))
              (mkdir-p bindir)
              (mkdir-p libdir)
              (mkdir-p includedir)
              (install-file "pthreadGC2.dll" bindir)
              (copy-file "libpthreadGC2.a"
                         (string-append libdir "/libpthread.a"))
              (install-file "pthread.h" includedir)
              (install-file "sched.h" includedir)
              (install-file "semaphore.h" includedir)))))))
   (synopsis "POSIX threads compatibility layer for Windows")
   (description "Pthreads-win32 provides a Windows compatibility layer
for the POSIX threads API.")
   (home-page "https://sourceware.org/pthreads-win32/")
   (license license:lgpl2.1)))

(define base-guile guile-2.2)

(define guile-mingw
  (package
   (inherit base-guile)
   (source (origin
            (inherit (package-source base-guile))
            (patches (patch-files "0001-Get-latest-poll-module-from-gnulib-to-fix-compilatio.patch"
                                  "0002-Fix-error-missing-netinet-tcp_h-on-mingw-w64.patch"
                                  "0004-Fix-posix.c-for-mingw-w64.patch"
                                  "0006-vm-Don-t-call-madvise-when-using-MinGW.patch"))))
   (arguments
    (append '(#:tests? #f
              #:make-flags
              '("CFLAGS=-DHAVE_GC_IS_HEAP_PTR=1 -DHAVE_GC_MOVE_DISAPPEARING_LINK=1"))
            (substitute-keyword-arguments (package-arguments base-guile)
              ((#:phases phases)
               `(modify-phases ,phases
                  (add-after 'unpack 'bootstrap
                             (lambda _
                               (substitute* '("build-aux/git-version-gen")
                                            (("/bin/sh") (which "bash")))
                               (invoke "autoreconf" "-vif"))))))))
   (native-inputs
    (append `(("autoconf" ,autoconf)
              ("automake" ,automake)
              ("gettext" ,gnu-gettext)
              ("libtool" ,libtool)
              ("texinfo" ,texinfo))
            (package-native-inputs base-guile)))
   (inputs
    (append `(("pthreads" ,pthreads-win32))
            (package-inputs base-guile)))))

(define guile-bundle-mingw
  (package
   (name "guile-bundle-mingw")
   (version "0")
   (source #f)
   (build-system trivial-build-system)
   (arguments
    `(#:modules ((guix build utils))
      #:builder
      (begin
        (use-modules (guix build utils))
        (let* ((guile (assoc-ref %build-inputs "guile"))
               (libffi (assoc-ref %build-inputs "libffi"))
               (libgc (assoc-ref %build-inputs "bdw-gc"))
               (gmp (assoc-ref %build-inputs "gmp"))
               (libiconv (assoc-ref %build-inputs "libiconv"))
               (libltdl (assoc-ref %build-inputs "libltdl"))
               (libunistring (assoc-ref %build-inputs "libunistring"))
               (pthreads (assoc-ref %build-inputs "pthreads"))
               (cross-gcc (assoc-ref %build-inputs "cross-gcc"))
               (out (string-append (assoc-ref %outputs "out") "/guile-win32"))
               (bindir (string-append out "/bin"))
               (libdir (string-append out "/lib"))
               (sharedir (string-append out "/share")))
          ;; Copy Guile modules (source and bytecode).
          (copy-recursively (string-append guile "/lib/guile")
                            (string-append libdir "/guile"))
          (copy-recursively (string-append guile "/share/guile")
                            (string-append sharedir "/guile"))
          ;; Copy native binaries.
          (for-each (lambda (file)
                      (install-file file bindir))
                    (list
                     ;; Guile
                     (string-append guile "/bin/guile.exe")
                     (string-append guile "/bin/libguile-2.2-1.dll")
                     ;; Guile dependencies
                     (string-append libffi "/bin/libffi-6.dll")
                     (string-append libgc "/bin/libgc-1.dll")
                     (string-append gmp "/bin/libgmp-10.dll")
                     (string-append libiconv "/bin/libiconv-2.dll")
                     (string-append libltdl "/bin/libltdl-7.dll")
                     (string-append libunistring "/bin/libunistring-2.dll")
                     (string-append pthreads "/bin/pthreadGC2.dll")
                     (string-append cross-gcc "/" ,(%current-target-system)
                                    "/lib/libgcc_s_sjlj-1.dll")
                     (string-append cross-gcc "/" ,(%current-target-system)
                                    "/lib/libstdc++-6.dll")))
          ;; Add launcher script.
          (call-with-output-file (string-append out "/guile.bat")
            (lambda (port)
              (display "ECHO OFF\r\n" port)
              (display "SET currentdir=%~dp0%\r\n" port)
              (display "SET GUILE_LOAD_PATH=%currentdir%share\\guile\\site\\2.2;%currentdir%share\\guile\\2.2\r\n" port)
              (display "SET GUILE_LOAD_COMPILED_PATH=%currentdir%lib\\guile\\2.2\\site-ccache;%currentdir%lib\\guile\\2.2\\ccache\r\n" port)
              (display "bin\\guile.exe\r\n" port))))
        #t)))
   (native-inputs
    `(("cross-gcc" ,(cross-gcc (%current-target-system)
                               #:libc mingw-w64))))
   (inputs
    `(("bdw-gc" ,libgc)
      ("gmp" ,gmp)
      ("guile" ,guile-mingw)
      ("libffi" ,libffi)
      ("libiconv" ,libiconv)
      ("libltdl" ,libltdl)
      ("libunistring" ,libunistring)
      ("pthreads" ,pthreads-win32)))
   (synopsis "Guile bundle for Windows")
   (description "A minimal bundle of the Guile runtime for Windows.")
   (home-page "https://gnu.org/s/guile")
   (license (package-license guile-mingw))))

guile-bundle-mingw