add `relative-in'

collects/racket/private/reqprov.rkt

@@ -2,7 +2,7 @@
   (#%require "define.rkt"
              (for-syntax '#%kernel
                          "stx.rkt" "stxcase-scheme.rkt" "small-scheme.rkt" 
-                         "stxloc.rkt" "qqstx.rkt"
+                         "stxloc.rkt" "qqstx.rkt" "more-scheme.rkt"
                          "../require-transform.rkt"
                          "../provide-transform.rkt"
                          "struct-info.rkt"))
@@ -11,6 +11,7 @@
              for-syntax for-template for-label for-meta
              require
              only-in rename-in prefix-in except-in combine-in only-meta-in
+             relative-in
              provide
              all-defined-out all-from-out
              rename-out except-out prefix-out struct-out combine-out
@@ -30,6 +31,11 @@
   ;; lib, file, planet, submod
   
   (define-for-syntax (xlate-path stx)
+    ;; Converts a path based on `require' submform bindings into
+    ;; one based on `#%require' symbolic combinations. For example,
+    ;; is `quote' is imported as `alt:quote', changes the `alt:quote'
+    ;; to plain `quote'.
+    (convert-relative-module-path
      (if (pair? (syntax-e stx))
          (let ([kw
                 ;; symbolic-identifier=? identifiers are not necessarily free-identifier=?
@@ -59,7 +65,7 @@
                    (cons kw (cdr d))
                    stx
                    stx)]))
-        stx))
+         stx)))
   
   (define-for-syntax (check-lib-form stx)
     (unless (module-path? (syntax->datum (xlate-path stx)))
@@ -238,6 +244,7 @@
       (raise-syntax-error #f
                           "not at module level or top level"
                           stx))
+    (parameterize ([current-require-module-path #f])
       (letrec ([mode-wrap
                 (lambda (mode base)
                   (cond
@@ -358,7 +365,7 @@
              (syntax/loc stx
                (#%require new-in ...)))]
           [(_ in ...)
-         (syntax/loc stx (begin (require in) ...))])))
+           (syntax/loc stx (begin (require in) ...))]))))
 
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;; require transformers
@@ -615,6 +622,22 @@
                   imports)
              sources))]))))
 
