From eb586b1dddf423c0abbcdbcc8f6d142574019ba1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Sat, 7 Jan 2017 00:14:56 +0100 Subject: [PATCH] =?UTF-8?q?Bugfix:=20use=20(code:comment=20(unsyntax=20?= =?UTF-8?q?=E2=80=A6))=20in=20@chunk,=20and=20(code:comment=20(UNSYNTAX=20?= =?UTF-8?q?=E2=80=A6))=20in=20@CHUNK?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- comment-reader.rkt | 43 +++++++++++++++++++++++----------------- lang/meta-first-line.rkt | 42 +++++++++++++++++++++++++++------------ private/lp.rkt | 16 +++++++++++---- 3 files changed, 66 insertions(+), 35 deletions(-) diff --git a/comment-reader.rkt b/comment-reader.rkt index 67e53c0b..931856d5 100644 --- a/comment-reader.rkt +++ b/comment-reader.rkt @@ -27,18 +27,21 @@ 'unsyntax))) (define (make-comment-readtable #:readtable [rt (current-readtable)] - #:comment-wrapper [comment-wrapper 'code:comment]) + #:comment-wrapper [comment-wrapper 'code:comment] + #:unsyntax [unsyntax? #t]) (make-readtable rt #\; 'terminating-macro (case-lambda [(char port) (do-comment port (lambda () (read/recursive port #\@)) - #:comment-wrapper comment-wrapper)] + #:comment-wrapper comment-wrapper + #:unsyntax unsyntax?)] [(char port src line col pos) (let ([v (do-comment port (lambda () (read-syntax/recursive src port #\@)) - #:comment-wrapper comment-wrapper)]) + #:comment-wrapper comment-wrapper + #:unsyntax unsyntax?)]) (let-values ([(eline ecol epos) (port-next-location port)]) (datum->syntax #f @@ -47,7 +50,8 @@ (define (do-comment port recur - #:comment-wrapper [comment-wrapper 'code:comment]) + #:comment-wrapper [comment-wrapper 'code:comment] + #:unsyntax [unsyntax? #t]) #;(let loop () (when (equal? #\; (peek-char port)) (read-char port) @@ -55,20 +59,23 @@ #;(when (equal? #\space (peek-char port)) (read-char port)) (define comment-text - `(,(unsyntaxer) - (t - ,@(append-strings - (let loop () - (let ([c (read-char port)]) - (cond - [(or (eof-object? c) - (char=? c #\newline)) - null] - [(char=? c #\@) - (cons (recur) (loop))] - [else - (cons (string c) - (loop))]))))))) + `(t + ,@(append-strings + (let loop () + (let ([c (read-char port)]) + (cond + [(or (eof-object? c) + (char=? c #\newline)) + null] + [(char=? c #\@) + (cons (recur) (loop))] + [else + (cons (string c) + (loop))])))))) + (define comment-unsyntax + (if unsyntax? + `(,(unsyntaxer) ,comment-text) + comment-text)) `(,comment-wrapper ,comment-text)) (define (append-strings l) diff --git a/lang/meta-first-line.rkt b/lang/meta-first-line.rkt index 5ca9b697..b0cc4a0c 100644 --- a/lang/meta-first-line.rkt +++ b/lang/meta-first-line.rkt @@ -18,7 +18,8 @@ #:datum-readtable (λ (rt) (make-comment-readtable #:readtable rt - #:comment-wrapper '#%comment)))) + #:comment-wrapper '#%comment + #:unsyntax #f)))) (define (meta-read-inside in . args) @@ -128,9 +129,13 @@ (-> syntax? (or/c #f comments-after/c)) (syntax-property stx 'comments-after)) - (define (restore-#%comment stx - #:replace-with (replace-with #f) - #:scope [scope (datum->syntax #f 'zero)]) + (define/contract (restore-#%comment stx + #:replace-with (replace-with #f) + #:scope [scope (datum->syntax #f 'zero)]) + (->* (syntax?) + (#:replace-with [or/c #f syntax? (-> syntax? syntax?)] + #:scope identifier?) + syntax?) (define (erase-props stx) (define stx* (if (syntax-property stx 'first-comments) (syntax-property stx 'first-comments #f) @@ -144,15 +149,26 @@ (syntax-parse commentᵢ #:datum-literals (#%comment) [({~and c #%comment} . rest) - (datum->syntax commentᵢ - `(,(datum->syntax #'c replace-with #'c #'c) - . ,((make-syntax-delta-introducer - scope - (datum->syntax #f 'zero)) - #'rest - 'add)) - commentᵢ - commentᵢ)] + (if (syntax? replace-with) + (datum->syntax commentᵢ + `(,(datum->syntax #'c replace-with #'c #'c) + . ,((make-syntax-delta-introducer + scope + (datum->syntax #f 'zero)) + #'rest + 'add)) + commentᵢ + commentᵢ) + (replace-with + (datum->syntax commentᵢ + `(,#'c + . ,((make-syntax-delta-introducer + scope + (datum->syntax #f 'zero)) + #'rest + 'add)) + commentᵢ + commentᵢ)))] [_ commentᵢ])) (define (replace-in-after comments) diff --git a/private/lp.rkt b/private/lp.rkt index 390bbc91..349875e9 100644 --- a/private/lp.rkt +++ b/private/lp.rkt @@ -128,7 +128,7 @@ ;; TODO: hash tables [else e])) -(define-for-syntax ((make-chunk-display racketblock) stx) +(define-for-syntax ((make-chunk-display racketblock unsyntax-id) stx) (syntax-parse stx ;; no need for more error checking, using chunk for the code will do that [(_ (original-before-expr ...) @@ -159,7 +159,15 @@ ;; and stashed away by read-syntax in "../lang/meta-first-line.rkt" (define/with-syntax (_ . expr*+comments) (restore-#%comment #'(original-before-expr ... expr ...) - #:replace-with #'code:comment + #:replace-with + (λ (stx) + (syntax-parse stx + #:datum-literals (#%comment) + [({~and #%comment com} . rest) + #:with c-c (datum->syntax #'com 'code:comment #'com #'com) + (datum->syntax stx `(,#'c-c (,unsyntax-id . ,#'rest)) stx stx)] + [other + #'other])) #:scope #'original-name)) ;; The (list) here could be important, to avoid the code being ;; executed multiple times in weird ways, when pre-expanding. @@ -256,8 +264,8 @@ (define-syntax chunk-code (make-chunk-code #t)) (define-syntax CHUNK-code (make-chunk-code #f)) -(define-syntax chunk-display (make-chunk-display #'racketblock)) -(define-syntax CHUNK-display (make-chunk-display #'RACKETBLOCK)) +(define-syntax chunk-display (make-chunk-display #'racketblock #'unsyntax)) +(define-syntax CHUNK-display (make-chunk-display #'RACKETBLOCK #'UNSYNTAX)) (define-syntax chunk (make-chunk #'chunk-code #'chunk-display)) (define-syntax CHUNK (make-chunk #'CHUNK-code #'CHUNK-display))