diff --git a/pkgs/racket-test-core/tests/racket/print.rktl b/pkgs/racket-test-core/tests/racket/print.rktl index 896226a308..b9fb7e03cd 100644 --- a/pkgs/racket-test-core/tests/racket/print.rktl +++ b/pkgs/racket-test-core/tests/racket/print.rktl @@ -139,6 +139,8 @@ (ptest "'(#)" (list add1)) (ptest "'#(#)" (vector add1)) + (ptest "(arity-at-least 1)" (arity-at-least 1)) + (ptest "#0='(#0#)" (read (open-input-string "#0=(#0#)"))) (ptest "#0='(#0# #0#)" (read (open-input-string "#0=(#0# #0#)"))) (ptest "#0='(#0# . #0#)" (read (open-input-string "#0=(#0# . #0#)"))) @@ -261,12 +263,12 @@ ;; path value in compiled code => path appears in .zo format: (let ([o (open-output-string)]) (write (compile p) o) - (test #t regexp-match? (regexp-quote (path->bytes (current-directory))) (get-output-string o))) + (test #t 'path-in-code?1 (regexp-match? (regexp-quote (path->bytes (current-directory))) (get-output-string o)))) ;; `current-write-relative-directory' set => path not in .zo format: (let ([o (open-output-string)]) (parameterize ([current-write-relative-directory (current-directory)]) (write (compile p) o) - (test #f regexp-match? (regexp-quote (path->bytes (current-directory))) (get-output-string o)))) + (test #f 'path-in-code?2 (regexp-match? (regexp-quote (path->bytes (current-directory))) (get-output-string o))))) ;; try all possible supers that have at least two path elements: (let loop ([super (current-directory)]) (let ([super (let-values ([(base name dir?) (split-path super)]) @@ -279,12 +281,12 @@ (let ([o (open-output-string)]) (parameterize ([current-write-relative-directory (current-directory)]) (write (compile (build-path super "other")) o) - (test #t regexp-match? (regexp-quote (path->bytes super)) (get-output-string o)))) + (test #t 'path-in-code?3 (regexp-match? (regexp-quote (path->bytes super)) (get-output-string o))))) (let ([o (open-output-string)]) (parameterize ([current-write-relative-directory (cons (current-directory) super)]) (write (compile (build-path super "other")) o) - (test #f regexp-match? (regexp-quote (path->bytes super)) (get-output-string o)))) + (test #f 'path-in-code?4 (regexp-match? (regexp-quote (path->bytes super)) (get-output-string o))))) (loop super))))) ;; ---------------------------------------- diff --git a/racket/src/io/demo.rkt b/racket/src/io/demo.rkt index 82d5c2cb7e..97fb664071 100644 --- a/racket/src/io/demo.rkt +++ b/racket/src/io/demo.rkt @@ -279,9 +279,9 @@ void))) (port-count-lines! specialist) -(test '(special #f #f #f #f) (read-byte-or-special specialist)) +(test '(special #f 1 0 1) (read-byte-or-special specialist)) (test '#&(special src 1 1 2) (read-byte-or-special specialist box 'src)) -(test '(special #f #f #f #f) (peek-byte-or-special specialist)) +(test '(special #f 1 2 3) (peek-byte-or-special specialist)) (test '#&(special src 1 2 3) (peek-byte-or-special specialist 0 #f box 'src)) (test 'special (peek-byte-or-special specialist 0 #f 'special 'src)) (test 'special (peek-char-or-special specialist 0 'special 'src)) @@ -603,13 +603,24 @@ (print-test b "#0='#�#")) (let ([b (vector #f #f)]) + (struct p (x y) #:transparent) (vector-set! b 0 b) (vector-set! b 1 b) (print-test b "#0='#(#0# #0#)") (print-test '(1) "'(1)") (print-test (cons 1 (cons 2 3)) "'(1 2 . 3)") (print-test (cons 1 (cons 2 (mcons 3 4))) "(cons 1 (cons 2 (mcons 3 4)))") - (print-test (cons 1 (cons (mcons 3 4) null)) "(list 1 (mcons 3 4))")) + (print-test (cons 1 (cons (mcons 3 4) null)) "(list 1 (mcons 3 4))") + (print-test '('a) "'('a)") + (print-test '(4 . 'a) "'(4 . 'a)") + (print-test '(4 unquote a) "'(4 . ,a)") + (print-test '(4 unquote @a) "'(4 . , @a)") + (print-test '#(4 unquote a) "'#(4 unquote a)") + (print-test '((quote a b)) "'((quote a b))") + (print-test (p 1 2) "(p 1 2)") + (print-test (box (p 1 2)) "(box (p 1 2))") + (print-test (hasheq 1 (p 1 2) 2 'other) "(hasheq 1 (p 1 2) 2 'other)") + ) (let ([b (make-hash)]) (hash-set! b 'self b) diff --git a/racket/src/io/print/graph.rkt b/racket/src/io/print/graph.rkt index 6d9f4dd161..0f1177f518 100644 --- a/racket/src/io/print/graph.rkt +++ b/racket/src/io/print/graph.rkt @@ -58,8 +58,7 @@ [(and (struct? v) (config-get config print-struct)) (and (not print-graph?) - (or (not (eq? mode PRINT-MODE/UNQUOTED)) - (prefab-struct-key v)) ; can quote a prefab in `print` mode + (prefab-struct-key v) ; can quote a prefab in `print` mode (quick-no-graph? (struct->vector v) (sub1 fuel)))] [else fuel]))) diff --git a/racket/src/io/print/list.rkt b/racket/src/io/print/list.rkt index e94a92e6ca..f4e7657d5f 100644 --- a/racket/src/io/print/list.rkt +++ b/racket/src/io/print/list.rkt @@ -1,7 +1,10 @@ #lang racket/base (require "write-with-max.rkt" "mode.rkt" - "graph.rkt") + "graph.rkt" + "config.rkt" + "parameter.rkt" + "symbol.rkt") (provide print-list) @@ -10,37 +13,68 @@ (and (eq? mode PRINT-MODE/UNQUOTED) (not alt-list-constructor) (not (uninterrupted-list? v graph)))) - (let ([max-length + (define (abbreviation v) + (and (eq? mode PRINT-MODE/QUOTED) + (pair? v) + (pair? (cdr v)) + (null? (cddr v)) + (not alt-list-constructor) + (config-get config print-reader-abbreviations) + (let ([starts-@? (lambda (v) + (and (symbol? v) + (let ([s (symbol->print-string v #:config config)]) + (char=? #\@ (string-ref s 0)))))]) + (case (car v) + [(quote) "'"] + [(quasiquote) "`"] + [(unquote) (if (starts-@? (cadr v)) ", " ",")] + [(unquote-splicing) ",@"] + [(syntax) "#'"] + [(quasisyntax) "#`"] + [(unsyntax) (if (starts-@? (cadr v)) "#, " "#,")] + [(unsyntax-splicing) "#,@"] + [else #f])))) + (cond + [(abbreviation v) + => (lambda (prefix) + (p who (cadr v) mode o (write-string/max prefix o max-length) graph config))] + [else + (let ([max-length + (cond + [(eq? mode PRINT-MODE/UNQUOTED) + (let ([max-length + (if unquoted-pairs? + (write-string/max "(cons" o max-length) + (write-string/max (or alt-list-constructor "(list") o max-length))]) + (cond + [(null? v) max-length] + [else (write-string/max " " o max-length)]))] + [else (write-string/max (or alt-list-prefix "(") o max-length)])]) + (let loop ([v v] [max-length max-length]) (cond - [(eq? mode PRINT-MODE/UNQUOTED) - (let ([max-length - (if unquoted-pairs? - (write-string/max "(cons" o max-length) - (write-string/max (or alt-list-constructor "(list") o max-length))]) - (cond - [(null? v) max-length] - [else (write-string/max " " o max-length)]))] - [else (write-string/max (or alt-list-prefix "(") o max-length)])]) - (let loop ([v v] [max-length max-length]) - (cond - [(eq? max-length 'full) 'full] - [(null? v) (write-string/max ")" o max-length)] - [(and (null? (cdr v)) - (not unquoted-pairs?)) - (let ([max-length (p who (car v) mode o max-length graph config)]) - (write-string/max ")" o max-length))] - [(and (pair? (cdr v)) - (or (not graph) (non-graph? (hash-ref graph (cdr v) #f))) - (not unquoted-pairs?)) - (let ([max-length (p who (car v) mode o max-length graph config)]) - (loop (cdr v) (write-string/max " " o max-length)))] - [else - (let* ([max-length (p who (car v) mode o max-length graph config)] - [max-length (if unquoted-pairs? - (write-string/max " " o max-length) - (write-string/max " . " o max-length))] - [max-length (p who (cdr v) mode o max-length graph config)]) - (write-string/max ")" o max-length))])))) + [(eq? max-length 'full) 'full] + [(null? v) (write-string/max ")" o max-length)] + [(and (null? (cdr v)) + (not unquoted-pairs?)) + (let ([max-length (p who (car v) mode o max-length graph config)]) + (write-string/max ")" o max-length))] + [(and (pair? (cdr v)) + (or (not graph) (non-graph? (hash-ref graph (cdr v) #f))) + (not unquoted-pairs?) + (not (abbreviation (cdr v)))) + (let ([max-length (p who (car v) mode o max-length graph config)]) + (loop (cdr v) (write-string/max " " o max-length)))] + [(abbreviation v) + => (lambda (prefix) + ;; Assume a "." has already printed + (p who (cadr v) mode o (write-string/max prefix o max-length) graph config))] + [else + (let* ([max-length (p who (car v) mode o max-length graph config)] + [max-length (if unquoted-pairs? + (write-string/max " " o max-length) + (write-string/max " . " o max-length))] + [max-length (p who (cdr v) mode o max-length graph config)]) + (write-string/max ")" o max-length))])))])) (define (uninterrupted-list? v graph) (and (list? v) diff --git a/racket/src/io/print/main.rkt b/racket/src/io/print/main.rkt index b9729a993d..75390bd1a7 100644 --- a/racket/src/io/print/main.rkt +++ b/racket/src/io/print/main.rkt @@ -224,9 +224,13 @@ [(eq? mode DISPLAY-MODE) (write-string/max (string v) o max-length)] [else (print-char v o max-length)])] [(not v) - (write-string/max "#f" o max-length)] + (if (config-get config print-boolean-long-form) + (write-string/max "#false" o max-length) + (write-string/max "#f" o max-length))] [(eq? v #t) - (write-string/max "#t" o max-length)] + (if (config-get config print-boolean-long-form) + (write-string/max "#true" o max-length) + (write-string/max "#t" o max-length))] [(pair? v) (print-list p who v mode o max-length graph config #f #f)] [(vector? v) @@ -238,25 +242,40 @@ (define l (for/list ([e (in-fxvector v)]) e)) (print-list p who l mode o max-length graph config "#fx(" "(fxvector")] [(box? v) - (if (config-get config print-box) - (p who (unbox v) mode o (write-string/max "#&" o max-length) graph config) - (write-string/max "#" o max-length))] + (cond + [(config-get config print-box) + (cond + [(eq? mode PRINT-MODE/UNQUOTED) + (let* ([max-length (write-string/max "(box " o max-length)] + [max-length (p who (unbox v) mode o max-length graph config)]) + (write-string/max ")" o max-length))] + [else + (p who (unbox v) mode o (write-string/max "#&" o max-length) graph config)])] + [else + (check-unreadable who config mode v) + (write-string/max "#" o max-length)])] [(hash? v) - (if (and (config-get config print-hash-table) - (not (hash-weak? v))) - (print-hash v o max-length p who mode graph config) - (write-string/max "#" o max-length))] + (cond + [(and (config-get config print-hash-table) + (not (hash-weak? v))) + (cond + [(eq? mode PRINT-MODE/UNQUOTED) + (define l (apply append (hash-map v list #t))) + (define prefix (cond + [(hash-eq? v) "(hasheq"] + [(hash-eqv? v) "(hasheqv"] + [else "(hash"])) + (print-list p who l mode o max-length graph config #f prefix)] + [else + (print-hash v o max-length p who mode graph config)])] + [else + (check-unreadable who config mode v) + (write-string/max "#" o max-length)])] [(and (eq? mode WRITE-MODE) (not (config-get config print-unreadable)) ;; Regexps are a special case: custom writers that produce readable input (not (printable-regexp? v))) - (raise (exn:fail - (string-append (symbol->string who) - ": printing disabled for unreadable value" - "\n value: " - (parameterize ([print-unreadable #t]) - ((error-value->string-handler) v (error-print-width)))) - (current-continuation-marks)))] + (fail-unreadable who v)] [(mpair? v) (print-mlist p who v mode o max-length graph config)] [(custom-write? v) @@ -295,6 +314,22 @@ (print-named "input-port" v mode o max-length)] [(core-output-port? v) (print-named "output-port" v mode o max-length)] + [(unquoted-printing-string? v) + (write-string/max (unquoted-printing-string-value v) o max-length)] [else ;; As a last resort, fall back to the host `format`: (write-string/max (format "~s" v) o max-length)])) + +(define (fail-unreadable who v) + (raise (exn:fail + (string-append (symbol->string who) + ": printing disabled for unreadable value" + "\n value: " + (parameterize ([print-unreadable #t]) + ((error-value->string-handler) v (error-print-width)))) + (current-continuation-marks)))) + +(define (check-unreadable who config mode v) + (when (and (eq? mode WRITE-MODE) + (not (config-get config print-unreadable))) + (fail-unreadable who v)))