diff --git a/collects/scribble/doc.txt b/collects/scribble/doc.txt index 37d0eadd65..a6c1ffd23c 100644 --- a/collects/scribble/doc.txt +++ b/collects/scribble/doc.txt @@ -49,6 +49,11 @@ the at-readtable. You can do this in a single command line: mzscheme -Le reader.ss scribble "(use-at-readtable)" +In addition to `read' and `read-syntax', which are used by #reader, +the "reader.ss" library provides the procedures `read-inside' and +`read-inside-syntax'; these `-inner' variants parse as if inside a +"@{}", and they return a (syntactic) list. + *** Concrete Syntax The *concrete* syntax of @-commands is (informally, more details below): diff --git a/collects/scribble/reader.ss b/collects/scribble/reader.ss index 2824f83588..4a8f819722 100644 --- a/collects/scribble/reader.ss +++ b/collects/scribble/reader.ss @@ -37,7 +37,7 @@ (let ([s (make-string n #\space)]) (hash-table-put! t n s) s)))))) - (define (dispatcher char inp source-name line-num col-num position) + (define ((dispatcher start-inside?) char inp source-name line-num col-num position) (define/kw (next-syntax readtable #:optional plain?) (let ([read (if plain? read-syntax read-syntax/recursive)]) (parameterize ([current-readtable readtable]) @@ -91,7 +91,7 @@ (let loop ([attrs '()]) (let ([a (get-attr)]) (if a (loop (append! (reverse! a) attrs)) (reverse! attrs)))))) - (define ((get-line open open-re close close-re item-re unquote-re level)) + (define ((get-line eof-ok? open open-re close close-re item-re unquote-re level)) (let-values ([(line col pos) (port-next-location inp)]) (define (make-stx sexpr) (datum->syntax-object #f @@ -124,7 +124,9 @@ => (lambda (m) (make-stx (car m)))] [(regexp-match/fail-without-reading #rx#"^$" inp) - (read-error "missing `~a'" close)] + (if eof-ok? + #f + (read-error "missing `~a'" close))] [else (read-error "internal error")]))) ;; adds stx (new syntax) to the list of stxs, merging it if both are ;; strings, except for newline markers @@ -162,9 +164,12 @@ stx) r) (cons stx r))))))))) - (define (get-lines) + (define (get-lines inside?) (define get - (cond [(regexp-match/fail-without-reading open-lines-special inp) + (cond [inside? + (get-line #t "{" open-lines "}" close-lines + line-item bslash-unquote (box 0))] + [(regexp-match/fail-without-reading open-lines-special inp) => (lambda (m) (let* ([open (cadr m)] [close (reverse-bytes open)] @@ -176,13 +181,13 @@ (bytes-append (car pfx/sfx) re (cadr pfx/sfx))))]) - (get-line open (bre open-lines* open-re) + (get-line #f open (bre open-lines* open-re) close (bre close-lines* close-re) (bre line-item* either-re) (bre bslash-unquote* either-re) (box 0))))] [(regexp-match/fail-without-reading open-lines inp) - (get-line "{" open-lines "}" close-lines + (get-line #f "{" open-lines "}" close-lines line-item bslash-unquote (box 0))] [else #f])) (and get (let loop ([lines '()] [more '()]) @@ -228,9 +233,13 @@ #t))] [else (values (next-syntax cmd-readtable) #f)]))) (cond + [start-inside? + (datum->syntax-object #f + (get-lines #t) + (list source-name line-num col-num position (span-from position)))] [(regexp-match/fail-without-reading comment-start inp) (if (regexp-match-peek-positions open-lines inp) - (get-lines) (regexp-match comment-line inp)) + (get-lines #f) (regexp-match comment-line inp)) (make-special-comment #f)] [else (let* ([pfx (get-rprefixes)] @@ -238,7 +247,7 @@ [cmd (let-values ([(cmd bs?) (get-command)]) (set! bars? bs?) cmd)] ; #f means no command [attrs (and (not bars?) (get-attrs))] - [lines (and (not bars?) (get-lines))] + [lines (and (not bars?) (get-lines #f))] [stx (and (or attrs lines) (append (or attrs '()) (or lines '())))] [stx (or (and cmd stx (cons cmd stx)) ; all parts @@ -254,7 +263,7 @@ (list source-name line-num col-num position (span-from position))))])) (define at-readtable - (make-readtable #f cmd-char 'terminating-macro dispatcher)) + (make-readtable #f cmd-char 'terminating-macro (dispatcher #f))) ;; similar to plain Scheme, but with `|' as a terminating macro (define cmd-readtable @@ -282,14 +291,32 @@ (port-count-lines! (current-input-port)) (current-readtable at-readtable)) + (define default-src (gensym)) + (define (src-name src port) + (if (eq? src default-src) + (object-name port) + src)) + (define/kw (*read #:optional [inp (current-input-port)]) (parameterize ([current-readtable at-readtable]) (read inp))) - (define/kw (*read-syntax #:optional src [port (current-input-port)]) + (define/kw (*read-syntax #:optional [src default-src] [port (current-input-port)]) (parameterize ([current-readtable at-readtable]) - (read-syntax (or src (object-name port)) port))) + (read-syntax (src-name src port) port))) - (provide (rename *read read) (rename *read-syntax read-syntax)) + (define/kw (read-inside #:optional [inp (current-input-port)]) + (let-values ([(line col pos) (port-next-location inp)]) + (parameterize ([current-readtable at-readtable]) + (syntax-object->datum + ((dispatcher #t) #f inp (object-name inp) line col pos))))) + + (define/kw (read-inside-syntax #:optional [src default-src] [port (current-input-port)]) + (let-values ([(line col pos) (port-next-location port)]) + (parameterize ([current-readtable at-readtable]) + ((dispatcher #t) #f port (src-name src port) line col pos)))) + + (provide (rename *read read) (rename *read-syntax read-syntax) + read-inside read-inside-syntax) )