[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
bug#10474: Building guile 2.x under mingw + msys
|
From: |
Andy Wingo |
|
Subject: |
bug#10474: Building guile 2.x under mingw + msys |
|
Date: |
Tue, 19 Feb 2013 11:44:35 +0100 |
|
User-agent: |
Gnus/5.13 (Gnus v5.13) Emacs/24.2 (gnu/linux) |
On Thu 02 Feb 2012 18:34, Eli Zaretskii <address@hidden> 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
>From 965bda2befddb84101cfebb8a4a36f93ac3c248c Mon Sep 17 00:00:00 2001
From: Andy Wingo <address@hidden>
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)))
@@ -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
--
http://wingolog.org/