diff --git a/collects/at-exp/lang/reader.ss b/collects/at-exp/lang/reader.ss index b519a3f079..5a9deb10e1 100644 --- a/collects/at-exp/lang/reader.ss +++ b/collects/at-exp/lang/reader.ss @@ -14,18 +14,19 @@ (apply p args)))) (define-values (at-read at-read-syntax at-get-info) - (make-meta-reader 'at-exp - "language path" - (lambda (str) - (let ([s (string->symbol - (string-append (bytes->string/latin-1 str) - "/lang/reader"))]) - (and (module-path? s) s))) - wrap-reader - wrap-reader - (lambda (proc) - (lambda (key defval) - (case key - [(color-lexer) - (dynamic-require 'syntax-color/scribble-lexer 'scribble-lexer)] - [else (if proc (proc key defval) defval)])))))) + (make-meta-reader + 'at-exp + "language path" + (lambda (str) + (let ([s (string->symbol + (string-append (bytes->string/latin-1 str) + "/lang/reader"))]) + (and (module-path? s) s))) + wrap-reader + wrap-reader + (lambda (proc) + (lambda (key defval) + (case key + [(color-lexer) + (dynamic-require 'syntax-color/scribble-lexer 'scribble-lexer)] + [else (if proc (proc key defval) defval)])))))) diff --git a/collects/planet/lang/reader.ss b/collects/planet/lang/reader.ss index 95d632e2dd..09a8aaf71c 100644 --- a/collects/planet/lang/reader.ss +++ b/collects/planet/lang/reader.ss @@ -6,13 +6,14 @@ [planet-get-info get-info])) (define-values (planet-read planet-read-syntax planet-get-info) - (make-meta-reader 'planet - "planet path" - (lambda (str) - (let ([str (bytes->string/latin-1 str)]) - (if (module-path? `(planet ,(string->symbol str))) - `(planet ,(string->symbol (string-append str "/lang/reader"))) - #f))) - values - values - values))) + (make-meta-reader + 'planet + "planet path" + (lambda (str) + (let ([str (bytes->string/latin-1 str)]) + (if (module-path? `(planet ,(string->symbol str))) + `(planet ,(string->symbol (string-append str "/lang/reader"))) + #f))) + values + values + values))) diff --git a/collects/reader/lang/reader.ss b/collects/reader/lang/reader.ss index 1c8ebd8c14..1473e045f9 100644 --- a/collects/reader/lang/reader.ss +++ b/collects/reader/lang/reader.ss @@ -6,11 +6,11 @@ [-get-info get-info])) (define-values (-read -read-syntax -get-info) - (make-meta-reader 'reader - "language path" - #:read-spec (lambda (in) (read in)) - (lambda (s) - (and (module-path? s) s)) - values - values - values))) + (make-meta-reader + 'reader + "language path" + #:read-spec (lambda (in) (read in)) + (lambda (s) (and (module-path? s) s)) + values + values + values))) diff --git a/collects/syntax/module-reader.ss b/collects/syntax/module-reader.ss index eeb0c6483e..8d1dd31ece 100644 --- a/collects/syntax/module-reader.ss +++ b/collects/syntax/module-reader.ss @@ -21,41 +21,42 @@ (if (not (and (pair? body) (pair? (cdr body)) (keyword? (syntax-e (car body))))) - (datum->syntax stx body stx) - (let* ([k (car body)] [k* (syntax-e k)] [v (cadr body)]) - (case k* - [(kwd) (if var - (err (format "got two ~s keywords" k*) k) - (begin (set! var v) (loop (cddr body))))] - ... - [else (err "got an unknown keyword" (car body))]))))) + (datum->syntax stx body stx) + (let* ([k (car body)] [k* (syntax-e k)] [v (cadr body)]) + (case k* + [(kwd) (if var + (err (format "got two ~s keywords" k*) k) + (begin (set! var v) (loop (cddr body))))] + ... + [else (err "got an unknown keyword" (car body))]))))) checks ... (unless var (set! var default)) ...)) (define (datum->syntax stx 'language-module stx)) (define (datum->syntax stx 'language-data stx)) (define (construct-reader lang body) (keywords body - [#:language ~lang lang] - [#:read ~read #'read] - [#:read-syntax ~read-syntax #'read-syntax] - [#:wrapper1 ~wrapper1 #'#f] - [#:wrapper2 ~wrapper2 #'#f] - [#:whole-body-readers? ~whole-body-readers? #'#f] - [#:info ~info #'#f] - [(when (equal? (and lang #t) (and ~lang #t)) - (err (string-append - "must specify either a module language, or #:language" - (if (and lang ~lang) ", not both" "")))) - (unless (equal? (and ~read #t) (and ~read-syntax #t)) - (err "must specify either both #:read and #:read-syntax, or none")) - (when (and ~whole-body-readers? (not (and ~read ~read-syntax))) - (err "got a #:whole-body-readers? without #:read and #:read-syntax"))]) - ;; FIXME: a lot of the generated code is constant and should be lifted + [#:language ~lang lang] + [#:read ~read #'read] + [#:read-syntax ~read-syntax #'read-syntax] + [#:wrapper1 ~wrapper1 #'#f] + [#:wrapper2 ~wrapper2 #'#f] + [#:whole-body-readers? ~whole-body-readers? #'#f] + [#:info ~info #'#f] + [(when (equal? (and lang #t) (and ~lang #t)) + (err (string-append + "must specify either a module language, or #:language" + (if (and lang ~lang) ", not both" "")))) + (unless (equal? (and ~read #t) (and ~read-syntax #t)) + (err "must specify either both #:read and #:read-syntax, or none")) + (when (and ~whole-body-readers? (not (and ~read ~read-syntax))) + (err "got a #:whole-body-readers? without #:read and #:read-syntax"))]) + ;; FIXME: a lot of the generated code is constant and should be lifted ;; out of the template: (quasisyntax/loc stx (#%module-begin #,@body - (#%provide (rename lang:read read) (rename lang:read-syntax read-syntax) + (#%provide (rename lang:read read) + (rename lang:read-syntax read-syntax) read-properties get-info-getter get-info) (define (lang:read in modpath line col pos) (wrap-internal/wrapper #f #f in modpath line col pos)) @@ -66,41 +67,43 @@ [lang (car props)] [#, lang] ;\ visible in [data (cadr props)] [#, data] ;/ user-code [read (if stx? - (let ([rd #,~read-syntax]) (lambda (in) (rd src in))) - #,~read)] + (let ([rd #,~read-syntax]) + (lambda (in) (rd src in))) + #,~read)] [w1 #,~wrapper1] [w2 #,~wrapper2] [whole? #,~whole-body-readers?] - [rd (lambda (in) (wrap-internal (if (and (not stx?) (syntax? lang)) - (syntax->datum lang) - lang) - in read whole? w1 stx? - modpath src line col pos))] + [rd (lambda (in) + (wrap-internal (if (and (not stx?) (syntax? lang)) + (syntax->datum lang) + lang) + in read whole? w1 stx? + modpath src line col pos))] [r (cond [(not w2) (rd in)] [(ar? w2 3) (w2 in rd stx?)] [else (w2 in rd)])]) (if stx? - (syntax-property r 'module-language - (vector (syntax->datum modpath) 'get-info-getter - props)) - r))) + (syntax-property r + 'module-language + (vector (syntax->datum modpath) 'get-info-getter props)) + r))) (define lang* (let ([lang #,~lang]) (if (not (procedure? lang)) - (list lang #f) - (cond [(ar? lang 5) lang] - [(ar? lang 1) (lambda (in . _) (lang in))] - [(ar? lang 0) (lambda _ (lang))] - [else (raise-type-error - 'syntax/module-reader - "language+reader procedure of 5, 1, or 0 arguments" - lang)])))) + (list lang #f) + (cond [(ar? lang 5) lang] + [(ar? lang 1) (lambda (in . _) (lang in))] + [(ar? lang 0) (lambda _ (lang))] + [else (raise-type-error + 'syntax/module-reader + "language+reader procedure of 5, 1, or 0 arguments" + lang)])))) (define (read-properties in modpath line col pos) (if (not (procedure? lang*)) - lang* - (call-with-values - (lambda () (parameterize ([current-input-port in]) - (lang* in modpath line col pos))) + lang* + (call-with-values + (lambda () (parameterize ([current-input-port in]) + (lang* in modpath line col pos))) (lambda xs (case (length xs) [(2) xs] [(1) (list (car xs) #f)] @@ -124,14 +127,14 @@ [#, data] ;/ user-code [info #,~info]) (if (or (not info) (and (procedure? info) (ar? info 3))) - info - (raise-type-error 'syntax/module-reader - "info procedure of 3 arguments" info)))) + info + (raise-type-error 'syntax/module-reader + "info procedure of 3 arguments" info)))) (define (language-info what defval) (if info - (let ([r (info what defval default-info)]) - (if (eq? r default-info) (default-info what defval) r)) - (default-info what defval))) + (let ([r (info what defval default-info)]) + (if (eq? r default-info) (default-info what defval) r)) + (default-info what defval))) language-info)))) (syntax-case stx () [(_ lang body ...) @@ -146,11 +149,9 @@ ;; expression that begins with the literal #%module-begin. If so, ;; it just returns that expression, else it wraps with #%module-begin. (define (wrap-#%module-begin exps stx?) - (define wrapped-exps + (define wrapped-exps (let ([wrapped `(#%module-begin . ,exps)]) - (if stx? - (datum->syntax #f wrapped) - wrapped))) + (if stx? (datum->syntax #f wrapped) wrapped))) (let ([exps (if stx? (syntax->list exps) exps)]) (cond [(null? exps) wrapped-exps] @@ -165,10 +166,12 @@ (let* ([lang (if stx? (datum->syntax #f lang modpath modpath) lang)] [body (lambda () (if whole? - (read port) - (let loop ([a null]) - (let ([v (read port)]) - (if (eof-object? v) (reverse a) (loop (cons v a)))))))] + (read port) + (let loop ([a null]) + (let ([v (read port)]) + (if (eof-object? v) + (reverse a) + (loop (cons v a)))))))] [body (cond [(not wrapper) (body)] [(ar? wrapper 2) (wrapper body stx?)] [else (wrapper body)])] @@ -176,25 +179,27 @@ (let-values ([(l c p) (port-next-location port)]) (and p (- p pos))))] [body (if (and stx? (not (syntax? body))) - (datum->syntax #f body all-loc) - body)] + (datum->syntax #f body all-loc) + body)] [p-name (object-name port)] [name (if (path? p-name) - (let-values ([(base name dir?) (split-path p-name)]) - (string->symbol - (path->string (path-replace-suffix name #"")))) - 'page)] + (let-values ([(base name dir?) (split-path p-name)]) + (string->symbol + (path->string (path-replace-suffix name #"")))) + 'page)] [tag-src (lambda (v) (if stx? - (datum->syntax - #f v (vector src line col pos - (- (or (syntax-position modpath) (add1 pos)) - pos))) - v))] - ;; Since there are users that wrap with #%module-begin in their reader - ;; or wrapper1 functions, we need to avoid double-wrapping. Having to - ;; do this for #lang readers should be considered deprecated, and - ;; hopefully one day we'll move to just doing it unilaterally. + (datum->syntax + #f v (vector src line col pos + (- (or (syntax-position modpath) + (add1 pos)) + pos))) + v))] + ;; Since there are users that wrap with #%module-begin in their + ;; reader or wrapper1 functions, we need to avoid double-wrapping. + ;; Having to do this for #lang readers should be considered + ;; deprecated, and hopefully one day we'll move to just doing it + ;; unilaterally. [wrapped-body (wrap-#%module-begin body stx?)] [r `(,(tag-src 'module) ,(tag-src name) ,lang ,wrapped-body)]) (if stx? (datum->syntax #f r all-loc) r))) @@ -202,18 +207,17 @@ (define (wrap lang port read modpath src line col pos) (wrap-internal lang port read #f #f #f modpath src line col pos)) - (define (make-meta-reader self-sym module-path-desc spec->module-path - convert-read - convert-read-syntax - convert-get-info - #:read-spec [read-spec - (lambda (in) - (let ([spec (regexp-try-match #px"^[ \t]+(.*?)(?=\\s|$)" in)]) - (and spec - (let ([s (cadr spec)]) - (if (equal? s "") - #f - s)))))]) + (define (make-meta-reader + self-sym module-path-desc spec->module-path + convert-read + convert-read-syntax + convert-get-info + #:read-spec + [read-spec + (lambda (in) + (let ([spec (regexp-try-match #px"^[ \t]+(.*?)(?=\\s|$)" in)]) + (and spec (let ([s (cadr spec)]) + (if (equal? s "") #f s)))))]) (define (get in export-sym src line col pos mk-fail-thunk) (define (bad str eof?) ((if eof? raise-read-eof-error raise-read-error) @@ -224,17 +228,20 @@ (and pos pos2 (- pos2 pos))))) (define spec (read-spec in)) (if (not spec) - (bad #f (eof-object? (peek-byte in))) - (let ([parsed-spec (spec->module-path spec)]) - (if parsed-spec - (begin ((current-reader-guard) parsed-spec) - (dynamic-require parsed-spec export-sym (mk-fail-thunk spec))) - (bad spec #f))))) + (bad #f (eof-object? (peek-byte in))) + (let ([parsed-spec (spec->module-path spec)]) + (if parsed-spec + (begin ((current-reader-guard) parsed-spec) + (dynamic-require parsed-spec export-sym + (mk-fail-thunk spec))) + (bad spec #f))))) (define (-get-info inp mod line col pos) (let ([r (get inp 'get-info (object-name inp) line col pos - (lambda (spec) (lambda () (lambda (inp mod line col pos) - (lambda (tag defval) defval)))))]) + (lambda (spec) + (lambda () + (lambda (inp mod line col pos) + (lambda (tag defval) defval)))))]) (convert-get-info (r inp mod line col pos)))) (define (read-fn in read-sym args src mod line col pos convert) @@ -245,14 +252,17 @@ self-sym spec))))]) (let ([r (convert r)]) - (if (and (procedure? r) (procedure-arity-includes? r (+ 5 (length args)))) - (apply r (append args (list in mod line col pos))) - (apply r (append args (list in))))))) - + (if (and (procedure? r) + (procedure-arity-includes? r (+ 5 (length args)))) + (apply r (append args (list in mod line col pos))) + (apply r (append args (list in))))))) + (define (-read inp mod line col pos) - (read-fn inp 'read null (object-name inp) mod line col pos convert-read)) - + (read-fn inp 'read null (object-name inp) mod line col pos + convert-read)) + (define (-read-syntax src inp mod line col pos) - (read-fn inp 'read-syntax (list src) src mod line col pos convert-read-syntax)) + (read-fn inp 'read-syntax (list src) src mod line col pos + convert-read-syntax)) (values -read -read-syntax -get-info))) diff --git a/collects/syntax/scribblings/module-reader.scrbl b/collects/syntax/scribblings/module-reader.scrbl index 3b7f2c91a9..695cc879f8 100644 --- a/collects/syntax/scribblings/module-reader.scrbl +++ b/collects/syntax/scribblings/module-reader.scrbl @@ -290,7 +290,7 @@ are meant to be exported directly.} @emph{This function is deprecated; the @schememodname[syntax/module-reader] language can be adapted using the -various keywords to arbitrary readers, and please use it instead.} +various keywords to arbitrary readers; please use it instead.} Repeatedly calls @scheme[read] on @scheme[in] until an end of file, collecting the results in order into @scheme[_lst], and derives a