change 'include' and 'include-bitmap' to better match normal module-path syntax
svn: r7936 original commit: eab8008c4f62d8561c57d8642860f0c5061ddbc7
This commit is contained in:
parent
fcdea053bb
commit
fb74476915
|
@ -1,11 +1,71 @@
|
|||
|
||||
(module include mzscheme
|
||||
(require-for-syntax (lib "stx.ss" "syntax")
|
||||
(lib "path-spec.ss" "syntax")
|
||||
"private/increader.ss"
|
||||
"cm-accomplice.ss")
|
||||
(require (lib "etc.ss"))
|
||||
|
||||
(define-for-syntax (resolve-path-spec fn loc stx build-path-stx)
|
||||
(let ([file
|
||||
(syntax-case* fn (lib) module-or-top-identifier=?
|
||||
[_
|
||||
(string? (syntax-e fn))
|
||||
(let ([s (syntax-e fn)])
|
||||
(unless (or (relative-path? s)
|
||||
(absolute-path? s))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad pathname string"
|
||||
stx
|
||||
fn))
|
||||
(string->path s))]
|
||||
[(-build-path elem ...)
|
||||
(module-or-top-identifier=? #'-build-path build-path-stx)
|
||||
(let ([l (syntax-object->datum (syntax (elem ...)))])
|
||||
(when (null? l)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"`build-path' keyword is not followed by at least one string"
|
||||
stx
|
||||
fn))
|
||||
(apply build-path l))]
|
||||
[(lib filename ...)
|
||||
(let ([l (syntax-object->datum (syntax (filename ...)))])
|
||||
(unless (or (andmap string? l)
|
||||
(pair? l))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"`lib' keyword is not followed by a sequence of string datums"
|
||||
stx
|
||||
fn))
|
||||
(build-path (if (null? (cdr l))
|
||||
(collection-path "mzlib")
|
||||
(apply collection-path (cdr l)))
|
||||
(car l)))]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not a pathname string, `build-path' form, or `lib' form for file"
|
||||
stx
|
||||
fn)])])
|
||||
(if (complete-path? file)
|
||||
file
|
||||
(path->complete-path
|
||||
file
|
||||
(cond
|
||||
;; Src of include expression is a path?
|
||||
[(and (path? (syntax-source loc))
|
||||
(complete-path? (syntax-source loc)))
|
||||
(let-values ([(base name dir?)
|
||||
(split-path (syntax-source loc))])
|
||||
(if dir?
|
||||
(syntax-source loc)
|
||||
base))]
|
||||
;; Load relative?
|
||||
[(current-load-relative-directory)]
|
||||
;; Current directory
|
||||
[(current-directory)])))))
|
||||
|
||||
(define-syntax-set (do-include ; private
|
||||
include-at/relative-to
|
||||
include
|
||||
|
@ -143,8 +203,3 @@
|
|||
include-at/relative-to
|
||||
include/reader
|
||||
include-at/relative-to/reader))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
Loading…
Reference in New Issue
Block a user