+  (define-syntax relative-in
+    (make-require-transformer
+     (lambda (stx)
+       (syntax-case stx ()
+         [(_ mod-path in ...)
+          (let ([mp (syntax->datum #'mod-path)])
+            (unless (module-path? mp)
+              (raise-syntax-error #f
+                                  "bad module path"
+                                  stx
+                                  #'mod-path))
+            (parameterize ([current-require-module-path (module-path-index-join
+                                                         mp
+                                                         (current-require-module-path))])
+              (expand-import #`(combine-in in ...))))]))))
+
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;; provide
   

collects/racket/require-transform.rkt

@@ -8,6 +8,7 @@
              (for-syntax '#%kernel))
   
   (#%provide expand-import 
+             current-require-module-path convert-relative-module-path
              syntax-local-require-certifier
              make-require-transformer prop:require-transformer require-transformer?
              ;; the import struct type:
@@ -72,6 +73,193 @@
   (define orig-insp (variable-reference->module-declaration-inspector
                      (#%variable-reference)))
 
+  (define current-require-module-path 
+    (make-parameter #f
+                    (lambda (v)
+                      (unless (or (not v)
+                                  (module-path-index? v))
+                        (raise-type-error 'current-require-module-path 
+                                          "#f or module path index"
+                                          v))
+                      v)))
+
+  ;; a simplified version of `collapse-module-path-index', where
+  ;; we don't have to normalize:
+  (define (collapse-mpi mpi)
+    (define-values (a b) (module-path-index-split mpi))
+    (define (recur b)
+      (cond
+       [(not b) (collapse-mpi (module-path-index-join #f #f))]
+       [(resolved-module-path? b)
+        (let ([n (resolved-module-path-name b)])
+          (if (pair? n)
+              (cons 'submod n)
+              n))]
+       [else (collapse-mpi b)]))
+    (define (extract-root bc)
+      (if (and (pair? bc) (eq? 'submod (car bc)))
+          (cadr bc)
+          bc))
+    (define (replace-last s a)
+      ;; replace last path element, and also eliminate "." and "..":
+      (regexp-replace* #rx"(?<=^|/)[.]/"
+                       (regexp-replace* #rx"(?<=^|/)[-+_%a-zA-Z0-9]*/[.][.]/"
+                                        (regexp-replace #rx"[^/]*$" s a)
+                                        "")
+                       ""))
+    (define (string->path* s)
+      ;; for now, module-path strings all works as paths
+      (string->path s))
+    (cond
+     [(and (not a) (not b))
+      (build-path (or (current-load-relative-directory)
+                      (current-directory))
+                  "here.rkt")]
+     [(path? a) a]
+     [(symbol? a) a]
+     [(string? a)
+      (define bc (extract-root (recur b)))
+      (let loop ([bc bc])
+        (cond
+         [(path? bc)
+          (define-values (base name dir?) (split-path bc))
+          (if (eq? base 'relative)
+              (string->path* a)
+              (build-path base (string->path* a)))]
+         [(symbol? bc)
+          (loop `(lib ,(symbol->string bc)))]
+         [(eq? (car bc) 'quote) 
+          (build-path (or (current-load-relative-directory)
+                          (current-directory))
+                      (string->path* a))]
+         [(eq? (car bc) 'file)
+          (loop (string->path (cadr bc)))]
+         [(eq? (car bc) 'lib)
+          (cond
+           [(and (null? (cddr bc))
+                 (regexp-match? #rx"[/]" (cadr bc)))
+            `(lib ,(replace-last (cadr bc) a))]
+           [(and (null? (cddr bc))
+                 (not (regexp-match? #rx"[/.]" (cadr bc))))
+            (loop `(lib ,(string-append (cadr bc) "/main.rkt")))]
+           [(and (null? (cddr bc))
+                 (not (regexp-match? #rx"[/]" (cadr bc))))
+            (loop `(lib ,(string-append "mzlib/" (cadr bc))))]
+           [else
+            (loop `(lib ,(apply
+                          string-append 
+                          (let loop ([l (cddr bc)])
+                            (if (null? l)
+                                (list (cadr bc))
+                                (list* (car l) "/" (loop (cdr l))))))))])]
+         [(eq? (car bc) 'planet)
+          (cond
+           [(symbol? (cadr bc))
+            (loop `(planet ,(symbol->string (cadr bc))))]
+           [(null? (cddr bc))
+            (define s (cadr bc))
+            (cond
+             [(regexp-match? #rx"/.*/" s)
+              `(planet ,(replace-last s a))]
+             [else
+              `(planet ,(string-append s "/" a))])]
+           [else
+            (define s (cadr bc))
+            `(planet ,(if (regexp-match? #rx"/" s)
+                          (replace-last s a)
+                          a)
+                     ,@(cddr bc))])]
+         [else (error "collapse-mpi failed on recur shape: " bc)]))]
+     [(eq? (car a) 'submod)
+      (define (add bc l)
+        (if (and (pair? bc) (eq? 'submod (car bc)))
+            (append bc l)
+            (list* 'submod bc l)))
+      (cond
+       [(equal? (cadr a) ".")
+        (add (recur b) (cddr a))]
+       [(equal? (cadr a) "..")
+        (add (recur b) (cdr a))]
+       [else
+        (add (collapse-mpi (module-path-index-join (cadr a) b))
+             (cddr a))])]
+     [else a]))
+  
+  (define (convert-relative-module-path mp/stx)
+    (define rmp (current-require-module-path))
+    (cond
+     [(not rmp) mp/stx]
+     [else
+      (define mp (if (syntax? mp/stx)
+                     (syntax->datum mp/stx)
+                     mp/stx))
+      (define (d->s d)
+        (if (syntax? mp/stx)
+            (datum->syntax mp/stx d mp/stx mp/stx)
+            d))
+      (cond
+       [(not (module-path? mp)) mp/stx]
+       [(string? mp)
+        ;; collapse a relative reference to an absolute one:
+        (d->s (collapse-mpi (module-path-index-join mp rmp)))]
+       [(symbol? mp) mp/stx]
+       [(eq? (car mp) 'quote)
+        ;; maybe a submodule...
+        (define r (module-path-index-resolve rmp))
+        (if (module-declared? (append '(submod)
+                                      (if (list? r)
+                                          r
+                                          (list r))
+                                      (cddr mp))
+                              #t)
+            ;; Yes, a submodule:
+            (let ([rmp-mod (collapse-mpi rmp)])
+              (if (and (pair? rmp-mod)
+                       (eq? (car rmp-mod 'submod)))
+                  (d->s (append rmp-mod (cadr mp)))
+                  (d->s `(submod ,rmp-mod . ,(cddr mp)))))
+            mp/stx)]
+       [(eq? (car mp) 'file)
+        (define base-path (resolved-module-path-name
+                           (module-path-index-resolve rmp)))
+        (define path (if (pair? base-path)
+                         (car base-path)
+                         base-path))
+        (if (path? path) 
+            (let-values ([(base name dir?) (split-path path)])
+              (if (eq? base 'relative)
+                  mp/stx
+                  (d->s (build-path base (cadr mp)))))
+            mp/stx)]
+       [(eq? (car mp) 'submod)
+        (define sub/stx (if (syntax? mp/stx)
+                            (syntax-case mp/stx ()
+                              [(_ sub . _) #'sub])
+                            (cadr mp)))
+        (define sub (if (syntax? sub/stx) (syntax->datum sub/stx) sub/stx))
+        (define new-sub/stx
+          (cond
+           [(equal? sub ".") (d->s (collapse-mpi rmp))]
+           [(equal? sub "..")
+            (define old (collapse-mpi rmp))
+            (if (and (pair? old)
+                     (eq? (car old) 'submod))
+                (d->s (append old ".."))
+                sub/stx)]
+           [else
+            (convert-relative-module-path sub/stx)]))
+        (cond
+         [(eq? sub/stx new-sub/stx) mp/stx]
+         [else
+          (define new-sub (if (syntax? new-sub/stx)
+                              (syntax->datum new-sub/stx)
+                              new-sub/stx))
+          (if (and (pair? new-sub)
+                   (eq? (car new-sub 'submod)))
+              (d->s (append new-sub (cddr sub)))
+              (d->s `(submod ,new-sub/stx . ,(cddr sub))))])]
+       [else mp/stx])]))
+
   ;; expand-import : stx bool -> (listof import)
   (define (expand-import stx)
     (let ([disarmed-stx (syntax-disarm stx orig-insp)])
@@ -91,7 +279,8 @@
               #f
               "invalid module-path form"
               stx))
-           (let ([namess (syntax-local-module-exports mod-path)])
+           (let* ([mod-path (convert-relative-module-path mod-path)]
+                  [namess (syntax-local-module-exports mod-path)])
              (values
               (apply
                append

collects/scribblings/reference/stx-trans.scrbl

@@ -602,13 +602,16 @@ by the expander, the result is the @tech{phase level} of the form
 being expanded. Otherwise, the result is @racket[0].}
 
 
-@defproc[(syntax-local-module-exports [mod-path module-path?]) 
+@defproc[(syntax-local-module-exports [mod-path (or/c module-path?
+                                                      (and/c syntax?
+                                                             (lambda (stx)
+                                                               (module-path? (syntax->datum stx)))))])
          (listof (cons/c (or/c exact-integer? #f) (listof symbol?)))]{
 
 Returns an association list from @tech{phase-level} numbers (or
 @racket[#f] for the @tech{label phase level}) to lists of symbols,
 where the symbols are the names of @racket[provide]d
-bindings at the corresponding @tech{phase level}.
+bindings from @racket[mod-path] at the corresponding @tech{phase level}.
 
 @transform-time[]}
 
@@ -929,6 +932,44 @@ into a module.
 ]}
 
 
+@defparam[current-require-module-path module-path (or/c #f module-path-index?)]{
+
+A parameter that determines how relative @racket[require]-level module
+paths are expanded to @racket[#%require]-level module paths by
+@racket[convert-relative-module-path] (which is used implicitly by all
+built-in @racket[require] sub-forms).
+
+When the value of @racket[current-require-module-path] is @racket[#f],
+relative module paths are left as-is, which means that the
+@racket[require] context determines the resolution of the module
+path.
+
+The @racket[require] form @racket[parameterize]s
+@racket[current-require-module-path] as @racket[#f] while invoking
+sub-form transformers, while @racket[relative-in] @racket[parameterize]s
+to a given module path.}
+
+
+@defproc[(convert-relative-module-path [module-path
+                                        (or/c module-path?
+                                              (and/c syntax?
+                                                     (lambda (stx)
+                                                       (module-path? (syntax-e stx)))))])
+          (or/c module-path?
+                (and/c syntax?
+                       (lambda (stx)
+                         (module-path? (syntax-e stx)))))]{
+
+Converts @racket[module-path] according to @racket[current-require-module-path].
+
+If @racket[module-path] is not relative or if the value of
+@racket[current-require-module-path] is @racket[#f], then
+@racket[module-path] is returned. Otherwise, @racket[module-path] is
+converted to an absolute module path that is equivalent to
+@racket[module-path] relative to the value of
+@racket[current-require-module-path].}
+
+
 @defproc[(syntax-local-require-certifier)
          ((syntax?) (or/c #f (syntax? . -> . syntax?)) 
           . ->* . syntax?)]{

collects/scribblings/reference/syntax.scrbl

@@ -1,7 +1,8 @@
 #lang scribble/doc
 @(require "mz.rkt" scribble/bnf scribble/core
           (for-label (only-in racket/require-transform
-                              make-require-transformer)
+                              make-require-transformer
+                              current-require-module-path)
                      racket/require-syntax
                      racket/require
                      (only-in racket/provide-transform
@@ -348,7 +349,8 @@ Legal only in a @tech{module begin context}, and handled by the
 @guideintro["module-require"]{@racket[require]}
 
 @defform/subs[#:literals (only-in prefix-in except-in rename-in lib file planet submod + - =
-                          for-syntax for-template for-label for-meta only-meta-in combine-in quote)
+                          for-syntax for-template for-label for-meta only-meta-in combine-in 
+                          relative-in quote)
               (require require-spec ...)
               ([require-spec module-path
                              (only-in require-spec id-maybe-renamed ...)
@@ -356,6 +358,7 @@ Legal only in a @tech{module begin context}, and handled by the
                              (prefix-in prefix-id require-spec)
                              (rename-in require-spec [orig-id bind-id] ...)
                              (combine-in require-spec ...)
+                             (relative-in module-path require-spec ...)
                              (only-meta-in phase-level require-spec ...)
                              (for-syntax require-spec ...)
                              (for-template require-spec ...)
@@ -491,6 +494,16 @@ bindings of each @racket[require-spec] are visible for expanding later
     tcp-listen
   ]}
 
+ @defsubform[(relative-in module-path require-spec ...)]{
+  Like the union of the @racket[require-spec]s, but each
+  relative module path in a @racket[require-spec] is treated
+  as relative to @racket[module-path] instead of the enclosing
+  context.
+
+  The @tech{require transformer} that implements @racket[relative-in]
+  sets @racket[current-require-module-path] to adjust module paths
+  in the @racket[require-spec]s.}
+
  @defsubform[(only-meta-in phase-level require-spec ...)]{
   Like the combination of @racket[require-spec]s, but removing any
   binding that is not for @racket[phase-level], where @racket[#f] for

collects/tests/racket/module.rktl

@@ -470,6 +470,27 @@
 (test #t module-path? '(planet "foo.rkt" ("robby" "redex.plt") "sub" "deeper"))
 (test #t module-path? '(planet "foo%2e.rkt" ("robby%2e" "redex%2e.plt") "sub%2e" "%2edeeper"))
 
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; check `relative-in'
+
+(let ([check
+       (lambda (path)
+         (parameterize ([current-namespace (make-base-namespace)])
+           (eval
+            `(module relative-in-test racket/base
+               (require ,path)
+               (provide x)
+               (define x (string-join '("a" "b" "c") "."))))
+           (test "a.b.c" dynamic-require ''relative-in-test 'x)))])
+  (check 'racket/string)
+  (check '(relative-in racket/delay "string.rkt"))
+  (check '(relative-in racket "string.rkt"))
+  (check '(relative-in (lib "racket/main.rkt") "string.rkt"))
+  (check '(relative-in (lib "racket") "string.rkt"))
+  (check '(relative-in (lib "main.rkt" "racket") "string.rkt"))
+  (check `(relative-in ,(collection-file-path "delay.rkt" "racket") "string.rkt"))
+  (check '(relative-in racket (relative-in "private/reqprov.rkt" "../string.rkt"))))
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; check collection-path details
 

doc/release-notes/racket/HISTORY.txt

@@ -1,6 +1,7 @@
 Version 5.3.0.8
 Added variable-reference->module-path-index
 Added syntax-local-submodules
+Added relative-in
 
 Version 5.3.0.7
 compiler/zo-struct: added cancel-id field to phase-shift