Preliminary native windows support, part 2: standard library and libg…

…erbil

src/build/build-libgerbil.ss

@@ -25,6 +25,8 @@
   (def default-ld-options "-lutil"))
  (netbsd
   (def default-ld-options "-lm"))
+ (visualc
+  (def default-ld-options "/link Kernel32.Lib User32.Lib Gdi32.Lib WS2_32.Lib /subsystem:console /entry:WinMainCRTStartup"))
  (else
   (def default-ld-options "-ldl -lm")))
 
@@ -244,8 +246,24 @@
 (def (module-c-file f)
   (file-replace-extension f ".c"))
 
+(def compiler-obj-suffix
+  (cond-expand
+    (visualc ".obj")
+    (else ".o")))
+
+; generates an `include` form for use in a source code, gsc's -e option etc.
+; It takes care of windows paths where we need to escape the path.
+; e.g. (displayln (include-source "d:\\gerbil\\mycode.scm")) should print
+; (include "d:\\gerbil\\mycode.scm")
+; instead of:
+; (include "d:\gerbil\mycode.scm")
+; which results in an error:
+; *** ERROR -- Invalid escaped character: #\g
+(def (include-source path)
+  (string-append "(include " (object->string path) ")"))
+
 (def (module-o-file f)
-  (file-replace-extension f ".o"))
+  (file-replace-extension f compiler-obj-suffix))
 
 (def (library-file-path f)
   (path-expand f (gerbil-lib-dir)))
@@ -323,8 +341,7 @@
          (static-module-c-paths   (map module-c-file static-module-scm-paths))
          (static-module-o-paths   (map module-o-file static-module-c-paths))
          (gambit-sharp (library-file-path "_gambit#.scm"))
