X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fpprint.lisp;h=bc3dc844f1e97546d1a3b249d99f7bc3bb0b75b4;hb=6f7128b46e9ca91de777f61e8623bf5d997b2987;hp=32df69b532c19a799dbc94484a7df4c2f435c80c;hpb=ac0bb62cb48dcba68b07e0a1eb5573de92373c7c;p=sbcl.git diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index 32df69b..bc3dc84 100644 --- a/src/code/pprint.lisp +++ b/src/code/pprint.lisp @@ -44,7 +44,7 @@ :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 @@ -75,12 +75,12 @@ ;; 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 @@ -134,7 +134,10 @@ (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 @@ -307,8 +310,8 @@ (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, @@ -319,19 +322,19 @@ ;; 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))) @@ -803,7 +806,7 @@ ;; 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]~]" @@ -811,17 +814,6 @@ (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 )). 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) @@ -926,7 +918,7 @@ (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=...") @@ -943,20 +935,20 @@ :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))