From eab8008c4f62d8561c57d8642860f0c5061ddbc7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 10 Dec 2007 16:13:25 +0000 Subject: [PATCH] change 'include' and 'include-bitmap' to better match normal module-path syntax svn: r7936 --- collects/compiler/cffi.ss | 2 +- collects/drscheme/private/unit.ss | 36 ++--- collects/mrlib/include-bitmap.ss | 2 +- collects/mrlib/syntax-browser.ss | 6 +- collects/mzlib/include.ss | 67 ++++++++- collects/profj/tool.ss | 49 +++--- collects/scheme/gui/info.ss | 2 + collects/scheme/include.ss | 141 +++++++++++++++++- collects/scribblings/reference/include.scrbl | 65 ++++++++ collects/scribblings/reference/macros.scrbl | 1 + collects/scribblings/reference/stx-comp.scrbl | 84 ++++++++++- collects/slideshow/viewer.ss | 21 ++- collects/syntax/path-spec.ss | 48 +++--- 13 files changed, 435 insertions(+), 89 deletions(-) create mode 100644 collects/scheme/gui/info.ss create mode 100644 collects/scribblings/reference/include.scrbl diff --git a/collects/compiler/cffi.ss b/collects/compiler/cffi.ss index 65b414455c..4dc711aa5f 100644 --- a/collects/compiler/cffi.ss +++ b/collects/compiler/cffi.ss @@ -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) diff --git a/collects/drscheme/private/unit.ss b/collects/drscheme/private/unit.ss index 328ccc3cb6..79b05ab4fa 100644 --- a/collects/drscheme/private/unit.ss +++ b/collects/drscheme/private/unit.ss @@ -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)] diff --git a/collects/mrlib/include-bitmap.ss b/collects/mrlib/include-bitmap.ss index 7bb9f95bd3..3fb2ea4b77 100644 --- a/collects/mrlib/include-bitmap.ss +++ b/collects/mrlib/include-bitmap.ss @@ -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) diff --git a/collects/mrlib/syntax-browser.ss b/collects/mrlib/syntax-browser.ss index 1254119479..7f6bdf9325 100644 --- a/collects/mrlib/syntax-browser.ss +++ b/collects/mrlib/syntax-browser.ss @@ -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) diff --git a/collects/mzlib/include.ss b/collects/mzlib/include.ss index 26a3257933..d760b43bf6 100644 --- a/collects/mzlib/include.ss +++ b/collects/mzlib/include.ss @@ -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)) - - - - - diff --git a/collects/profj/tool.ss b/collects/profj/tool.ss index 946ff57f2a..e9790db905 100644 --- a/collects/profj/tool.ss +++ b/collects/profj/tool.ss @@ -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 diff --git a/collects/scheme/gui/info.ss b/collects/scheme/gui/info.ss new file mode 100644 index 0000000000..0a4d235f7b --- /dev/null +++ b/collects/scheme/gui/info.ss @@ -0,0 +1,2 @@ +(module info setup/infotab + (define name "Scheme GUI language")) diff --git a/collects/scheme/include.ss b/collects/scheme/include.ss index 5c7f4cbea0..2cf6e7739a 100644 --- a/collects/scheme/include.ss +++ b/collects/scheme/include.ss @@ -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))))])) diff --git a/collects/scribblings/reference/include.scrbl b/collects/scribblings/reference/include.scrbl new file mode 100644 index 0000000000..0084545986 --- /dev/null +++ b/collects/scribblings/reference/include.scrbl @@ -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].} diff --git a/collects/scribblings/reference/macros.scrbl b/collects/scribblings/reference/macros.scrbl index ca622bcd5d..96e930354d 100644 --- a/collects/scribblings/reference/macros.scrbl +++ b/collects/scribblings/reference/macros.scrbl @@ -18,3 +18,4 @@ called. @include-section["stx-props.scrbl"] @include-section["stx-certs.scrbl"] @include-section["stx-expand.scrbl"] +@include-section["include.scrbl"] diff --git a/collects/scribblings/reference/stx-comp.scrbl b/collects/scribblings/reference/stx-comp.scrbl index 6b9e997955..26b783828f 100644 --- a/collects/scribblings/reference/stx-comp.scrbl +++ b/collects/scribblings/reference/stx-comp.scrbl @@ -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].} diff --git a/collects/slideshow/viewer.ss b/collects/slideshow/viewer.ss index 0141390a1e..6753ba8e43 100644 --- a/collects/slideshow/viewer.ss +++ b/collects/slideshow/viewer.ss @@ -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) diff --git a/collects/syntax/path-spec.ss b/collects/syntax/path-spec.ss index 8fcf1826b1..ef614106f9 100644 --- a/collects/syntax/path-spec.ss +++ b/collects/syntax/path-spec.ss @@ -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)