bug#10474: Building guile 2.x under mingw + msys

[Andy Wingo <wingo@pobox.com>]

[-- Attachment #1: Type: text/plain, Size: 582 bytes --]

On Thu 02 Feb 2012 18:34, Eli Zaretskii <eliz@gnu.org> writes:

>  . module/ice-9/boot-9.scm -- absolute-path? does not support Windows
>                               file names with drive letters.  Windows
>                               absolute file names match the regex
>                               "\([a-zA-Z]:\)?[\\/]".  I don't know
>                               Scheme well enough to write this in a
>                               clean way, sorry...

Ludo, what do you think about the attached patch?  Eli, is it correct
and sufficient to fix path handling?

Andy


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-better-handling-of-windows-path-conventions.patch --]
[-- Type: text/x-diff, Size: 8000 bytes --]

From 965bda2befddb84101cfebb8a4a36f93ac3c248c Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Tue, 19 Feb 2013 11:41:44 +0100
Subject: [PATCH] better handling of windows path conventions

* libguile/filesys.c (scm_system_path_convention): New function.
  Exported to Scheme only.

* module/ice-9/boot-9.scm (path-separator?, absolute-path?): New
  predicates.
  (path-separator-string): New global variable.
  (in-vicinity): Use the new procedures.
  (load-user-init, try-module-autoload): Use path-separator-string.
  (load-in-vicinity): Update canonical->suffix.  A Racket-style
  `reroot-path' would be nice.

* module/ice-9/psyntax.scm (include): Use global `absolute-path?'.
---
 libguile/filesys.c       |   20 ++++++++++-
 module/ice-9/boot-9.scm  |   90 +++++++++++++++++++++++++++++++++++++++-------
 module/ice-9/psyntax.scm |    3 --
 3 files changed, 96 insertions(+), 17 deletions(-)

