change 'include' and 'include-bitmap' to better match normal module-path syntax

svn: r7936

original commit: eab8008c4f62d8561c57d8642860f0c5061ddbc7
This commit is contained in:
Matthew Flatt 2007-12-10 16:13:25 +00:00
parent fcdea053bb
commit fb74476915

View File

@ -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))