suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cs: fix more printer problems exposed by "print.rktl" tests

Browse Source
This commit is contained in:
Matthew Flatt 2018-10-11 20:31:59 -06:00
parent dbb74b5814
commit e260aef958
7 changed files with 65 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
racket/src/cs/rumble/error.ss
View File

@ -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

9
racket/src/cs/rumble/object-name.ss
View File

@ -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)))))

4
racket/src/cs/rumble/struct.ss
View File

@ -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 '())))

12
racket/src/io/demo.rkt
View File

@ -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)

3
racket/src/io/print/graph.rkt
View File

@ -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)

15
racket/src/io/print/list.rkt
View File

@ -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)

9
racket/src/io/print/main.rkt
View File

@ -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)])