From e260aef95891e829d9271c43664c0e9f3b3120f7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 11 Oct 2018 20:31:59 -0600 Subject: [PATCH] cs: fix more printer problems exposed by "print.rktl" tests --- racket/src/cs/rumble/error.ss | 48 +++++++++++++++-------------- racket/src/cs/rumble/object-name.ss | 9 ++++-- racket/src/cs/rumble/struct.ss | 4 +++ racket/src/io/demo.rkt | 12 ++++++-- racket/src/io/print/graph.rkt | 3 +- racket/src/io/print/list.rkt | 15 ++++++--- racket/src/io/print/main.rkt | 9 ++++-- 7 files changed, 65 insertions(+), 35 deletions(-) diff --git a/racket/src/cs/rumble/error.ss b/racket/src/cs/rumble/error.ss index 5af2ebf20d..48e6e2abe5 100644 --- a/racket/src/cs/rumble/error.ss +++ b/racket/src/cs/rumble/error.ss @@ -570,29 +570,31 @@ (when (or (continuation-condition? v) (and (exn? v) (not (exn:fail:user? v)))) - (eprintf "\n context...:") - (let loop ([l (traces->context - (if (exn? v) - (continuation-mark-set-traces (exn-continuation-marks v)) - (list (continuation->trace (condition-continuation v)))))] - [n (|#%app| error-print-context-length)]) - (unless (or (null? l) (zero? n)) - (let* ([p (car l)] - [s (cdr p)]) - (cond - [(and s - (srcloc-line s) - (srcloc-column s)) - (eprintf "\n ~a:~a:~a" (srcloc-source s) (srcloc-line s) (srcloc-column s)) - (when (car p) - (eprintf ": ~a" (car p)))] - [(and s (srcloc-position s)) - (eprintf "\n ~a::~a" (srcloc-source s) (srcloc-position s)) - (when (car p) - (eprintf ": ~a" (car p)))] - [(car p) - (eprintf "\n ~a" (car p))])) - (loop (cdr l) (sub1 n))))) + (let ([n (|#%app| error-print-context-length)]) + (unless (zero? n) + (eprintf "\n context...:") + (let loop ([l (traces->context + (if (exn? v) + (continuation-mark-set-traces (exn-continuation-marks v)) + (list (continuation->trace (condition-continuation v)))))] + [n n]) + (unless (or (null? l) (zero? n)) + (let* ([p (car l)] + [s (cdr p)]) + (cond + [(and s + (srcloc-line s) + (srcloc-column s)) + (eprintf "\n ~a:~a:~a" (srcloc-source s) (srcloc-line s) (srcloc-column s)) + (when (car p) + (eprintf ": ~a" (car p)))] + [(and s (srcloc-position s)) + (eprintf "\n ~a::~a" (srcloc-source s) (srcloc-position s)) + (when (car p) + (eprintf ": ~a" (car p)))] + [(car p) + (eprintf "\n ~a" (car p))])) + (loop (cdr l) (sub1 n))))))) (eprintf "\n")) (define eprintf diff --git a/racket/src/cs/rumble/object-name.ss b/racket/src/cs/rumble/object-name.ss index a8bef29e52..4615a9ea3f 100644 --- a/racket/src/cs/rumble/object-name.ss +++ b/racket/src/cs/rumble/object-name.ss @@ -56,7 +56,10 @@ (define (struct-object-name v) (let ([rtd (record-rtd v)]) (and - ;; Having an entry in `rtd-props` is a sign that - ;; this structure type was created with `make-struct-type`: - (with-global-lock* (hashtable-contains? rtd-props rtd)) + ;; Having an entry in `rtd-props` is a sign that this structure + ;; type was created with `make-struct-type`, or it could be a + ;; prefab structure type + (with-global-lock* + (or (hashtable-contains? rtd-props rtd) + (getprop (record-type-uid rtd) 'prefab-key+count #f))) (object-name (record-rtd v))))) diff --git a/racket/src/cs/rumble/struct.ss b/racket/src/cs/rumble/struct.ss index 2e06a4d68b..db4e21a398 100644 --- a/racket/src/cs/rumble/struct.ss +++ b/racket/src/cs/rumble/struct.ss @@ -1150,6 +1150,7 @@ ... (define dummy (begin + (register-struct-named! struct:name) (register-struct-constructor! name) (register-struct-field-accessor! name-field struct:name field-index) ... (record-type-equal-procedure struct:name default-struct-equal?) @@ -1166,3 +1167,6 @@ #'(begin (struct name . rest) (define make-name name)))]))) + +(define (register-struct-named! rtd) + (with-global-lock* (hashtable-set! rtd-props rtd '()))) diff --git a/racket/src/io/demo.rkt b/racket/src/io/demo.rkt index 97fb664071..4327c5bfcf 100644 --- a/racket/src/io/demo.rkt +++ b/racket/src/io/demo.rkt @@ -604,12 +604,14 @@ (let ([b (vector #f #f)]) (struct p (x y) #:transparent) + (struct c (x y) #:prefab) (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 (mcons 3 4)) "(cons 1 (mcons 3 4))") + (print-test (cons 1 (cons 2 (mcons 3 4))) "(list* 1 2 (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)") @@ -620,7 +622,13 @@ (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)") - ) + (print-test (arity-at-least 1) "(arity-at-least 1)") + (let ([v (make-placeholder #f)]) + (placeholder-set! v (list (p 1 2) v)) + (print-test (make-reader-graph v) "#0=(list (p 1 2) #0#)")) + (let ([v (make-placeholder #f)]) + (placeholder-set! v (c (p 1 2) v)) + (print-test (make-reader-graph v) "#0=(c (p 1 2) #0#)"))) (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 0f1177f518..4addbdac24 100644 --- a/racket/src/io/print/graph.rkt +++ b/racket/src/io/print/graph.rkt @@ -177,7 +177,8 @@ [(or (eq? mode PRINT-MODE/QUOTED) (eq? mode PRINT-MODE/UNQUOTED)) (define e-unquoted? (build-graph e mode)) - (unless (eq? print-quotable 'always) + (unless (or (eq? print-quotable 'always) + (eq? print-quotable 'self)) (set! unquoted? (or e-unquoted? unquoted?)))] [else (build-graph e mode)])))) (checking! v) diff --git a/racket/src/io/print/list.rkt b/racket/src/io/print/list.rkt index f4e7657d5f..8c0283a9d1 100644 --- a/racket/src/io/print/list.rkt +++ b/racket/src/io/print/list.rkt @@ -44,7 +44,9 @@ [(eq? mode PRINT-MODE/UNQUOTED) (let ([max-length (if unquoted-pairs? - (write-string/max "(cons" o max-length) + (if (multiple-pairs? v graph) + (write-string/max "(list*" o max-length) + (write-string/max "(cons" o max-length)) (write-string/max (or alt-list-constructor "(list") o max-length))]) (cond [(null? v) max-length] @@ -60,7 +62,6 @@ (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)))] @@ -78,12 +79,18 @@ (define (uninterrupted-list? v graph) (and (list? v) - (let loop ([v v]) + (let loop ([v (cdr v)]) (cond [(null? v) #t] [(non-graph? (hash-ref graph v #f)) (loop (cdr v))] - [else #f])))) + [else + #f])))) + +(define (multiple-pairs? v graph) + (define d (cdr v)) + (and (pair? d) + (non-graph? (hash-ref graph d #f)))) (define (non-graph? g) (or (not g) diff --git a/racket/src/io/print/main.rkt b/racket/src/io/print/main.rkt index 75390bd1a7..bd706c6458 100644 --- a/racket/src/io/print/main.rkt +++ b/racket/src/io/print/main.rkt @@ -171,7 +171,9 @@ [max-length (write-string/max gs o max-length)] [max-length (write-string/max "=" o max-length)]) (hash-set! graph v gs) - (p/no-graph who v mode o max-length graph config))]))] + (if (as-constructor? g) + (p/no-graph-no-quote who v mode o max-length graph config) + (p/no-graph who v mode o max-length graph config)))]))] [else (p/no-graph who v mode o max-length graph config)])) @@ -185,7 +187,10 @@ (vector? v) (box? v) (hash? v) - (prefab-struct-key v))) + (prefab-struct-key v) + (and (custom-write? v) + (not (printable-regexp? v)) + (not (eq? 'self (custom-print-quotable-accessor v 'self)))))) ;; Since this value is not marked for constructor mode, ;; transition to quote mode: (let ([max-length (write-string/max "'" o max-length)])