From 76988f2d906e3f3d42a99205043da97cc8b5ea22 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 19 Jun 2007 18:27:34 +0000 Subject: [PATCH] fix the source problem with placeholders svn: r6697 --- collects/scribble/reader.ss | 107 ++++++++++++++++++++++++------- collects/scribble/test-reader.ss | 18 +++--- 2 files changed, 93 insertions(+), 32 deletions(-) diff --git a/collects/scribble/reader.ss b/collects/scribble/reader.ss index 2fba29fd32..55ac567b5a 100644 --- a/collects/scribble/reader.ss +++ b/collects/scribble/reader.ss @@ -45,14 +45,67 @@ (let ([s (make-string n #\space)]) (hash-table-put! t n s) s)))))) + ;; Skips whitespace characters, sensitive to the current readtable's + ;; definition of whitespace; optimizes common spaces when possible + (define/kw skip-whitespace + (let* ([plain-readtables (make-hash-table 'weak)] + [plain-spaces '(#\space #\tab #\newline #\return #\page)] + [plain-spaces-re + (regexp (string-append "^["(apply string plain-spaces)"]*"))]) + (define (skip-plain-spaces port) + ;; hack: according to the specs, this might consume more characters + ;; than needed, but it seems to work fine with a simple * regexp + (regexp-match-positions plain-spaces-re port)) + (define (whitespace? ch rt) + (if rt + (let-values ([(like-ch/sym _1 _2) (readtable-mapping rt ch)]) + ;; if like-ch/sym is whitespace, then ch is whitespace + (and (char? like-ch/sym) (char-whitespace? like-ch/sym))) + ;; `char-whitespace?' is fine for the default readtable + (char-whitespace? ch))) + (define (plain-readtable? rt) + (hash-table-get plain-readtables rt + (lambda () + (let ([plain? (andmap (lambda (ch) (whitespace? ch rt)) + plain-spaces)]) + (hash-table-put! plain-readtables rt #t) + rt)))) + (lambda/kw (#:optional [port (current-input-port)]) + (let* ([rt (current-readtable)] [plain? (plain-readtable? rt)]) + (let loop () + (when plain? (skip-plain-spaces port)) + (let ([ch (peek-char port)]) + (unless (eof-object? ch) + (when (whitespace? ch rt) (read-char port) (loop))))))))) + + ;; Wrappers for placeholders, to keep source information for them. (MzScheme + ;; provides nothing for them -- there's not even a predicate. Hopefully, if + ;; something is added it will use the same name, so there's a compiler error + ;; here and this code is adapted.) + (define-struct placeholder (p loc)) + (define (syntax/placeholder-line sp) + (if (placeholder? sp) (cadr (placeholder-loc sp)) (syntax-line sp))) + (define (syntax/placeholder-column sp) + (if (placeholder? sp) (caddr (placeholder-loc sp)) (syntax-column sp))) + (define (syntax/placeholder-strip sp) + (if (placeholder? sp) (placeholder-p sp) sp)) + (define (datum->syntax-object/placeholder sp d) + (if (placeholder? sp) + ;; using the syntax for lexical context is not possible for placeholders, + ;; but we don't need it since we're a reader + (datum->syntax-object #f d (placeholder-loc sp)) + (datum->syntax-object sp d sp))) + (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]) - (let loop () - (let ([x (read source-name inp)]) - (if (special-comment? x) (loop) x)))))) + (if plain? + (read source-name inp) ; read-syntax never returns special comments + (let loop () + (let ([x (read source-name inp)]) + (if (special-comment? x) (loop) x))))))) (define (cur-pos) (let-values ([(line col pos) (port-next-location inp)]) pos)) @@ -119,7 +172,13 @@ (set-box! level (add1 (unbox level))) (make-stx (car m)))] [(regexp-match-peek-positions sub-start inp) - (read-syntax source-name inp)] ; include comment objs + ;; read the next value, include comment objs, keep source + ;; location manually (see above) + (let ([x (read-syntax/recursive source-name inp)]) + (if (or (syntax? x) (special-comment? x)) + x + (make-placeholder x + (list source-name line col pos (span-from pos)))))] [(regexp-match/fail-without-reading end-of-line inp) => (lambda (m) (if (cadr m) ; backslashes? @@ -137,7 +196,7 @@ (make-stx (car m)))] [(regexp-match/fail-without-reading #rx#"^$" inp) (if eof-ok? #f (read-error "missing `~a'" close))] - [else (read-error "internal error")]))) + [else (read-error "internal error [get-line]")]))) ;; adds stx (new syntax) to the list of stxs, merging it if both are ;; strings, except for newline markers (define (maybe-merge stx stxs) @@ -157,24 +216,27 @@ (cdr stxs))) (cons stx stxs))) (define (add-indents stxs) - (if (or (not (read-insert-indents)) - (null? stxs) - (not (andmap (lambda (s) (and (syntax-line s) (syntax-column s))) - stxs))) + (unless (andmap (lambda (x) + (or (and (syntax? x) (syntax-line x) (syntax-column x)) + (placeholder? x))) + stxs) + (read-error "internal error [add-indents] ~s" stxs)) + (if (or (not (read-insert-indents)) (null? stxs)) stxs - (let ([mincol (apply min (map syntax-column stxs))]) + (let ([mincol (apply min (map syntax/placeholder-column stxs))]) (let loop ([curline line-num] [stxs stxs] [r '()]) (if (null? stxs) (reverse! r) - (let* ([stx (car stxs)] [line (syntax-line stx)]) + (let* ([stx (car stxs)] [line (syntax/placeholder-line stx)]) (loop line (cdr stxs) - (if (and (< curline line) (< mincol (syntax-column stx))) - (list* stx - (datum->syntax-object stx - (make-spaces (- (syntax-column stx) mincol)) - stx) - r) - (cons stx r))))))))) + (let ([stxcol (syntax/placeholder-column stx)] + [stx* (syntax/placeholder-strip stx)]) + (if (and (< curline line) (< mincol stxcol)) + (list* stx* + (datum->syntax-object/placeholder stx* + (make-spaces (- stxcol mincol))) + r) + (cons stx* r)))))))))) (define (get-lines inside?) (define get (cond [inside? @@ -229,9 +291,10 @@ [#"," unquote] [#",@" unquote-splicing])) => cadr] - [else (error "internal error")])) + [else (read-error + "internal error [rpfxs]")])) r)))] - [else (error "internal error")])))] + [else (read-error "internal error [rpfxs]")])))] [else '()])) (define (get-command) ; #f means no command (let-values ([(line col pos) (port-next-location inp)]) @@ -266,7 +329,7 @@ cmd ; no attrs/lines => simple expression (no parens) ;; impossible: either we saw []s or {}s, or we read a ;; scheme expression - (error "internal error"))] + (read-error "internal error [dispatcher]"))] [stx (let loop ([pfx pfx] [stx stx]) (if (null? pfx) stx (loop (cdr pfx) (list (car pfx) stx))))]) @@ -281,7 +344,7 @@ (define cmd-readtable (make-readtable at-readtable #\| 'terminating-macro (lambda (char inp source-name line-num col-num position) - (let ([m (regexp-match #rx#"^([^|]*)\\|" inp)]) + (let ([m (regexp-match/fail-without-reading #rx#"^([^|]*)\\|" inp)]) (unless m (raise-read-error "unbalanced `|'" source-name line-num col-num position #f)) diff --git a/collects/scribble/test-reader.ss b/collects/scribble/test-reader.ss index 7d99350d75..b9a476a09f 100755 --- a/collects/scribble/test-reader.ss +++ b/collects/scribble/test-reader.ss @@ -28,22 +28,22 @@ exec mzscheme -r "$0" "$@" [@'foo{bar} '(foo "bar")] - ,' + ,@'( ; <- avoid the above openning quasiquote for these + [@'`,foo{bar} '`,(foo "bar")] - ,' ; <- to avoid the above openning quasiquote [@'`,@,foo{bar} '`,@,(foo "bar")] - ,' [@`',@foo{blah} `@',@foo{blah}] - ,' [@`',@foo{blah} `',@@foo{blah}] + ) + [@(lambda (x) x){blah} ((lambda (x) x) "blah")] @@ -102,13 +102,11 @@ exec mzscheme -r "$0" "$@" [@foo{a @bar{b} c} (foo "a " (bar "b") " c")] - ;; !!! to be fixed + [@foo{a @bar c} + (foo "a " bar " c")] - ;; [@foo{a @bar c} - ;; (foo "a " bar " c")] - - ;; [@foo{a @(bar 2) c} - ;; (foo "a " (bar 2) " c")] + [@foo{a @(bar 2) c} + (foo "a " (bar 2) " c")] ))