suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
svn: r7936
This commit is contained in:
Matthew Flatt 2007-12-10 16:13:25 +00:00
parent 65d7f486b8
commit eab8008c4f
13 changed files with 435 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/compiler/cffi.ss
View File

@ -304,7 +304,7 @@
(raise-syntax-error #f "only allowed at the top-level or a module top-level" stx))
(syntax-case stx ()
[(_ path)
(let ([pathname (resolve-path-spec #'path #'path stx #'build-path)])
(let ([pathname (resolve-path-spec #'path #'path stx)])
(let ([str
(with-handlers ([exn:fail?
(lambda (x)

36
collects/drscheme/private/unit.ss
View File

@ -11,14 +11,14 @@ module browser threading seems wrong.
|#
(module unit mzscheme
(require (lib "contract.ss")
(lib "unit.ss")
(lib "class.ss")
(lib "file.ss")
(lib "etc.ss")
(lib "list.ss")
(lib "port.ss")
(module unit scheme/base
(require scheme/contract
scheme/unit
scheme/class
scheme/file
scheme/port
scheme/list
(only-in (lib "etc.ss") compose)
(lib "string-constant.ss" "string-constants")
(lib "framework.ss" "framework")
(lib "name-message.ss" "mrlib")
@ -27,10 +27,10 @@ module browser threading seems wrong.
"drsig.ss"
"auto-language.ss"
(prefix drscheme:arrow: "../arrow.ss")
(prefix-in drscheme:arrow: "../arrow.ss")
(lib "mred.ss" "mred")
(prefix mred: (lib "mred.ss" "mred"))
(prefix-in mred: (lib "mred.ss" "mred"))
(lib "date.ss"))
@ -377,7 +377,7 @@ module browser threading seems wrong.
(unless definitions-text%
(set! definitions-text% (make-definitions-text%)))
definitions-text%)))
(define (make-definitions-text%)
(let ([definitions-super%
((get-program-editor-mixin)
@ -538,7 +538,7 @@ module browser threading seems wrong.
(define/pubment (get-next-settings) next-settings)
(define/pubment set-next-settings
(opt-lambda (_next-settings [update-prefs? #t])
(lambda (_next-settings [update-prefs? #t])
(when (or (send (drscheme:language-configuration:language-settings-language _next-settings)
get-reader-module)
(send (drscheme:language-configuration:language-settings-language next-settings)
@ -859,7 +859,7 @@ module browser threading seems wrong.
(super-new (label "(define ...)"))))
;; defn = (make-defn number string number number)
(define-struct defn (indent name start-pos end-pos))
(define-struct defn (indent name start-pos end-pos) #:mutable)
;; get-definitions : boolean text -> (listof defn)
(define (get-definitions tag-string indent? text)
@ -2165,7 +2165,7 @@ module browser threading seems wrong.
;; create-new-tab : -> void
;; creates a new tab and updates the GUI for that new tab
(define/private create-new-tab
(opt-lambda ([filename #f])
(lambda ([filename #f])
(let* ([defs (new (drscheme:get/extend:get-definitions-text))]
[tab-count (length tabs)]
[new-tab (new (drscheme:get/extend:get-tab)
@ -2262,7 +2262,7 @@ module browser threading seems wrong.
(change-to-tab (cond
[(< (send tab get-i) (length tabs))
(list-ref tabs (send tab get-i))]
[else (car (last-pair tabs))])))
[else (last tabs)])))
(loop (cdr l-tabs))))]))]))
(define/private (close-tab tab)
@ -2526,7 +2526,7 @@ module browser threading seems wrong.
[lang (drscheme:language-configuration:language-settings-language lang/config)]
[strs (send lang get-language-position)]
[can-browse?
(or (regexp-match #rx"module" (car (last-pair strs)))
(or (regexp-match #rx"module" (last strs))
(ormap (λ (x) (regexp-match #rx"PLT" x))
strs))])
(unless can-browse?
@ -2783,7 +2783,7 @@ module browser threading seems wrong.
(let ([items (send menu get-items)])
(when (null? items)
(error 'register-capability-menu-item "menu ~e has no items" menu))
(let* ([menu-item (car (last-pair items))]
(let* ([menu-item (last items)]
[this-one (list menu-item (- (length items) 1) key)]
[old-ones (hash-table-get capability-menu-items menu (λ () '()))])
(hash-table-put! capability-menu-items menu (cons this-one old-ones)))))
@ -3716,7 +3716,7 @@ module browser threading seems wrong.
(create-new-drscheme-frame name)))]
[else
(create-new-drscheme-frame name)])]))
(define first-frame? #t)
(define (create-new-drscheme-frame filename)
(let* ([drs-frame% (drscheme:get/extend:get-unit-frame)]

2
collects/mrlib/include-bitmap.ss
View File

@ -13,7 +13,7 @@
(define-syntax (-include-bitmap stx)
(syntax-case stx ()
[(_ orig-stx source path-spec type)
(let* ([c-file (resolve-path-spec #'path-spec #'source #'orig-stx #'build-path)]
(let* ([c-file (resolve-path-spec #'path-spec #'source #'orig-stx)]
[content
(with-handlers ([exn:fail?
(lambda (exn)

6
collects/mrlib/syntax-browser.ss
View File

@ -6,7 +6,7 @@ needed to really make this work:
|#
(module syntax-browser mzscheme
(module syntax-browser scheme/base
(require (lib "pretty.ss")
(lib "list.ss")
(lib "class.ss")
@ -400,7 +400,7 @@ needed to really make this work:
(define black-style-delta (make-object style-delta% 'change-normal-color))
(define green-style-delta (make-object style-delta%))
(send green-style-delta set-delta-foreground "forest green")
(void (send green-style-delta set-delta-foreground "forest green"))
(define small-style (make-object style-delta% 'change-size 4))
(define turn-snip%
@ -591,7 +591,7 @@ needed to really make this work:
(contents ,contents))
(foldl
add-properties
(datum->syntax-object
(datum->syntax
#'here ;; ack
(unmarshall-object contents)
(list (unmarshall-object src)

67
collects/mzlib/include.ss
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))

49
collects/profj/tool.ss
View File

@ -1,18 +1,20 @@
(module tool mzscheme
(module tool scheme/base
(require (lib "tool.ss" "drscheme") (lib "contract.ss")
(lib "mred.ss" "mred") (lib "framework.ss" "framework")
(lib "errortrace-lib.ss" "errortrace")
(prefix u: (lib "unit.ss"))
(lib "file.ss")
(prefix-in u: (lib "unit.ss"))
scheme/file
(lib "include-bitmap.ss" "mrlib") (lib "etc.ss")
(lib "class.ss")
(lib "string-constant.ss" "string-constants")
(lib "Object.ss" "profj" "libs" "java" "lang") (lib "array.ss" "profj" "libs" "java" "lang")
(lib "String.ss" "profj" "libs" "java" "lang"))
(require "compile.ss" "parameters.ss" "parsers/lexer.ss" "parser.ss" "ast.ss" "tester.scm"
(require "compile.ss" "parameters.ss" "parsers/lexer.ss" "parser.ss"
(except-in "ast.ss" for) "tester.scm"
"display-java.ss")
(require-for-syntax "compile.ss")
(require (for-syntax scheme/base
"compile.ss"))
(provide tool@)
@ -273,7 +275,8 @@
;(make-profj-settings symbol boolean boolean boolean boolean (list string))
(define-struct profj-settings
(print-style print-full? allow-check? allow-test? run-tests? coverage? classpath) (make-inspector))
(print-style print-full? allow-check? allow-test? run-tests? coverage? classpath)
#:transparent)
;ProfJ general language mixin
(define (java-lang-mixin level name number one-line dyn? manual-dirname)
@ -593,8 +596,8 @@
(let ((end? (eof-object? (peek-char-or-special port))))
(if end?
eof
(datum->syntax-object #f `(parse-java-full-program ,(parse port name level)
,name) #f)))))))
(datum->syntax #f `(parse-java-full-program ,(parse port name level)
,name) #f)))))))
(define/public (front-end/interaction port settings)
(mred? #t)
(let ([name (object-name port)]
@ -605,7 +608,7 @@
(begin
(set! executed? #t)
(syntax-as-top
(datum->syntax-object
(datum->syntax
#f
#;`(compile-interactions-helper ,(lambda (ast) (compile-interactions-ast ast name level execute-types))
,(parse-interactions port name level))
@ -639,15 +642,15 @@
(syntax-case tc (parse-java-interactions)
((test-case eq (parse-java-interactions ast-1 ed-1)
(parse-java-interactions ast-2 ed-2) end1 end2)
(datum->syntax-object #f
`(,(syntax test-case)
,(dynamic-require '(lib "profj-testing.ss" "profj") 'java-values-equal?);,(syntax eq)
,(compile-interactions-ast (syntax-object->datum (syntax ast-1))
(syntax-object->datum (syntax ed-1)) level type-recs #f)
,(compile-interactions-ast (syntax-object->datum (syntax ast-2))
(syntax-object->datum (syntax ed-2)) level type-recs #f)
,(syntax end1) ,(syntax end2))
#f))
(datum->syntax #f
`(,(syntax test-case)
,(dynamic-require '(lib "profj-testing.ss" "profj") 'java-values-equal?);,(syntax eq)
,(compile-interactions-ast (syntax->datum (syntax ast-1))
(syntax->datum (syntax ed-1)) level type-recs #f)
,(compile-interactions-ast (syntax->datum (syntax ast-2))
(syntax->datum (syntax ed-2)) level type-recs #f)
,(syntax end1) ,(syntax end2))
#f))
(_ tc))) (process-extras (cdr extras) type-recs))
#;(cons (test-case-test (car extras)) (process-extras (cdr extras) type-recs)))
#;((interact-case? (car extras))
@ -832,7 +835,7 @@
(errortrace-annotate syn)))
(loop (cdr mods) extras #t)))))))))
((parse-java-interactions ex loc)
(let ((exp (syntax-object->datum (syntax ex))))
(let ((exp (syntax->datum (syntax ex))))
(old-current-eval
(syntax-as-top (compile-interactions-ast exp (syntax loc) level execute-types #t)))))
(_ (old-current-eval exp))))))
@ -1113,7 +1116,7 @@
;(printf "~a~n~a~n" syntax-list (map remove-requires syntax-list))
(if ret-list?
syntax-list
(datum->syntax-object #f `(begin ,@(map remove-requires syntax-list)) #f)))))
(datum->syntax #f `(begin ,@(map remove-requires syntax-list)) #f)))))
(define (remove-requires syn)
(syntax-case* syn (begin require) (lambda (r1 r2) (eq? (syntax-e r1) (syntax-e r2)))
((begin (require x ...) exp1 exp ...) (syntax (begin exp1 exp ...)))
@ -1165,8 +1168,8 @@
(define-syntax (compile-interactions-helper syn)
(syntax-case syn ()
((_ comp ast)
(namespace-syntax-introduce ((syntax-object->datum (syntax comp))
(syntax-object->datum (syntax ast)))))))
(namespace-syntax-introduce ((syntax->datum (syntax comp))
(syntax->datum (syntax ast)))))))
(define (get-module-name stx)
(syntax-case stx (module #%plain-module-begin)
@ -1188,7 +1191,7 @@
(display " - ")
(display (,(string->symbol (string-append (cadr (main)) "-main_java.lang.String1")) x)))
'void)])
(with-syntax ([main (datum->syntax-object #f execute-body #f)])
(with-syntax ([main (datum->syntax #f execute-body #f)])
(values (syntax name)
(syntax (module name lang
(#%plain-module-begin

2
collects/scheme/gui/info.ss Normal file
View File

@ -0,0 +1,2 @@
(module info setup/infotab
(define name "Scheme GUI language"))

141
collects/scheme/include.ss
View File

@ -1,4 +1,139 @@
#lang scheme/base
(module include scheme/base
(require mzlib/include)
(provide (all-from-out mzlib/include)))
(require (for-syntax scheme/base
syntax/stx
syntax/path-spec
mzlib/private/increader
mzlib/cm-accomplice))
(provide include
include-at/relative-to
include/reader
include-at/relative-to/reader)
(define-syntax (do-include stx)
(syntax-case stx ()
[(_ orig-stx ctx loc fn reader)
;; Parse the file name
(let ([c-file (resolve-path-spec (syntax fn) (syntax loc) (syntax orig-stx))]
[ctx (syntax ctx)]
[loc (syntax loc)]
[reader (syntax reader)]
[orig-stx (syntax orig-stx)])
(register-external-file c-file)
(let ([read-syntax (if (syntax-e reader)
(reader-val
(let loop ([e (syntax->datum
(local-expand reader 'expression null))])
(cond
[(reader? e) e]
[(pair? e) (or (loop (car e))
(loop (cdr e)))]
[else #f])))
read-syntax)])
(unless (and (procedure? read-syntax)
(procedure-arity-includes? read-syntax 2))
(raise-syntax-error
#f
"reader is not a procedure of two arguments"
orig-stx))
;; Open the included file
(let ([p (with-handlers ([exn:fail?
(lambda (exn)
(raise-syntax-error
#f
(format
"can't open include file (~a)"
(if (exn? exn)
(exn-message exn)
exn))
orig-stx
c-file))])
(open-input-file c-file))])
(port-count-lines! p)
;; Read expressions from file
(let ([content
(let loop ()
(let ([r (with-handlers ([exn:fail?
(lambda (exn)
(close-input-port p)
(raise-syntax-error
#f
(format
"read error (~a)"
(if (exn? exn)
(exn-message exn)
exn))
orig-stx))])
(read-syntax c-file p))])
(if (eof-object? r)
null
(cons r (loop)))))])
(close-input-port p)
;; Preserve src info for content, but set its
;; lexical context to be that of the include expression
(let ([lexed-content
(let loop ([content content])
(cond
[(pair? content)
(cons (loop (car content))
(loop (cdr content)))]
[(null? content) null]
[else
(let ([v (syntax-e content)])
(datum->syntax
ctx
(cond
[(pair? v)
(loop v)]
[(vector? v)
(list->vector (loop (vector->list v)))]
[(box? v)
(box (loop (unbox v)))]
[else
v])
content))]))])
(datum->syntax
(quote-syntax here)
`(begin ,@lexed-content)
orig-stx))))))]))
(define-syntax (include stx)
(syntax-case stx ()
[(_ fn)
(with-syntax ([_stx stx])
(syntax/loc stx (do-include _stx _stx _stx fn #f)))]))
(define (include-at/relative-to stx)
(syntax-case stx ()
[(_ ctx loc fn)
(with-syntax ([_stx stx])
(syntax/loc stx (do-include _stx ctx loc fn #f)))]))
(define (include/reader stx)
(syntax-case stx ()
[(_ fn reader)
;; Expand to do-include:
(with-syntax ([_stx stx])
(syntax/loc stx
(do-include _stx _stx _stx fn
(letrec-syntax ([the-reader (lambda (stx)
(datum->syntax
#'here
(make-reader reader)))])
the-reader))))]))
(define (include-at/relative-to/reader stx)
(syntax-case stx ()
[(_ ctx loc fn reader)
(with-syntax ([_stx stx])
(syntax/loc stx
(do-include _stx ctx loc fn
(letrec-syntax ([the-reader (lambda (stx)
(datum->syntax
#'here
(make-reader reader)))])
the-reader))))]))

65
collects/scribblings/reference/include.scrbl Normal file
View File

@ -0,0 +1,65 @@
#lang scribble/doc
@require["mz.ss"]
@title[#:tag "include"]{File Inclusion}
@note-lib[scheme/include]
@defform/subs[#:literals (file lib)
(include path-spec)
([include-spec string
(file string)
(lib string ...+)])]{
Inlines the syntax in the file designated by @scheme[path-spec] in
place of the @scheme[include] expression.
A @scheme[path-spec] resembles a subset of the @scheme[_mod-path]
forms for @scheme[require], but it specifies a file whose content need
not be a module. That is, @scheme[string] refers to a file using a
platform-independent relative path, @scheme[(file string)] refers to a
file using platform-specific notation, and @scheme[(lib string ...)]
refers to a file within a collection.
If @scheme[path-spec] specifies a relative path, the path is resolved
relative to the source for the @scheme[include] expression, if that
source is a complete path string. If the source is not a complete path
string, then @scheme[path-spec] is resolved relative to
@scheme[(current-load-relative-directory)] if it is not @scheme[#f],
or relative to @scheme[(current-directory)] otherwise.
The included syntax is given the lexical context of the
@scheme[include] expression, while the included syntax's source
location refers to its actual source.}
@defform[(include-at/relative-to context source path-spec)]{
Like @scheme[include], except that the lexical context of
@scheme[context] is used for the included syntax, and a relative
@scheme[path-spec] is resolved with respect to the source of
@scheme[source]. The @scheme[context] and @scheme[source] elements are
otherwise discarded by expansion.}
@defform[(include/reader path-spec reader-expr)]{
Like @scheme[include], except that the procedure produced by the
expression @scheme[reader-expr] is used to read the included file,
instead of @scheme[read-syntax].
The @scheme[reader-expr] is evaluated at expansion time in the
@tech{transformer environment}. Since it serves as a replacement for
@scheme[read-syntax], the expression's value should be a procedure
that consumes two inputs---a string representing the source and an
input port---and produces a syntax object or @scheme[eof]. The
procedure will be called repeatedly until it produces @scheme[eof].
The syntax objects returned by the procedure should have source
location information, but usually no lexical context; any lexical
context in the syntax objects will be ignored.}
@defform[(include-at/relative-to/reader context source path-spec reader-expr)]{
Combines @scheme[include-at/relative-to] and @scheme[include/reader].}

1
collects/scribblings/reference/macros.scrbl
View File

@ -18,3 +18,4 @@ called.
@include-section["stx-props.scrbl"]
@include-section["stx-certs.scrbl"]
@include-section["stx-expand.scrbl"]
@include-section["include.scrbl"]

84
collects/scribblings/reference/stx-comp.scrbl
View File

@ -1,5 +1,7 @@
#lang scribble/doc
@require["mz.ss"]
@(require "mz.ss"
(for-label scheme/stxparam
scheme/stxparam-exptime))
@title[#:tag "stxcmp"]{Syntax Object Bindings}
@ -159,3 +161,83 @@ for the identifier's binding in the @tech{label phase level} (see
Unlike @scheme[identifier-binding], the result cannot be
@scheme['lexical].}
@; ----------------------------------------------------------------------
@section[#:tag "stxparam"]{Syntax Parameters}
@note-lib-only[scheme/stxparam]
@defform[(define-syntax-parameter id expr)]{
Binds @scheme[id] as syntax to a @deftech{syntax
parameter}. The @scheme[expr] is an expression in the
@tech{transformer environment} that serves as the default value for
the @tech{syntax parameter}. The value is typically obtained by a transformer
using @scheme[syntax-parameter-value].
The @scheme[id] can be used with @scheme[syntax-parameterize]
or @scheme[syntax-parameter-value] (in a transformer). If
@scheme[expr] produces a procedure of one argument or a
@scheme[make-set!-transformer] result, then @scheme[id] can be
used as a macro. If @scheme[expr] produces a
@scheme[rename-transformer] result, then @scheme[id] can be
used as a macro that expands to a use of the target identifier, but
@scheme[syntax-local-value] of @scheme[id] does not produce
the target's value.}
@defform[(syntax-parameterize ((id expr) ...) body-expr ...+)]{
Each @scheme[id] must be bound to a @tech{syntax parameter} using
@scheme[define-syntax-parameter]. Each @scheme[expr] is an expression
in the @tech{transformer environment}. During the expansion of the
@scheme[body-expr]s, the value of each @scheme[expr] is bound to the
corresponding @scheme[id].
If an @scheme[expr] produces a procedure of one argument or a
@scheme[make-set!-transformer] result, then its @scheme[id]
can be used as a macro during the expansion of the
@scheme[body-expr]s. If @scheme[expr] produces a
@scheme[rename-transformer] result, then @scheme[id] can be
used as a macro that expands to a use of the target identifier, but
@scheme[syntax-local-value] of @scheme[id] does not produce
the target's value.}
@defproc[(syntax-parameter-value [id-stx syntax?]) any]{
This procedure is intended for use in a @tech{transformer
environment}, where @scheme[id-stx] is an identifier bound in the
normal environment to a @tech{syntax parameter}. The result is the current
value of the @tech{syntax parameter}, as adjusted by
@scheme[syntax-parameterize] form.
This binding is provided @scheme[for-syntax] by
@schememodname[scheme/stxparam], since it is normally used in a
transformer. It is provided normally by
@scheme[scheme/stxparam-exptime].}
@defproc[(make-parameter-rename-transformer [id-stx syntax?]) any]{
This procedure is intended for use in a transformer, where
@scheme[id-stx] is an identifier bound to a @tech{syntax parameter}. The
result is transformer that behaves as @scheme[id-stx], but that cannot
be used with @scheme[syntax-parameterize] or
@scheme[syntax-parameter-value].
Using @scheme[make-parameter-rename-transformer] is analogous to
defining a procedure that calls a parameter. Such a procedure can be
exported to others to allow access to the parameter value, but not to
change the parameter value. Similarly,
@scheme[make-parameter-rename-transformer] allows a @tech{syntax parameter}
to used as a macro, but not changed.
The result of @scheme[make-parameter-rename-transformer] is not
treated specially by @scheme[syntax-local-value], unlike the result
of @scheme[make-rename-transformer].
This binding is provided @scheme[for-syntax] by
@schememodname[scheme/stxparam], since it is normally used in a
transformer. It is provided normally by
@scheme[scheme/stxparam-exptime].}

21
collects/slideshow/viewer.ss
View File

@ -1,15 +1,14 @@
(module viewer mzscheme
(require (lib "class.ss")
(lib "unit.ss")
(lib "file.ss")
(lib "etc.ss")
(lib "contract.ss")
(lib "mred.ss" "mred")
(module viewer scheme/base
(require scheme/class
scheme/unit
scheme/contract
scheme/list
scheme/file
mred
(lib "mrpict.ss" "texpict")
(lib "utils.ss" "texpict")
(lib "math.ss")
(lib "list.ss")
scheme/math
(lib "include-bitmap.ss" "mrlib")
"sig.ss"
"core.ss"
@ -140,7 +139,7 @@
(make-vector
(- 4 (length l))
(make-sliderec void #f #f
(sliderec-page (car (last-pair l)))
(sliderec-page (last l))
1
zero-inset
null
@ -993,7 +992,7 @@
(define c-both (make-object two-c% f-both))
(define refresh-page
(opt-lambda ([immediate-prefetch? #f])
(lambda ([immediate-prefetch? #f])
(hide-cursor-until-moved)
(send f set-blank-cursor #t)
(when (= current-page 0)

48
collects/syntax/path-spec.ss
View File

@ -4,47 +4,51 @@
(provide resolve-path-spec)
(define (resolve-path-spec fn loc stx build-path-stx)
(define (resolve-path-spec fn loc stx)
(let ([file
(syntax-case* fn (lib) module-or-top-identifier=?
(syntax-case fn (lib file)
[_
(string? (syntax-e fn))
(let ([s (syntax-e fn)])
(unless (or (relative-path? s)
(absolute-path? s))
(unless (module-path? s)
(raise-syntax-error
#f
"bad pathname string"
"bad relative pathname string"
stx
fn))
(string->path s))]
[(-build-path elem ...)
(module-or-top-identifier=? #'-build-path build-path-stx)
(let ([l (syntax->datum (syntax (elem ...)))])
(when (null? l)
(apply build-path
(regexp-split #rx"/" s)))]
[(file . _)
(let ([l (syntax->datum fn)])
(unless (module-path? l)
(raise-syntax-error
#f
"`build-path' keyword is not followed by at least one string"
"bad `file' path"
stx
fn))
(apply build-path l))]
[(lib filename ...)
(let ([l (syntax->datum (syntax (filename ...)))])
(unless (or (andmap string? l)
(pair? l))
(string->path (cadr l)))]
[(lib . _)
(let ([l (syntax->datum fn)])
(unless (module-path? l)
(raise-syntax-error
#f
"`lib' keyword is not followed by a sequence of string datums"
"bad `lib' path"
stx
fn))
(build-path (if (null? (cdr l))
(collection-path "mzlib")
(apply collection-path (cdr l)))
(car l)))]
(let ([s (resolved-module-path-name
(module-path-index-resolve
(module-path-index-join l #f)))])
(if (path? s)
s
(raise-syntax-error
#f
"`lib' path produced symbolic module name"
stx
fn))))]
[else
(raise-syntax-error
#f
"not a pathname string, `build-path' form, or `lib' form for file"
"not a pathname string, `file' form, or `lib' form for file"
stx
fn)])])
(if (complete-path? file)