X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fpprint.lisp;h=0da0d3d8abb428c21831c123c25cf97b44d46e74;hb=0152c2971917eed5117f5d6b53653bd8424b6b1f;hp=aadf41ae46a6c0f3e210ef728f6707ee3d583c2f;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index aadf41a..0da0d3d 100644 --- a/src/code/pprint.lisp +++ b/src/code/pprint.lisp @@ -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-array character (*))) + (prefix (make-string initial-buffer-size) :type simple-string) ;; 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-array character (*))) + (suffix (make-string initial-buffer-size) :type simple-string) ;; 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,33 +134,48 @@ (type simple-string string) (type index start) (type (or index null) end)) - (let* ((string (if (typep string '(simple-array character (*))) - string - (coerce string '(simple-array character (*))))) - (end (or end (length string)))) + (let* ((end (or end (length string)))) (unless (= start end) - (let ((newline (position #\newline string :start start :end end))) - (cond - (newline - (pretty-sout stream string start newline) - (enqueue-newline stream :literal) - (pretty-sout stream string (1+ newline) end)) - (t - (let ((chars (- end start))) - (loop - (let* ((available (ensure-space-in-buffer stream chars)) - (count (min available chars)) - (fill-pointer (pretty-stream-buffer-fill-pointer stream)) - (new-fill-ptr (+ fill-pointer count))) - (replace (pretty-stream-buffer stream) - string - :start1 fill-pointer :end1 new-fill-ptr - :start2 start) - (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) - (decf chars count) - (when (zerop count) - (return)) - (incf start count)))))))))) + (sb!impl::string-dispatch (simple-base-string + #!+sb-unicode + (simple-array character (*))) + string + ;; For POSITION transform + (declare (optimize (speed 2))) + (let ((newline (position #\newline string :start start :end end))) + (cond + (newline + (pretty-sout stream string start newline) + (enqueue-newline stream :literal) + (pretty-sout stream string (1+ newline) end)) + (t + (let ((chars (- end start))) + (loop + (let* ((available (ensure-space-in-buffer stream chars)) + (count (min available chars)) + (fill-pointer (pretty-stream-buffer-fill-pointer + stream)) + (new-fill-ptr (+ fill-pointer count))) + (if (typep string 'simple-base-string) + ;; FIXME: Reimplementing REPLACE, since it + ;; can't be inlined and we don't have a + ;; generic "simple-array -> simple-array" + ;; transform for it. + (loop for i from fill-pointer below new-fill-ptr + for j from start + with target = (pretty-stream-buffer stream) + do (setf (aref target i) + (aref string j))) + (replace (pretty-stream-buffer stream) + string + :start1 fill-pointer :end1 new-fill-ptr + :start2 start)) + (setf (pretty-stream-buffer-fill-pointer stream) + new-fill-ptr) + (decf chars count) + (when (zerop count) + (return)) + (incf start count))))))))))) (defun pretty-misc (stream op &optional arg1 arg2) (declare (ignore stream op arg1 arg2))) @@ -310,8 +325,8 @@ (defstruct (block-start (:include section-start) (:copier nil)) (block-end nil :type (or null block-end)) - (prefix nil :type (or null (simple-array character (*)))) - (suffix nil :type (or null (simple-array character (*))))) + (prefix nil :type (or null simple-string)) + (suffix nil :type (or null simple-string))) (defun start-logical-block (stream prefix per-line-p suffix) ;; (In the PPRINT-LOGICAL-BLOCK form which calls us, @@ -322,19 +337,22 @@ ;; trivial, so it should always be a string.) (declare (type string suffix)) (when prefix - (setq prefix (coerce prefix '(simple-array character (*)))) + (unless (typep prefix 'simple-string) + (setq prefix (coerce prefix '(simple-array character (*))))) (pretty-sout stream prefix 0 (length prefix))) + (unless (typep suffix 'simple-string) + (setq suffix (coerce suffix '(simple-array character (*))))) (let* ((pending-blocks (pretty-stream-pending-blocks stream)) (start (enqueue stream block-start :prefix (and per-line-p prefix) - :suffix (coerce suffix '(simple-array character (*))) + :suffix suffix :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-array character (*))))) + (suffix nil :type (or null simple-string))) (defun end-logical-block (stream) (let* ((start (pop (pretty-stream-pending-blocks stream))) @@ -1264,9 +1282,13 @@ (defun pprint-fun-call (stream list &rest noise) (declare (ignore noise)) - (funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~_~}~:>") + (funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~:_~}~:>") stream list)) + +(defun pprint-data-list (stream list &rest noise) + (declare (ignore noise)) + (funcall (formatter "~:<~@{~W~^ ~:_~}~:>") stream list)) ;;;; the interface seen by regular (ugly) printer and initialization routines @@ -1284,8 +1306,10 @@ ;; printers for regular types (/show0 "doing SET-PPRINT-DISPATCH for regular types") (set-pprint-dispatch 'array #'pprint-array) - (set-pprint-dispatch '(cons symbol) + (set-pprint-dispatch '(cons (and symbol (satisfies fboundp))) #'pprint-fun-call -1) + (set-pprint-dispatch '(cons symbol) + #'pprint-data-list -2) (set-pprint-dispatch 'cons #'pprint-fill -2) ;; cons cells with interesting things for the car (/show0 "doing SET-PPRINT-DISPATCH for CONS with interesting CAR")