From 965bda2befddb84101cfebb8a4a36f93ac3c248c Mon Sep 17 00:00:00 2001 From: Andy Wingo 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