:type column)
;; A simple string holding all the text that has been output but not yet
;; printed.
- (buffer (make-string initial-buffer-size) :type simple-string)
+ (buffer (make-string initial-buffer-size) :type (simple-array character (*)))
;; The index into BUFFER where more text should be put.
(buffer-fill-pointer 0 :type index)
;; Whenever we output stuff from the buffer, we shift the remaining noise
;; Buffer holding the per-line prefix active at the buffer start.
;; Indentation is included in this. The length of this is stored
;; in the logical block stack.
- (prefix (make-string initial-buffer-size) :type simple-string)
+ (prefix (make-string initial-buffer-size) :type (simple-array character (*)))
;; Buffer holding the total remaining suffix active at the buffer start.
;; The characters are right-justified in the buffer to make it easier
;; to output the buffer. The length is stored in the logical block
;; stack.
- (suffix (make-string initial-buffer-size) :type simple-string)
+ (suffix (make-string initial-buffer-size) :type (simple-array character (*)))
;; Queue of pending operations. When empty, HEAD=TAIL=NIL. Otherwise,
;; TAIL holds the first (oldest) cons and HEAD holds the last (newest)
;; cons. Adding things to the queue is basically (setf (cdr head) (list
(type simple-string string)
(type index start)
(type (or index null) end))
- (let ((end (or end (length string))))
+ (let* ((string (if (typep string '(simple-array character (*)))
+ string
+ (coerce string '(simple-array character (*)))))
+ (end (or end (length string))))
(unless (= start end)
(let ((newline (position #\newline string :start start :end end)))
(cond
(defstruct (block-start (:include section-start)
(:copier nil))
(block-end nil :type (or null block-end))
- (prefix nil :type (or null simple-string))
- (suffix nil :type (or null simple-string)))
+ (prefix nil :type (or null (simple-array character (*))))
+ (suffix nil :type (or null (simple-array character (*)))))
(defun start-logical-block (stream prefix per-line-p suffix)
;; (In the PPRINT-LOGICAL-BLOCK form which calls us,
;; trivial, so it should always be a string.)
(declare (type string suffix))
(when prefix
- (setq prefix (coerce prefix 'simple-string))
+ (setq prefix (coerce prefix '(simple-array character (*))))
(pretty-sout stream prefix 0 (length prefix)))
(let* ((pending-blocks (pretty-stream-pending-blocks stream))
(start (enqueue stream block-start
:prefix (and per-line-p prefix)
- :suffix (coerce suffix 'simple-string)
+ :suffix (coerce suffix '(simple-array character (*)))
:depth (length pending-blocks))))
(setf (pretty-stream-pending-blocks stream)
(cons start pending-blocks))))
(defstruct (block-end (:include queued-op)
(:copier nil))
- (suffix nil :type (or null simple-string)))
+ (suffix nil :type (or null (simple-array character (*)))))
(defun end-logical-block (stream)
(let* ((start (pop (pretty-stream-pending-blocks stream)))
;; T iff one of the original entries.
(initial-p *building-initial-table* :type (member t nil))
;; and the associated function
- (fun (missing-arg) :type function))
+ (fun (missing-arg) :type callable))
(def!method print-object ((entry pprint-dispatch-entry) stream)
(print-unreadable-object (entry stream :type t)
(format stream "type=~S, priority=~S~@[ [initial]~]"
(pprint-dispatch-entry-priority entry)
(pprint-dispatch-entry-initial-p entry))))
-(defstruct (pprint-dispatch-table (:copier nil))
- ;; A list of all the entries (except for CONS entries below) in highest
- ;; to lowest priority.
- (entries nil :type list)
- ;; A hash table mapping things to entries for type specifiers of the
- ;; form (CONS (MEMBER <thing>)). If the type specifier is of this form,
- ;; we put it in this hash table instead of the regular entries table.
- (cons-entries (make-hash-table :test 'eql)))
-(def!method print-object ((table pprint-dispatch-table) stream)
- (print-unreadable-object (table stream :type t :identity t)))
-
(defun cons-type-specifier-p (spec)
(and (consp spec)
(eq (car spec) 'cons)
(defun set-pprint-dispatch (type function &optional
(priority 0) (table *print-pprint-dispatch*))
- (declare (type (or null function) function)
+ (declare (type (or null callable) function)
(type real priority)
(type pprint-dispatch-table table))
(/show0 "entering SET-PPRINT-DISPATCH, TYPE=...")
:test #'equal))
(entry (make-pprint-dispatch-entry
:type type
- :test-fn (compute-test-fn type)
- :priority priority
- :fun function)))
+ :test-fn (compute-test-fn type)
+ :priority priority
+ :fun function)))
(do ((prev nil next)
(next list (cdr next)))
((null next)
(if prev
- (setf (cdr prev) (list entry))
- (setf list (list entry))))
- (when (entry< (car next) entry)
- (if prev
- (setf (cdr prev) (cons entry next))
- (setf list (cons entry next)))
- (return)))
+ (setf (cdr prev) (list entry))
+ (setf list (list entry))))
+ (when (entry< (car next) entry)
+ (if prev
+ (setf (cdr prev) (cons entry next))
+ (setf list (cons entry next)))
+ (return)))
(setf (pprint-dispatch-table-entries table) list)))
(if (cons-type-specifier-p type)
(remhash (second (second type))
projects / sbcl.git / blobdiff