(loop (fix:- index 1))))))
\f
(define (print-vector vector context)
- (let ((printer (named-vector-with-unparser? vector)))
- (if printer
- (call-print-method printer vector context)
- (limit-print-depth context
- (lambda (context*)
- (let ((end (vector-length vector)))
- (if (fix:> end 0)
- (begin
- (*print-string "#(" context*)
- (print-object (safe-vector-ref vector 0) context*)
- (let loop ((index 1))
- (if (fix:< index end)
- (if (let ((limit
- (context-list-breadth-limit context*)))
- (and limit
- (>= index limit)))
- (*print-string " ...)" context*)
- (begin
- (*print-char #\space context*)
- (print-object (safe-vector-ref vector index)
- context*)
- (loop (fix:+ index 1))))))
- (*print-char #\) context*))
- (*print-string "#()" context*))))))))
+ (limit-print-depth context
+ (lambda (context*)
+ (let ((end (vector-length vector)))
+ (if (fix:> end 0)
+ (begin
+ (*print-string "#(" context*)
+ (print-object (safe-vector-ref vector 0) context*)
+ (let loop ((index 1))
+ (if (fix:< index end)
+ (if (let ((limit
+ (context-list-breadth-limit context*)))
+ (and limit
+ (>= index limit)))
+ (*print-string " ...)" context*)
+ (begin
+ (*print-char #\space context*)
+ (print-object (safe-vector-ref vector index)
+ context*)
+ (loop (fix:+ index 1))))))
+ (*print-char #\) context*))
+ (*print-string "#()" context*))))))
(define (safe-vector-ref vector index)
(if (with-absolutely-no-interrupts
=> (lambda (prefix) (print-prefix-pair prefix pair context)))
((and (get-param:print-streams?) (stream-pair? pair))
(print-stream-pair pair context))
- ((named-list-with-unparser? pair)
- => (lambda (printer) (call-print-method printer pair context)))
(else
(print-list pair context))))
(define structure-type/field-names)
(define structure-type/field-indexes)
(define structure-type/default-inits)
-(define structure-type/unparser-method)
(define structure-type/tag)
(define structure-type/length)
(add-boot-init!
(record-accessor rtd:structure-type 'field-indexes))
(set! structure-type/default-inits
(record-accessor rtd:structure-type 'default-inits))
- (set! structure-type/unparser-method
- (record-accessor rtd:structure-type 'unparser-method))
(set! structure-type/tag
(record-accessor rtd:structure-type 'tag))
(set! structure-type/length
(and (structure-type? type)
type))))
-;;; Starting here can be removed after 9.3 release...
-
-(define (named-list-with-unparser? object)
- (and (named-list? object)
- (tag->unparser-method (car object))))
-
-(define (named-vector-with-unparser? object)
- (and (named-vector? object)
- (tag->unparser-method (vector-ref object 0))))
-
-(define (tag->unparser-method tag)
- (structure-type/unparser-method (tag->structure-type tag)))
-
-;;; ...and ending here.
-
(define-pp-describer named-list?
(lambda (pair)
(let ((type (tag->structure-type (car pair))))
(export (runtime pathname)
record-type-proxy:host
record-type-proxy:pathname)
- (export (runtime printer)
- named-list-with-unparser?
- named-vector-with-unparser?)
(initialization (initialize-package!)))
(define-package (runtime reference-trap)