Merge pull request #446 from okuoku/win32-cmake

Win32: Wrap-up

AUTHORS

@@ -50,6 +50,7 @@ Thanks to the following people for patches and bug reports:
   * Stephen Lewis
   * Taylor Venable
   * Travis Cross
+  * Yuki Okumura
 
 If you would prefer not to be listed, or are one of the users listed
 without a full name, please contact me.  If you've made a contribution

CMakeLists.txt

@@ -249,3 +249,44 @@ foreach(e ${chibi-scheme-tests})
         COMMAND chibi-scheme tests/${e}.scm
         WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
 endforeach()
+
+message(STATUS "Detecting library tests")
+
+file(GLOB_RECURSE srfi_tests RELATIVE ${CMAKE_CURRENT_SOURCE_DIR}/lib
+    ${CMAKE_CURRENT_SOURCE_DIR}/lib/srfi/*/test.sld)
+
+file(GLOB_RECURSE chibi_scheme_tests RELATIVE ${CMAKE_CURRENT_SOURCE_DIR}/lib
+    ${CMAKE_CURRENT_SOURCE_DIR}/lib/chibi/*-test.sld)
+
+set(testexcludes
+    # Excluded tests
+    chibi/filesystem-test
+    chibi/memoize-test
+    chibi/term/ansi-test
+    chibi/weak-test
+
+    # Not ported to Win32
+    srfi/18/test # Threading
+    chibi/doc-test # Depends (chibi time)
+    chibi/system-test
+    chibi/tar-test # Depends (chibi system)
+    )
+
+set(testlibs)
+foreach(e ${srfi_tests} ${chibi_scheme_tests})
+    get_filename_component(pth ${e} PATH)
+    get_filename_component(nam ${e} NAME_WE)
+    list(APPEND testlibs ${pth}/${nam})
+endforeach()
+list(REMOVE_ITEM testlibs ${testexcludes})
+
+foreach(e ${testlibs})
+    string(REGEX REPLACE "/" "_" testname ${e})
+    string(REGEX REPLACE "/" " " form ${e})
+    add_test(NAME "lib_${testname}"
+        COMMAND chibi-scheme -e "(import (${form}))"
+        -e "(run-tests)"
+        WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
+    message(STATUS "Test ${testname}")
+endforeach()
+

Makefile

@@ -24,11 +24,23 @@ TEMPFILE := $(shell mktemp -t chibi.XXXXXX)
 
 ########################################################################
 
+# Choose compiled library on MSYS
+ifeq ($(OS), Windows_NT)
+ifeq ($(PLATFORM),msys)
+EXCLUDE_WIN32_LIBS=1
+else
+EXCLUDE_POSIX_LIBS=1
+endif
+endif
+
+########################################################################
+
 CHIBI_COMPILED_LIBS = lib/chibi/filesystem$(SO) lib/chibi/weak$(SO) \
 	lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) lib/chibi/ast$(SO) \
 	lib/chibi/emscripten$(SO)
 CHIBI_POSIX_COMPILED_LIBS = lib/chibi/process$(SO) lib/chibi/time$(SO) \
 	lib/chibi/system$(SO) lib/chibi/stty$(SO) lib/chibi/net$(SO) 
+CHIBI_WIN32_COMPILED_LIBS = lib/chibi/win32/process-win32$(SO)
 CHIBI_CRYPTO_COMPILED_LIBS = lib/chibi/crypto/crypto$(SO)
 CHIBI_IO_COMPILED_LIBS = lib/chibi/io/io$(SO)
 CHIBI_OPT_COMPILED_LIBS = lib/chibi/optimize/rest$(SO) \
@@ -37,6 +49,8 @@ EXTRA_COMPILED_LIBS ?=
 
 ifndef EXCLUDE_POSIX_LIBS
 CHIBI_COMPILED_LIBS += $(CHIBI_POSIX_COMPILED_LIBS)
+else
+CHIBI_COMPILED_LIBS += $(CHIBI_WIN32_COMPILED_LIBS)
 endif
 
 COMPILED_LIBS = $(CHIBI_COMPILED_LIBS) $(CHIBI_IO_COMPILED_LIBS) \

README-win32.md

@@ -0,0 +1,81 @@
+Chibi-scheme for Windows
+========================
+
+Chibi-scheme provides limited support for native desktop Windows. To use 
+fully-featured Chibi-scheme on Windows, consider using POSIX layer such as
+Windows Subsytem for Linux(WSL), Cygwin or MSYS.
+
+Currently, only R7RS Small libraries are available for the platform. 
+
+Supported Environments
+----------------------
+
+Chibi-scheme can be compiled with following platforms:
+
+* Microsoft Visual Studio 2017 (32bit only)
+* MinGW32
+* MinGW64
+* MSYS
+
+
+Known Issues
+------------
+
+Following libraries are not ported yet:
+
+* `(chibi net)`
+* `(chibi process)` : `exit` is available through `(scheme process-context)`
+* `(chibi stty)`
+* `(chibi system)`
+* `(chibi time)`
+
+Following library is not completely ported:
+
+* `(chibi filesystem)`
+
+Other issues:
+
+* SRFI-27: Due to C Runtime limitation, the library is not thread-safe
+* `make install` is not supported on Windows platforms
+* On MSVC, flonum precision is degraded when compared with other compilers
+* Cross compilation is not supported
+
+
+Build with MinGW(Makefile)
+--------------------------
+
+The top-level `Makefile` can be used with MinGW.
+
+1. Open MinGW64 or MinGW32 command prompt
+2. `make`
+3. `make test`
+
+Currently, `make doc` is not supported on these platforms.
+
+
+Build with MSYS(Makefile)
+-------------------------
+
+By default, the Makefile will compile against native Windows API. To use
+MSYS's own POSIX emulation layer, specify `PLATFORM=msys`.
+
+1. Open MSYS command prompt
+2. `make PLATFORM=msys`
+3. `make PLATFORM=msys test`
+
+
+Build with Visual Studio(CMake)
+-------------------------------
+
+Minimal `CMakeLists.txt` is provided as an example to build Chibi-scheme on
+Windows platforms. This is only intended to be used with Windows platforms;
+currently it does not provide features provided with standard `Makefile` nor
+it does not support UNIX/APPLE platforms either.
+
+1. (Make sure CMake was selected with Visual Studio installer)
+2. Open this directory with "Open with Visual Studio"
+3. Choose "x86-Release" or "x86-Debug" configuration
+4. "CMake" => "Build all"
+5. "CMake" => "Run Tests" => "chibi-scheme"
+
+

README.md

@@ -22,6 +22,8 @@ a smaller language on startup.
 Chibi-Scheme is known to work on **32** and **64-bit** Linux,
 FreeBSD and OS X, Plan 9, Windows (using Cygwin), iOS, Android,
 ARM and [Emscripten](https://kripken.github.io/emscripten-site).
+Basic support for native Windows desktop also exists. See 
+README-win32.md for details and build instructions.
 
 To build on most platforms just run `make && make test`.  This will
 provide a shared library *libchibi-scheme*, as well as a sample

appveyor.yml

@@ -32,7 +32,7 @@ before_build:
     - if %BUILDTYPE%.==x86MinGW. set CC=c:/msys64/mingw32/bin/gcc
     - if %BUILDTYPE%.==x64MSYS. set CC=gcc
     - if %TOOLCHAIN%.==MSVC. set CC=cl.exe
-    - if %TOOLCHAIN%%BUILDSYSTEM%.==MinGWMSYS2. set EXARG=EXCLUDE_POSIX_LIBS=1
+    - if %TOOLCHAIN%%BUILDSYSTEM%.==MinGWMSYS2. set EXARG=
     - if %TOOLCHAIN%%BUILDSYSTEM%.==MSYSMSYS2. set EXARG=PLATFORM=msys
     - if %BUILDSYSTEM%.==CMAKE. cmake -G Ninja .
 

include/chibi/sexp.h

@@ -20,11 +20,11 @@ extern "C" {
 #ifdef _WIN32
 #include <windows.h>
 #include <errno.h>
-#define sexp_isalpha(x) ((isalpha)((int)(x)))
-#define sexp_isxdigit(x) ((isxdigit)((int)(x)))
-#define sexp_isdigit(x) ((isdigit)((int)(x)))
-#define sexp_tolower(x) ((tolower)((int)(x)))
-#define sexp_toupper(x) ((toupper)((int)(x)))
+#define sexp_isalpha(x) (isalpha(x))
+#define sexp_isxdigit(x) (isxdigit(x))
+#define sexp_isdigit(x) (isdigit(x))
+#define sexp_tolower(x) (tolower(x))
+#define sexp_toupper(x) (toupper(x))
 #define SEXP_USE_POLL_PORT 0
 #define sexp_poll_input(ctx, port) usleep(SEXP_POLL_SLEEP_TIME)
 #define sexp_poll_output(ctx, port) usleep(SEXP_POLL_SLEEP_TIME)

lib/chibi/ast.c

@@ -10,6 +10,10 @@
 #endif
 
 #ifdef _WIN32
+#if defined(__MINGW32__) || defined(__MINGW64__)
+/* Workaround MinGW header implementation */
+errno_t getenv_s(size_t*, char*, size_t, const char*);
+#endif
 int setenv(const char *name, const char *value, int overwrite)
 {
   int errcode = 0;

lib/chibi/disasm.c

@@ -11,7 +11,11 @@
 #define SEXP_DISASM_PAD_WIDTH 4
 
 #if SEXP_64_BIT
+#ifdef _WIN32
+#define SEXP_PRId "%I64d"
+#else
 #define SEXP_PRId "%ld"
+#endif
 #else
 #define SEXP_PRId "%d"
 #endif

lib/chibi/filesystem.stub

@@ -14,6 +14,7 @@
 
 (cond-expand
   (windows
+   (c-include-verbatim "filesystem_win32_shim.c")
    (define-c-struct stat
     predicate: stat?
     (dev_t      st_dev      stat-dev)
@@ -30,10 +31,6 @@
     (time_t     st_mtime    stat-mtime)
     (time_t     st_ctime    stat-ctime)))
   (else
-   (define-c-type DIR
-    finalizer: closedir)
-   (define-c-struct dirent
-    (string d_name dirent-name))
    (define-c-struct stat
     predicate: stat?
     (dev_t      st_dev      stat-dev)
@@ -51,18 +48,19 @@
     (time_t     st_ctime    stat-ctime))
    ))
 
+(define-c-type DIR
+ finalizer: closedir)
+(define-c-struct dirent
+ (string d_name dirent-name))
 
 
-
-(cond-expand
-  ((not windows)
-   (define-c boolean S_ISREG (mode_t))
-   (define-c boolean S_ISDIR (mode_t))
-   (define-c boolean S_ISCHR (mode_t))
-   (define-c boolean S_ISBLK (mode_t))
-   (define-c boolean S_ISFIFO (mode_t))
-   (define-c boolean S_ISLNK (mode_t))
-   (define-c boolean S_ISSOCK (mode_t))))
+(define-c boolean S_ISREG (mode_t))
+(define-c boolean S_ISDIR (mode_t))
+(define-c boolean S_ISCHR (mode_t))
+(define-c boolean S_ISBLK (mode_t))
+(define-c boolean S_ISFIFO (mode_t))
+(define-c boolean S_ISLNK (mode_t))
+(define-c boolean S_ISSOCK (mode_t))
 
 (cond-expand
  ((not windows)
@@ -152,7 +150,7 @@
   ((not windows)
    (define-c errno (create-directory "mkdir") (string (default #o775 int))))
   (else
-   (define-c errno (create-directory "mkdir") (string))))
+   (define-c errno (create-directory "mkdir_shim") (string (default #o775 int)))))
 
 ;;> Deletes the directory named \var{string} from the filesystem.
 ;;> Does not attempt to delete recursively.
@@ -160,10 +158,8 @@
 
 (define-c errno (delete-directory "rmdir") (string))
 
-(cond-expand
-  ((not windows)
-   (define-c (free DIR) opendir (string))
-   (define-c dirent readdir ((link (pointer DIR))))))
+(define-c (free DIR) opendir (string))
+(define-c dirent readdir ((link (pointer DIR))))
 
 ;;> Duplicates the given file descriptor, returning he new value,
 ;; or -1 on failure.
@@ -248,11 +244,9 @@
     (port-or-fileno off_t))))
 
 ;; Used for file-is-readable?, file-is-writable?, file-is-executable?.
-(cond-expand
-  ((not windows)
-   (define-c-const int (access/read "R_OK"))
-   (define-c-const int (access/write "W_OK"))
-   (define-c-const int (access/execute "X_OK"))))
+(define-c-const int (access/read "R_OK"))
+(define-c-const int (access/write "W_OK"))
+(define-c-const int (access/execute "X_OK"))
 (define-c int (file-access "access") (string int))
 
 ;;> Applies the specified locking operation using flock(2) to the port

lib/chibi/filesystem_win32_shim.c

@@ -0,0 +1,104 @@
+/* Win32 shim for (chibi filesystem) */
+
+#include <windows.h>
+#include <stdlib.h>
+#include <errno.h>
+#include <string.h>
+#include <direct.h>
+
+static int mkdir_shim(const char* path, int ignored) {
+    return mkdir(path);
+}
+
+#if !defined(__MINGW32__) && !defined(__MINGW64__)
+/* Flags for _access() API */
+#define R_OK 4
+#define W_OK 2
+#define X_OK 1 /* Follow MinGW */
+
+#define SHIM_WIN32_STAT_IS(m, flg) ((m & _S_IFMT) == flg)
+#define S_ISREG(m) SHIM_WIN32_STAT_IS(m, _S_IFREG)
+#define S_ISDIR(m) SHIM_WIN32_STAT_IS(m, _S_IFDIR)
+#define S_ISCHR(m) SHIM_WIN32_STAT_IS(m, _S_IFCHR)
+#define S_ISFIFO(m) SHIM_WIN32_STAT_IS(m, _S_IFIFO)
+#define S_ISBLK(m) 0
+#endif
+
+#define S_ISLNK(m) 0
+#define S_ISSOCK(m) S_ISFIFO(m)
+
+struct dirent {
+    char d_name[MAX_PATH];
+};
+
+struct DIR_s {
+    int want_next;
+    HANDLE hFind;
+    struct dirent result;
+};
+
+typedef struct DIR_s DIR;
+
+static DIR* opendir(const char* path) {
+    HANDLE hFind;
+    WIN32_FIND_DATAA ffd;
+    DIR* dp;
+    char* query;
+    query = malloc(MAX_PATH + 1);
+    if(!query){
+        errno = ENOMEM;
+        return NULL;
+    }
+    query[0] = 0;
+    strncat(query, path, MAX_PATH);
+    strncat(query, "\\*", MAX_PATH);
+    query[MAX_PATH] = 0;
+    hFind = FindFirstFileA(query, &ffd);
+    if(hFind == INVALID_HANDLE_VALUE){
+        switch(GetLastError()){
+            case ERROR_FILE_NOT_FOUND:
+                errno = ENOENT;
+                break;
+            default:
+                errno = EACCES;
+                break;
+        }
+        return NULL;
+    }
+    free(query);
+    dp = malloc(sizeof(DIR));
+    if(!dp){
+        errno = ENOMEM;
+        return NULL;
+    }
+    dp->hFind = hFind;
+    strncpy(dp->result.d_name, ffd.cFileName, MAX_PATH);
+    dp->want_next = 0;
+    return dp;
+}
+
+static struct dirent *readdir(DIR *dp) {
+    BOOL b;
+    WIN32_FIND_DATAA ffd;
+    if(dp->want_next){
+        /* Query the next file */
+        b = FindNextFile(dp->hFind, &ffd);
+        if(! b){
+            return NULL;
+        }
+        strncpy(dp->result.d_name, ffd.cFileName, MAX_PATH);
+    }
+    dp->want_next = 1;
+    return &dp->result;
+}
+
+static int closedir(DIR *dp) {
+    BOOL b;
+    b = FindClose(dp->hFind);
+    if(! b){
+        errno = EBADF;
+        return -1;
+    }
+    free(dp);
+    return 0;
+}

lib/chibi/io/port.c

@@ -6,6 +6,10 @@
 #include <sys/sendfile.h>
 #endif
 
+#ifdef _WIN32
+#include <io.h>
+#endif
+
 #define SEXP_LAST_CONTEXT_CHECK_LIMIT 256
 
 #define sexp_cookie_ctx(vec) sexp_vector_ref((sexp)vec, SEXP_ZERO)

lib/chibi/win32/process-win32.scm

@@ -0,0 +1,7 @@
+(define (exit . code?)
+  (%exit (if (pair? code?) 
+           (let ((c (car code?)))
+            (cond ((integer? c) c)
+                  ((eq? #t c) 0)
+                  (else 1)))
+           0)))

lib/chibi/win32/process-win32.sld

@@ -0,0 +1,5 @@
+(define-library (chibi win32 process-win32)
+  (import (scheme base))
+  (export %exit)
+  (include-shared "process-win32")
+  (include "process-win32.scm"))

lib/chibi/win32/process-win32.stub

@@ -0,0 +1,5 @@
+;;> An interface to Win32 MSVCRT provided process functions and Win32 APIs
+
+(c-system-include "stdlib.h")
+
+(define-c void (%exit exit) (int))

lib/scheme/process-context.sld

@@ -1,6 +1,8 @@
 
 (define-library (scheme process-context)
-  (import (chibi) (srfi 98) (only (chibi process) exit))
+  (import (chibi) (srfi 98))
+  (cond-expand (windows (import (only (chibi win32 process-win32) exit)))
+               (else (import (only (chibi process) exit))))
   (export get-environment-variable get-environment-variables
           command-line exit emergency-exit)
   ;; TODO: Make exit unwind and finalize properly.

lib/srfi/144/lgamma_r.c

@@ -0,0 +1,84 @@
+/* 
+ * Ruby's missing/lgamma_r.c took from
+ * https://github.com/ruby/ruby/commit/39330d6b79c95f67006453156d8405242da04d7b
+ */
+
+/* lgamma_r.c  - public domain implementation of function lgamma_r(3m)
+
+lgamma_r() is based on gamma().  modified by Tanaka Akira.
+
+reference - Haruhiko Okumura: C-gengo niyoru saishin algorithm jiten
+            (New Algorithm handbook in C language) (Gijyutsu hyouron
+            sha, Tokyo, 1991) [in Japanese]
+            http://oku.edu.mie-u.ac.jp/~okumura/algo/
+*/
+
+/***********************************************************
+    gamma.c -- Gamma function
+***********************************************************/
+#include <math.h>
+#include <errno.h>
+#define PI      3.14159265358979324  /* $\pi$ */
+#define LOG_2PI 1.83787706640934548  /* $\log 2\pi$ */
+#define LOG_PI  1.14472988584940017  /* $\log_e \pi$ */
+#define N       8
+
+#define B0  1                 /* Bernoulli numbers */
+#define B1  (-1.0 / 2.0)
+#define B2  ( 1.0 / 6.0)
+#define B4  (-1.0 / 30.0)
+#define B6  ( 1.0 / 42.0)
+#define B8  (-1.0 / 30.0)
+#define B10 ( 5.0 / 66.0)
+#define B12 (-691.0 / 2730.0)
+#define B14 ( 7.0 / 6.0)
+#define B16 (-3617.0 / 510.0)
+
+static double
+loggamma(double x)  /* the natural logarithm of the Gamma function. */
+{
+    double v, w;
+
+    if (x == 1.0 || x == 2.0) return 0.0;
+
+    v = 1;
+    while (x < N) {  v *= x;  x++;  }
+    w = 1 / (x * x);
+    return ((((((((B16 / (16 * 15))  * w + (B14 / (14 * 13))) * w
+                + (B12 / (12 * 11))) * w + (B10 / (10 *  9))) * w
+                + (B8  / ( 8 *  7))) * w + (B6  / ( 6 *  5))) * w
+                + (B4  / ( 4 *  3))) * w + (B2  / ( 2 *  1))) / x
+                + 0.5 * LOG_2PI - log(v) - x + (x - 0.5) * log(x);
+}
+
+
+#ifdef __MINGW_ATTRIB_PURE
+/* get rid of bugs in math.h of mingw */
+#define modf(_X, _Y) __extension__ ({\
+    double intpart_modf_bug = intpart_modf_bug;\
+    double result_modf_bug = modf((_X), &intpart_modf_bug);\
+    *(_Y) = intpart_modf_bug;\
+    result_modf_bug;\
+})
+#endif
+
+/* the natural logarithm of the absolute value of the Gamma function */
+double
+lgamma_r(double x, int *signp)
+{
+    if (x <= 0) {
+        double i, f, s;
+        f = modf(-x, &i);
+        if (f == 0.0) { /* pole error */
+            *signp = signbit(x) ? -1 : 1;
+            errno = ERANGE;
+            return HUGE_VAL;
+        }
+        *signp = (fmod(i, 2.0) != 0.0) ? 1 : -1;
+        s = sin(PI * f);
+        if (s < 0) s = -s;
+        return LOG_PI - log(s) - loggamma(1 - x);
+    }
+    *signp = 1;
+    return loggamma(x);
+}

lib/srfi/144/math.stub

@@ -148,11 +148,8 @@
 (define-c double (flgamma "tgamma") (double))
 (cond-expand
   (windows
-   ;; FIXME: Implement this.
-   (c-declare "double lgamma_r(double x, int* sign) { *sign = 9999; __debugbreak(); }")
-    (define-c double lgamma_r (double (result int))))
-   (else
-    (define-c double lgamma_r (double (result int)))))
+   (c-include-verbatim "lgamma_r.c")))
+(define-c double lgamma_r (double (result int)))
 
 (define-c double (flfirst-bessel "jn") (int double))
 (define-c double (flsecond-bessel "yn") (int double))

lib/srfi/151/bit.c

@@ -398,13 +398,13 @@ sexp sexp_bit_set_p (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp x) {
     return sexp_xtype_exception(ctx, self, "index must be non-negative", i);
   if (sexp_fixnump(x)) {
     return sexp_make_boolean((pos < sizeof(sexp_uint_t)*CHAR_BIT)
-                             && (sexp_unbox_fixnum(x) & (1UL<<pos)));
+                             && (sexp_unbox_fixnum(x) & ((sexp_uint_t)1<<pos)));
 #if SEXP_USE_BIGNUMS
   } else if (sexp_bignump(x)) {
     pos /= (sizeof(sexp_uint_t)*CHAR_BIT);
     rem = (sexp_unbox_fixnum(i) - pos*sizeof(sexp_uint_t)*CHAR_BIT);
     return sexp_make_boolean((pos < (sexp_sint_t)sexp_bignum_length(x))
-                             && (sexp_bignum_data(x)[pos] & (1UL<<rem)));
+                             && (sexp_bignum_data(x)[pos] & ((sexp_uint_t)1<<rem)));
 #endif
   } else {
     return sexp_type_exception(ctx, self, SEXP_FIXNUM, x);

lib/srfi/98/env.c

@@ -5,11 +5,9 @@
 #ifdef __APPLE__
 #include <crt_externs.h>
 #define environ (*_NSGetEnviron())
-#else
-#ifndef PLAN9
+#elif !defined(_WIN32) && !defined(PLAN9)
 extern char **environ;
 #endif
-#endif
 
 #include <chibi/eval.h>
 

sexp.c

@@ -15,6 +15,10 @@ struct sexp_huff_entry {
 #include "chibi/sexp-huff.h"
 #endif
 
+#ifdef _WIN32
+#include <io.h>
+#endif
+
 static int sexp_initialized_p = 0;
 
 static const char sexp_separators[] = {