-         (include-gambit-sharp
-          (string-append "(include \"" gambit-sharp "\")"))
+         (include-gambit-sharp (include-source gambit-sharp))
          (gsc-gx-macros
           (if (gerbil-runtime-smp?)
             ["-e" "(define-cond-expand-feature|enable-smp|)"

src/gerbil/expander/module.ss

@@ -38,7 +38,10 @@ namespace: gx
 (def current-module-reader-args
   (make-parameter #f))
 
-(def source-file-settings '(char-encoding: UTF-8 eol-encoding: lf))
+(def source-file-settings
+  (cond-expand
+    (visualc '(char-encoding: UTF-8 eol-encoding: cr-lf))
+    (else '(char-encoding: UTF-8 eol-encoding: lf))))
 
 (def (call-with-input-source-file path fun)
   (call-with-input-file [path: path . source-file-settings] fun))

src/std/build-spec.ss

@@ -201,9 +201,15 @@
     "text/json/api"
     "text/json"
     ,@(if config-enable-zlib
-        `((gsc: "text/_zlib"
-                "-cc-options" ,(cppflags "zlib" "")
-                "-ld-options" ,(ldflags "zlib" "-lz"))
+        `(,(cond-expand
+            (visualc
+             `(gsc: "text/_zlib"
+               "-cc-options" ,(cppflags "zlib" "")
+               "-ld-options" ,(ldflags "zlib" "zlibstatic.lib")))
+            (else
+             `(gsc: "text/_zlib"
+               "-cc-options" ,(cppflags "zlib" "")
+               "-ld-options" ,(ldflags "zlib" "-lz"))))
           (ssi: "text/_zlib")
           "text/zlib")
         '())
@@ -219,6 +225,10 @@
                            (if (enable-shared?)
                              [(string-append "-L" (gerbil-libdir)) "-lgambit"]
                              []))))
+      (visualc 
+       `(gxc: "net/ssl/libssl"
+	      "-cc-options" ,(cppflags "libssl" "")
+	      "-ld-options" ,(ldflags "libssl" "libssl.lib libcrypto.lib")))
       (else `(gxc: "net/ssl/libssl"
 		   "-ld-options" ,(ldflags "libssl" "-lssl"))))
     "net/ssl/error"
@@ -257,16 +267,16 @@
     "net/socks"
     ;; std/os
     (gxc: "os/error" ,@(include-gambit-sharp))
-    (gxc: "os/fd" ,@(include-gambit-sharp))
-    (gxc: "os/fdio" ,@(include-gambit-sharp))
-    (gxc: "os/fcntl" ,@(include-gambit-sharp))
-    (gxc: "os/flock" ,@(include-gambit-sharp))
-    (gxc: "os/pipe" ,@(include-gambit-sharp))
+    (gxc: "os/fd"    ,@(include-gambit-sharp))
+    (gxc: "os/fdio"  ,@(non-posix-extra-gsc-options) ,@(include-gambit-sharp))
+    (gxc: "os/fcntl" ,@(non-posix-extra-gsc-options) ,@(include-gambit-sharp))
+    (gxc: "os/flock" ,@(non-posix-extra-gsc-options) ,@(include-gambit-sharp))
+    (gxc: "os/pipe"  ,@(non-posix-extra-gsc-options) ,@(include-gambit-sharp))
     ,(cond-expand
        (linux
         `(gsc: "os/_socket" "-cc-options" "-D_GNU_SOURCE -Wno-implicit-function-declaration" ,@(include-gambit-sharp)))
        (else
-        `(gsc: "os/_socket" ,@(include-gambit-sharp))))
+        `(gsc: "os/_socket" ,@(non-posix-extra-gsc-options) ,@(include-gambit-sharp))))
     (ssi: "os/_socket")
     "os/socket"
     ,@(cond-expand
@@ -282,9 +292,9 @@
          `((gxc: "os/signalfd" ,@(include-gambit-sharp))))
         (else '()))
     "os/signal-handler"
-    "os/pid"
+    (gxc: "os/pid" ,@(non-posix-extra-gsc-options))
     "os/temporaries"
-    "os/hostname"
+    (gxc: "os/hostname" ,@(non-posix-extra-gsc-options))
     ,@(if config-enable-deprecated
         ;; :std/net/bio -- DEPRECATED
         ["net/bio/input"
@@ -339,10 +349,17 @@
     "xml"
     ;; :std/crypto
     (static-include: "crypto/libcrypto-rfc5114.c")
-    (gxc: "crypto/libcrypto"
-          "-cc-options" ,(append-options (cppflags "libcrypto" "") "-Wno-deprecated-declarations -Wno-implicit-function-declaration")
-          "-ld-options" ,(ldflags "libcrypto" "-lcrypto")
-          ,@(include-gambit-sharp))
+    ,(cond-expand
+        (visualc 
+          `(gxc: "crypto/libcrypto"
+            "-cc-options" ,(append-options (cppflags "libcrypto" "") "")
+            "-ld-options" ,(ldflags "libcrypto" "libcrypto.lib")
+            ,@(include-gambit-sharp)))
+        (else
+          `(gxc: "crypto/libcrypto"
+            "-cc-options" ,(append-options (cppflags "libcrypto" "") "-Wno-deprecated-declarations -Wno-implicit-function-declaration")
+            "-ld-options" ,(ldflags "libcrypto" "-lcrypto")
+            ,@(include-gambit-sharp))))
     (gxc: "crypto/etc" ,@(include-gambit-sharp))
     "crypto/digest"
     "crypto/cipher"
@@ -436,9 +453,15 @@
     "db/postgresql-driver"
     "db/postgresql"
     ,@(if config-enable-sqlite
-        `((gsc: "db/_sqlite"
+        `(,(cond-expand
+            (visualc
+              `(gsc: "db/_sqlite"
+                "-cc-options" ,(cppflags "sqlite3" "")
+                "-ld-options" ,(append-options (ldflags "sqlite3" "sqlite3.lib") "")))
+            (else
+              `(gsc: "db/_sqlite"
                 "-cc-options" ,(cppflags "sqlite3" "")
-                "-ld-options" ,(append-options (ldflags "sqlite3" "-lsqlite3") "-lm"))
+                "-ld-options" ,(append-options (ldflags "sqlite3" "-lsqlite3") "-lm"))))
           (ssi: "db/_sqlite")
           "db/sqlite")
         '())))

src/std/crypto/libcrypto.ss

@@ -127,6 +127,10 @@ END-C
 
 ;; error handling
 (c-declare #<<END-C
+#ifdef _MSC_VER
+#define __thread __declspec(thread)
+#endif
+
 __thread char openssl_error_buf[256];
 static char *ffi_openssl_error_string(unsigned long err)
 {

src/std/make.ss

@@ -20,6 +20,7 @@
         env-cppflags
         env-ldflags
         include-gambit-sharp
+        non-posix-extra-gsc-options
         pkg-config
         pkg-config-libs
         pkg-config-cflags
@@ -448,19 +449,36 @@ TODO:
    (else
     identity)))
 
+; generates an `include` form for use in a source code, gsc's -e option etc.
+; It takes care of windows paths where we need to escape the path.
+; e.g. (displayln (include-source "d:\\gerbil\\mycode.scm")) should print
+; (include "d:\\gerbil\\mycode.scm")
+; instead of:
+; (include "d:\gerbil\mycode.scm")
+; which results in an error:
+; *** ERROR -- Invalid escaped character: #\g
+(def (include-source path)
+  (string-append "(include " (object->string path) ")"))
+
 (def (include-gambit-sharp)
   (let* ((gambit-sharp
           (path-expand "lib/_gambit#.scm"
                        (getenv "GERBIL_BUILD_PREFIX" (gerbil-home))))
-         (include-gambit-sharp
-          (string-append "(include \"" gambit-sharp "\")")))
+         (include-gambit-sharp (include-source gambit-sharp)))
     (cond
      ((gerbil-runtime-smp?)
       `("-e" "(define-cond-expand-feature|enable-smp|)"
         "-e" ,include-gambit-sharp))
      (else
       `("-e" ,include-gambit-sharp)))))
 
+(def (non-posix-extra-gsc-options)
+  (cond-expand
+    (visualc 
+       `("-cc-options" ,((env-cppflags) "")))
+    (else
+       `())))
+
 (def (build spec settings)
   (match spec
     ((? string? modf)

src/std/net/httpd/handler.ss

@@ -302,15 +302,23 @@
 
 (begin-ffi (http-date)
   (c-declare #<<END-C
+#ifdef _MSC_VER
+#define __thread __declspec(thread)
+#endif
+
 #include <time.h>
 #include <string.h>
 __thread char date_buf[64];
 static char *ffi_httpd_date () {
+#ifndef _WINDOWS
  struct tm tm;
  time_t t = time(NULL);
  asctime_r (gmtime_r (&t, &tm), date_buf);
  // clobber newline
  date_buf[strlen(date_buf)-1] = 0;
+#else
+ date_buf[0] = 0;
+#endif
  return date_buf;
 }
 END-C

src/std/net/ssl/libssl.ss

@@ -338,6 +338,10 @@ static SSL_CTX *ffi_actor_tls_ctx(const char *caroot, const char *ca_file, const
  return ctx;
 }
 
+#ifdef _MSC_VER
+#define __thread __declspec(thread)
+#endif
+
 __thread char openssl_x509_name_buf[16384];
 static char *ffi_X509_get_subject_name(X509 *cert)
 {

src/std/os/_socket.scm

@@ -18,12 +18,26 @@
 (c-declare #<<END-C
 #include <errno.h>
 #include <sys/types.h>
+#ifdef _WINDOWS
+#include <winsock2.h>
+#include <ws2tcpip.h>
+
+// workaround: define mandatory consts
+// constants defined by define-const* (e.g. AF_NETLINK) is optional
+// TODO: check their actual values
+#define AF_LOCAL  0
+#define SHUT_RD   0
+#define SHUT_WR   0
+#define SHUT_RDWR 0
+
+#else
 #include <sys/socket.h>
 #include <netinet/in.h>
 #include <netinet/ip.h>
 #include <netinet/tcp.h>
 #include <arpa/inet.h>
 #include <sys/un.h>
+#endif
 #include <sys/time.h>
 #include <stdlib.h>
 #include <string.h>
@@ -456,8 +470,10 @@ static socklen_t ___sockaddr_family_len (int family)
    return sizeof (struct sockaddr_in);
   case AF_INET6:
    return sizeof (struct sockaddr_in6);
+#ifndef _WINDOWS
   case AF_UNIX:
    return sizeof (struct sockaddr_un);
+#endif
 #ifdef __linux__
   case AF_NETLINK:
    return sizeof (struct sockaddr_nl);
@@ -531,6 +547,7 @@ int ffi_socket_sendto (int fd, ___SCMOBJ bytes, int start, int end, int flags, s
 
 int ffi_socket_sendmsg (int fd, ___SCMOBJ name, ___SCMOBJ io, ___SCMOBJ ctl, int flags)
 {
+#ifndef _WINDOWS
  void *msg_name = NULL;
  socklen_t msg_namelen = 0;
  struct iovec msg_iov = {NULL, 0};
@@ -565,6 +582,9 @@ int ffi_socket_sendmsg (int fd, ___SCMOBJ name, ___SCMOBJ io, ___SCMOBJ ctl, int
  msg.msg_flags = 0;
 
  return sendmsg (fd, &msg, flags);
+#else
+ return 0;
+#endif
 }
 
 int ffi_socket_recv (int fd, ___SCMOBJ bytes, int start, int end, int flags)
@@ -580,6 +600,7 @@ int ffi_socket_recvfrom (int fd, ___SCMOBJ bytes, int start, int end, int flags,
 
 int ffi_socket_recvmsg (int fd, ___SCMOBJ name, int *rname, ___SCMOBJ io, ___SCMOBJ ctl, int *rctl, int flags, int *rflags)
 {
+#ifndef _WINDOWS
  void *msg_name = NULL;
  socklen_t msg_namelen = 0;
  struct iovec msg_iov = {NULL, 0};
@@ -624,6 +645,9 @@ int ffi_socket_recvmsg (int fd, ___SCMOBJ name, int *rname, ___SCMOBJ io, ___SCM
   *rflags = msg.msg_flags;
 
  return r;
+#else
+ return 0;
+#endif
 }
 
 int ffi_socket_getpeername (int fd, struct sockaddr *sa)
@@ -703,14 +727,20 @@ void ffi_socket_sockaddr_in6_port_set (struct sockaddr *sa, int port)
 
 char *ffi_socket_sockaddr_un_path (struct sockaddr *sa)
 {
+#ifndef _WINDOWS
  struct sockaddr_un *sa_un = (struct sockaddr_un*)sa;
  return sa_un->sun_path;
+#else
+ return NULL;
+#endif
 }
 
 void ffi_socket_sockaddr_un_path_set (struct sockaddr *sa, char *path)
 {
+#ifndef _WINDOWS
  struct sockaddr_un *sa_un = (struct sockaddr_un*)sa;
  strncpy (sa_un->sun_path, path, sizeof (sa_un->sun_path));
+#endif
 }
 
 int ffi_socket_sockaddr_len (struct sockaddr *sa)

src/std/os/error.ss

@@ -134,6 +134,13 @@
   (c-declare "#include <errno.h>")
   (c-declare "#include <string.h>")
 
+  ; I don't know why, but it's the only error code msvc doesn't define
+  (c-declare "
+  #ifdef _WINDOWS
+  #define ENOTBLK 15
+  #endif
+  ")
+
   (define-const EPERM)
   (define-const ENOENT)
   (define-const ESRCH)