From 1c10a636cb416dfaecd8acd76115323eb64ed658 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 13 Mar 2006 20:19:05 +0000 Subject: [PATCH] fix 'lib' path collapsing to always use Unix style svn: r2422 --- collects/syntax/doc.txt | 7 +- collects/syntax/moddep.ss | 235 +++++++++++++++++------------- collects/tests/mzscheme/moddep.ss | 15 +- 3 files changed, 142 insertions(+), 115 deletions(-) diff --git a/collects/syntax/doc.txt b/collects/syntax/doc.txt index 59d8ffd281..2d9c9524e9 100644 --- a/collects/syntax/doc.txt +++ b/collects/syntax/doc.txt @@ -290,7 +290,7 @@ currently exist). > (with-module-reading-parameterization thunk) - calls `thunk' with all reader parameters reset to their default values. -> (check-module-form stx expected-module-sym filename-string-or-#f) - +> (check-module-form stx expected-module-sym source-or-#f) - inspects `stx' to check whether evaluating it will declare a module named `expected-module-sym' (plus a prefix, if `current-module-name-prefix' is set) --- at least if `module' is @@ -301,8 +301,9 @@ currently exist). `check-module-form' procedure returns a syntax object that certainly will declare a module (adding explicit context to the leading `module' if necessary) in any top-level. Otherwise, if - `filename-string-or-#f' is a string, a suitable exception is raised, - and if `filename-string-or-#f' is #f, #f is returned. + `source-string-or-#f' is not #f, a suitable exception is raised + using the `write' form of the source in the message; if + `source-or-#f' is #f, #f is returned. If stx is eof or eof wrapped as a syntax object, then an error is raised or #f is returned. diff --git a/collects/syntax/moddep.ss b/collects/syntax/moddep.ss index e2002f9e52..0aa1953805 100644 --- a/collects/syntax/moddep.ss +++ b/collects/syntax/moddep.ss @@ -2,6 +2,7 @@ (module moddep mzscheme (require (lib "etc.ss") (lib "port.ss") + (lib "list.ss") (lib "contract.ss") (lib "resolver.ss" "planet")) @@ -297,112 +298,136 @@ ;; relto-mp should be a relative path, '(lib relative-path collection), or '(file path) ;; or a thunk that produces one of those (lambda (s relto-mp) - (let ([combine-relative-elements - (lambda (elements) - (define (attach-to-relative-path relto) - (apply build-path - (let-values ([(base n d?) (split-path relto)]) - (if (eq? base 'relative) - 'same - base)) - (map (lambda (i) - (cond - [(bytes? i) (bytes->path i)] - [else i])) - elements))) - - (when (procedure? relto-mp) - (set! relto-mp (relto-mp))) - (cond - [(path-string? relto-mp) - ((if (path? relto-mp) - bytes->path - bytes->string/locale) - (apply - bytes-append - (let ([m (regexp-match re:path-only (if (path? relto-mp) - (path->bytes relto-mp) - (string->bytes/locale relto-mp)))]) - (if m - (cadr m) - #".")) - (map (lambda (e) - (cond - [(eq? e 'same) #"/."] - [(eq? e 'up) #"/.."] - [else (bytes-append #"/" (if (path? e) - (path->bytes e) - e))])) - elements)))] - [(eq? (car relto-mp) 'file) - (let ([path ((if (ormap path? elements) - values - path->string) - (attach-to-relative-path (cadr relto-mp)))]) - (if (path? path) - path - `(file ,path)))] - [(eq? (car relto-mp) 'lib) - (let ([path (path->string - (attach-to-relative-path (cadr relto-mp)))]) - `(lib ,path ,(caddr relto-mp)))] - [(eq? (car relto-mp) 'planet) - (let ([pathstr (path->string (attach-to-relative-path (cadr relto-mp)))]) - `(planet ,pathstr ,(caddr relto-mp)))] - [else (error 'combine-relative-elements "don't know how to deal with: ~s" relto-mp)]))]) + ;; Used for 'lib paths, so it's always Unix-style + (define (attach-to-relative-path-string elements relto) + (let ([elem-str (substring + (apply string-append + (map (lambda (i) + (string-append + "/" + (cond + [(bytes? i) (bytes->string/locale i)] + [(path? i) (path->string i)] + [(eq? i 'up) ".."] + [else i]))) + (filter (lambda (x) + (not (eq? x 'same))) + elements))) + 1)]) + (if (or (regexp-match #rx"^[.]/+[^/]*" relto) + (not (regexp-match #rx"/" relto))) + elem-str + (let ([m (regexp-match #rx"^(.*/)/*[^/]*$" relto)]) + (string-append (cadr m) elem-str))))) + + (define (combine-relative-elements elements) + + ;; Used for 'file paths, so it's platform specific: + (define (attach-to-relative-path relto) + (apply build-path + (let-values ([(base n d?) (split-path relto)]) + (if (eq? base 'relative) + 'same + base)) + (map (lambda (i) + (cond + [(bytes? i) (bytes->path i)] + [else i])) + elements))) + + (when (procedure? relto-mp) + (set! relto-mp (relto-mp))) (cond - [(string? s) - ;; Parse Unix-style relative path string - (let loop ([elements null][s (string->bytes/utf-8 s)]) - (let ([prefix (regexp-match re:dir s)]) - (if prefix - (loop (cons (let ([p (cadr prefix)]) - (cond - [(bytes=? p #".") 'same] - [(bytes=? p #"..") 'up] - [else (bytes->path p)])) - elements) - (caddr prefix)) - (combine-relative-elements - (reverse (cons s elements))))))] - [(and (or (not (pair? s)) - (not (list? s))) - (not (path? s))) - #f] - [(or (path? s) - (eq? (car s) 'file)) - (let ([p (if (path? s) - s - (cadr s))]) - (if (absolute-path? p) - s - (let loop ([p p][elements null]) - (let-values ([(base name dir?) (split-path p)]) - (cond - [(eq? base 'relative) - (combine-relative-elements - (cons name elements))] - [else (loop base (cons name elements))])))))] - [(eq? (car s) 'lib) - (let ([cols (let ([len (length s)]) - (if (= len 2) - (list "mzlib") - (cddr s)))]) - `(lib ,(path->string - (build-path (if (null? (cdr cols)) - 'same - (apply build-path 'same (cdr cols))) - (cadr s))) - ,(car cols)))] - [(eq? (car s) 'planet) - (let ((cols (cdddr s))) - `(planet - ,(path->string (build-path (if (null? cols) - 'same - (apply build-path 'same cols)) - (cadr s))) - ,(caddr s)))] - [else #f])))) + [(path-string? relto-mp) + ((if (path? relto-mp) + bytes->path + bytes->string/locale) + (apply + bytes-append + (let ([m (regexp-match re:path-only (if (path? relto-mp) + (path->bytes relto-mp) + (string->bytes/locale relto-mp)))]) + (if m + (cadr m) + #".")) + (map (lambda (e) + (cond + [(eq? e 'same) #"/."] + [(eq? e 'up) #"/.."] + [else (bytes-append #"/" (if (path? e) + (path->bytes e) + e))])) + elements)))] + [(eq? (car relto-mp) 'file) + (let ([path ((if (ormap path? elements) + values + path->string) + (attach-to-relative-path (cadr relto-mp)))]) + (if (path? path) + path + `(file ,path)))] + [(eq? (car relto-mp) 'lib) + (let ([path (attach-to-relative-path-string elements + (cadr relto-mp))]) + `(lib ,path ,(caddr relto-mp)))] + [(eq? (car relto-mp) 'planet) + (let ([pathstr (attach-to-relative-path-string elements + (cadr relto-mp))]) + `(planet ,pathstr ,(caddr relto-mp)))] + [else (error 'combine-relative-elements "don't know how to deal with: ~s" relto-mp)])) + + (cond + [(string? s) + ;; Parse Unix-style relative path string + (let loop ([elements null][s (string->bytes/utf-8 s)]) + (let ([prefix (regexp-match re:dir s)]) + (if prefix + (loop (cons (let ([p (cadr prefix)]) + (cond + [(bytes=? p #".") 'same] + [(bytes=? p #"..") 'up] + [else (bytes->path p)])) + elements) + (caddr prefix)) + (combine-relative-elements + (reverse (cons s elements))))))] + [(and (or (not (pair? s)) + (not (list? s))) + (not (path? s))) + #f] + [(or (path? s) + (eq? (car s) 'file)) + (let ([p (if (path? s) + s + (cadr s))]) + (if (absolute-path? p) + s + (let loop ([p p][elements null]) + (let-values ([(base name dir?) (split-path p)]) + (cond + [(eq? base 'relative) + (combine-relative-elements + (cons name elements))] + [else (loop base (cons name elements))])))))] + [(eq? (car s) 'lib) + (let ([cols (let ([len (length s)]) + (if (= len 2) + (list "mzlib") + (cddr s)))]) + `(lib ,(attach-to-relative-path-string + (append (cdr cols) + (list (cadr s))) + ".") + ,(car cols)))] + [(eq? (car s) 'planet) + (let ((cols (cdddr s))) + `(planet + ,(attach-to-relative-path-string + (append (cdr cols) + (list (cadr s))) + ".") + ,(caddr s)))] + [else #f]))) (define (collapse-module-path-index mpi relto-mp) (let-values ([(path base) (module-path-index-split mpi)]) diff --git a/collects/tests/mzscheme/moddep.ss b/collects/tests/mzscheme/moddep.ss index 7c1496b407..d48e42fc52 100644 --- a/collects/tests/mzscheme/moddep.ss +++ b/collects/tests/mzscheme/moddep.ss @@ -78,12 +78,13 @@ (module-path-index-join #f #f))) rel-to)) -(test-cmp '(lib "./x.ss" "nonesuch") "x.ss" '(lib "y.ss" "nonesuch")) -(test-cmp '(lib "./x.ss" "nonesuch") "x.ss" (lambda () '(lib "y.ss" "nonesuch"))) -(test-cmp '(lib "./down/x.ss" "nonesuch") "down/x.ss" '(lib "y.ss" "nonesuch")) -(test-cmp '(lib "./x.ss" "mzlib") '(lib "x.ss") '(lib "y.ss" "nonesuch")) -(test-cmp '(lib "./../x.ss" "nonesuch/private") "../x.ss" '(lib "y.ss" "nonesuch/private")) -(test-cmp '(lib "./private/x.ss" "alsonot") '(lib "x.ss" "alsonot" "private") '(lib "y.ss" "nonesuch")) +(test-cmp '(lib "x.ss" "nonesuch") "x.ss" '(lib "y.ss" "nonesuch")) +(test-cmp '(lib "x.ss" "nonesuch") "x.ss" (lambda () '(lib "y.ss" "nonesuch"))) +(test-cmp '(lib "down/x.ss" "nonesuch") "down/x.ss" '(lib "y.ss" "nonesuch")) +(test-cmp '(lib "x.ss" "mzlib") '(lib "x.ss") '(lib "y.ss" "nonesuch")) +(test-cmp '(lib "../x.ss" "nonesuch/private") "../x.ss" '(lib "y.ss" "nonesuch/private")) +(test-cmp '(lib "private/../x.ss" "nonesuch") "../x.ss" '(lib "private/y.ss" "nonesuch")) +(test-cmp '(lib "private/x.ss" "alsonot") '(lib "x.ss" "alsonot" "private") '(lib "y.ss" "nonesuch")) (test-cmp (build-path (current-directory) "x.ss") "x.ss" (build-path (current-directory) "other")) (test-cmp `(file ,(path->string (build-path (current-directory) "x.ss"))) @@ -102,7 +103,7 @@ (bytes->path #"\xFF") `(file ,(path->string (build-path (current-directory) "other")))) -(test '(lib "./x.ss" "alsonot") +(test '(lib "x.ss" "alsonot") collapse-module-path-index (module-path-index-join "x.ss" (module-path-index-join