diff --git a/libguile/filesys.c b/libguile/filesys.c
index 9c39307..d48a655 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1,5 +1,5 @@
 /* Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2004, 2006,
- *   2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+ *   2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -1434,6 +1434,24 @@ SCM_DEFINE (scm_mkstemp, "mkstemp!", 1, 0, 0,
 
 SCM scm_dot_string;
 
+#ifdef __MINGW32__
+SCM_SYMBOL (sym_path_convention, "windows");
+#else
+SCM_SYMBOL (sym_path_convention, "posix");
+#endif
+
+SCM_INTERNAL SCM scm_system_path_convention (void);
+
+SCM_DEFINE (scm_system_path_convention, "system-path-convention", 0, 0, 0,
+            (void),
+	    "Return either @code{posix} or @code{windows}, depending on\n"
+            "what kind of system this Guile is running on.")
+#define FUNC_NAME s_scm_system_path_convention
+{
+  return sym_path_convention;
+}
+#undef FUNC_NAME
+
 SCM_DEFINE (scm_dirname, "dirname", 1, 0, 0, 
             (SCM filename),
 	    "Return the directory name component of the file name\n"
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 31d4523..18178b5 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -296,6 +296,12 @@ If there is no handler at all, Guile prints an error and then exits."
              (apply f (car l1) (map car rest))
              (lp (cdr l1) (map cdr rest))))))))
 
+;; Temporary definition used in the include-from-path expansion;
+;; replaced later.
+
+(define (absolute-path? path)
+  #t)
+
 ;;; {and-map and or-map}
 ;;;
 ;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...)
@@ -1411,16 +1417,70 @@ VALUE."
 ;;; {Load Paths}
 ;;;
 
+(let-syntax ((compile-time-case
+              (lambda (stx)
+                (syntax-case stx ()
+                  ((_ exp clauses ...)
+                   (let ((val (primitive-eval (syntax->datum #'exp))))
+                     (let next-clause ((clauses #'(clauses ...)))
+                       (syntax-case clauses (else)
+                         (()
+                          (syntax-violation 'compile-time-case
+                                            "all clauses failed to match" stx))
+                         (((else form ...))
+                          #'(begin form ...))
+                         ((((k ...) form ...) clauses ...)
+                          (if (memv val (syntax->datum #'(k ...)))
+                              #'(begin form ...)
+                              (next-clause #'(clauses ...))))))))))))
+  ;; emacs: (put 'compile-time-case 'scheme-indent-function 1)
+  (compile-time-case (system-path-convention)
+    ((posix)
+     (define (path-separator? c)
+       (char=? c #\/))
+
+     (define path-separator-string "/")
+
+     (define (absolute-path? path)
+       (string-prefix? "/" path)))
+
+    ((windows)
+     (define (path-separator? c)
+       (or (char=? c #\/)
+           (char=? c #\\)))
+
+     (define path-separator-string "\\")
+
+     (define (absolute-path? path)
+       (define (unc-path?)
+         ;; Universal Naming Convention (UNC) paths start with \\, and
+         ;; are always absolute.
+         (string-prefix? "\\\\" path))
+       (define (has-drive-specifier?)
+         (and (>= (string-length path) 2)
+              (let ((drive (string-ref path 0)))
+                (or (char<=? #\a drive #\z)
+                    (char<=? #\A drive #\Z)))
+              (eqv? (string-ref path 1) #\:)))
+       (define (path-separator-at-index? idx)
+         (and (> (string-length path) idx)
+              (case (string-ref path idx)
+                ((#\\ #\/) #t)
+                (else #f))))
+       (or (unc-path?)
+           (if (has-drive-specifier?)
+               (path-separator-at-index? 2)
+               (path-separator-at-index? 0)))))))
+
 (define (in-vicinity vicinity file)
   (let ((tail (let ((len (string-length vicinity)))
                 (if (zero? len)
                     #f
                     (string-ref vicinity (- len 1))))))
     (string-append vicinity
-                   (if (or (not tail)
-                           (eq? tail #\/))
+                   (if (or (not tail) (path-separator? tail))
                        ""
-                       "/")
+                       path-separator-string)
                    file)))
 
 \f
@@ -1440,7 +1500,7 @@ VALUE."
 (define (load-user-init)
   (let* ((home (or (getenv "HOME")
                    (false-if-exception (passwd:dir (getpwuid (getuid))))
-                   "/"))  ;; fallback for cygwin etc.
+                   path-separator-string))  ;; fallback for cygwin etc.
          (init-file (in-vicinity home ".guile")))
     (if (file-exists? init-file)
         (primitive-load init-file))))
@@ -2777,7 +2837,8 @@ but it fails to load."
          (dir-hint-module-name (reverse (cdr reverse-name)))
          (dir-hint (apply string-append
                           (map (lambda (elt)
-                                 (string-append (symbol->string elt) "/"))
+                                 (string-append (symbol->string elt)
+                                                path-separator-string))
                                dir-hint-module-name))))
     (resolve-module dir-hint-module-name #f)
     (and (not (autoload-done-or-in-progress? dir-hint name))
@@ -3635,11 +3696,17 @@ reading PATH with READER."
 
   (define (canonical->suffix canon)
     (cond
-     ((string-prefix? "/" canon) canon)
-     ((and (> (string-length canon) 2)
-           (eqv? (string-ref canon 1) #\:))
-      ;; Paths like C:... transform to /C...
-      (string-append "/" (substring canon 0 1) (substring canon 2)))
+     ((and (not (string-null? canon))
+           (path-separator? (string-ref canon 0)))
+      canon)
+     ((and (eq? (system-path-convention) 'windows)
+           (absolute-path? canon))
+      ;; An absolute path that doesn't start with a path separator starts with a
+      ;; drive component.  Transform the drive component to a path element:
+      ;; c:\foo -> \c\foo.
+      (string-append path-separator-string
+                     (substring canon 0 1)
+                     (substring canon 2)))
      (else canon)))
 
   (define compiled-extension
@@ -3723,9 +3790,6 @@ reading PATH with READER."
         (warn-about-exception k args)
         #f)))
 
-  (define (absolute-path? path)
-    (string-prefix? "/" path))
-
   (define (sans-extension file)
     (let ((dot (string-rindex file #\.)))
       (if dot
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 565c911..2e71aab 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -2929,9 +2929,6 @@
 
 (define-syntax include
   (lambda (x)
-    (define (absolute-path? path)
-      (string-prefix? "/" path))
-
     (define read-file
       (lambda (fn dir k)
         (let ((p (open-input-file
-- 
1.7.10.4


[-- Attachment #3: Type: text/plain, Size: 26 bytes --]


-- 
http://wingolog.org/