| 1 | ;;; -*- Mode: LISP; Package: CCL -*- |
|---|
| 2 | ;;; |
|---|
| 3 | ;;; Copyright (C) 2009 Clozure Associates |
|---|
| 4 | ;;; Copyright (C) 1994-2001 Digitool, Inc |
|---|
| 5 | ;;; This file is part of Clozure CL. |
|---|
| 6 | ;;; |
|---|
| 7 | ;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public |
|---|
| 8 | ;;; License , known as the LLGPL and distributed with Clozure CL as the |
|---|
| 9 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
|---|
| 10 | ;;; which is distributed with Clozure CL as the file "LGPL". Where these |
|---|
| 11 | ;;; conflict, the preamble takes precedence. |
|---|
| 12 | ;;; |
|---|
| 13 | ;;; Clozure CL is referenced in the preamble as the "LIBRARY." |
|---|
| 14 | ;;; |
|---|
| 15 | ;;; The LLGPL is also available online at |
|---|
| 16 | ;;; http://opensource.franz.com/preamble.html |
|---|
| 17 | |
|---|
| 18 | ;; L1-io.lisp |
|---|
| 19 | |
|---|
| 20 | (in-package "CCL") |
|---|
| 21 | |
|---|
| 22 | (setf (fdefinition '%new-ptr) (fdefinition '%new-gcable-ptr)) |
|---|
| 23 | |
|---|
| 24 | |
|---|
| 25 | ;;;; ====================================================================== |
|---|
| 26 | ;;;; Standard CL IO frobs |
|---|
| 27 | |
|---|
| 28 | |
|---|
| 29 | (declaim (inline %real-print-stream)) |
|---|
| 30 | (defun %real-print-stream (&optional (stream nil)) |
|---|
| 31 | (cond ((null stream) |
|---|
| 32 | *standard-output*) |
|---|
| 33 | ((eq stream t) |
|---|
| 34 | *terminal-io*) |
|---|
| 35 | (t stream))) |
|---|
| 36 | |
|---|
| 37 | ;;; OK, EOFP isn't CL ... |
|---|
| 38 | (defun eofp (&optional (stream *standard-input*)) |
|---|
| 39 | (stream-eofp stream)) |
|---|
| 40 | |
|---|
| 41 | (defun force-output (&optional stream) |
|---|
| 42 | (stream-force-output (%real-print-stream stream)) |
|---|
| 43 | nil) |
|---|
| 44 | |
|---|
| 45 | (defun listen (&optional (stream *standard-input*)) |
|---|
| 46 | (let* ((stream (designated-input-stream stream))) |
|---|
| 47 | (stream-listen stream))) |
|---|
| 48 | |
|---|
| 49 | (defun fresh-line (&optional (output-stream *standard-output*)) |
|---|
| 50 | "Output #\Newline only if the OUTPUT-STREAM is not already at the |
|---|
| 51 | start of a line. Return T if #\Newline needed." |
|---|
| 52 | (stream-fresh-line (%real-print-stream output-stream))) |
|---|
| 53 | |
|---|
| 54 | (defun column (&optional stream) |
|---|
| 55 | (let* ((stream (%real-print-stream stream))) |
|---|
| 56 | (stream-line-column stream))) |
|---|
| 57 | |
|---|
| 58 | (defun clear-input (&optional input-stream) |
|---|
| 59 | "Clear any available input from INPUT-STREAM." |
|---|
| 60 | (stream-clear-input (designated-input-stream input-stream)) |
|---|
| 61 | nil) |
|---|
| 62 | |
|---|
| 63 | (defun write-char (char &optional (output-stream nil)) |
|---|
| 64 | "Output CHAR to OUTPUT-STREAM." |
|---|
| 65 | (let* ((stream (%real-print-stream output-stream))) |
|---|
| 66 | (if (typep stream 'basic-stream) |
|---|
| 67 | (let* ((ioblock (basic-stream-ioblock stream))) |
|---|
| 68 | (funcall (ioblock-write-char-function ioblock) ioblock char)) |
|---|
| 69 | (stream-write-char stream char)) |
|---|
| 70 | char)) |
|---|
| 71 | |
|---|
| 72 | (defun write-string (string &optional output-stream &key (start 0 start-p) |
|---|
| 73 | (end nil end-p)) |
|---|
| 74 | "Write the characters of the subsequence of STRING bounded by START |
|---|
| 75 | and END to OUTPUT-STREAM." |
|---|
| 76 | (let* ((stream (%real-print-stream output-stream))) |
|---|
| 77 | (if (typep stream 'basic-stream) |
|---|
| 78 | (let* ((ioblock (basic-stream-ioblock stream))) |
|---|
| 79 | (with-ioblock-output-locked (ioblock) |
|---|
| 80 | (if (and (typep string 'simple-string) |
|---|
| 81 | (not start-p) (not end-p)) |
|---|
| 82 | (funcall (ioblock-write-simple-string-function ioblock) |
|---|
| 83 | ioblock string 0 (length string)) |
|---|
| 84 | (progn |
|---|
| 85 | (setq end (check-sequence-bounds string start end)) |
|---|
| 86 | (locally (declare (fixnum start end)) |
|---|
| 87 | (multiple-value-bind (arr offset) |
|---|
| 88 | (if (typep string 'simple-string) |
|---|
| 89 | (values string 0) |
|---|
| 90 | (array-data-and-offset (require-type string 'string))) |
|---|
| 91 | (unless (eql 0 offset) |
|---|
| 92 | (incf start offset) |
|---|
| 93 | (incf end offset)) |
|---|
| 94 | (funcall (ioblock-write-simple-string-function ioblock) |
|---|
| 95 | ioblock arr start (the fixnum (- end start))))))))) |
|---|
| 96 | (if (and (not start-p) (not end-p)) |
|---|
| 97 | (stream-write-string stream string) |
|---|
| 98 | (stream-write-string stream string start end))) |
|---|
| 99 | string)) |
|---|
| 100 | |
|---|
| 101 | (defun write-simple-string (string output-stream start end) |
|---|
| 102 | "Write the characters of the subsequence of simple-string STRING bounded by START |
|---|
| 103 | and END to OUTPUT-STREAM." |
|---|
| 104 | (let* ((stream (%real-print-stream output-stream)) |
|---|
| 105 | (string (the simple-string string))) ;; typecheck at high safety. |
|---|
| 106 | (if (typep stream 'basic-stream) |
|---|
| 107 | (let* ((ioblock (basic-stream-ioblock stream)) |
|---|
| 108 | (start (or start 0))) |
|---|
| 109 | (with-ioblock-output-locked (ioblock) |
|---|
| 110 | (if (and (eq start 0) (null end)) |
|---|
| 111 | (funcall (ioblock-write-simple-string-function ioblock) |
|---|
| 112 | ioblock string 0 (length string)) |
|---|
| 113 | (let* ((end (check-sequence-bounds string start end))) |
|---|
| 114 | (funcall (ioblock-write-simple-string-function ioblock) |
|---|
| 115 | ioblock string start (%i- end start)))))) |
|---|
| 116 | (if (and (not start) (not end)) |
|---|
| 117 | (stream-write-string stream string) |
|---|
| 118 | (stream-write-string stream string start (or end (length string))))) |
|---|
| 119 | string)) |
|---|
| 120 | |
|---|
| 121 | (defun write-line (string &optional output-stream |
|---|
| 122 | &key (start 0) (end (length string))) |
|---|
| 123 | "Write the characters of the subsequence of STRING bounded by START |
|---|
| 124 | and END to OUTPUT-STREAM then output a #\Newline at end." |
|---|
| 125 | (write-string string output-stream :start start :end end) |
|---|
| 126 | (terpri output-stream) |
|---|
| 127 | string) |
|---|
| 128 | |
|---|
| 129 | (defun terpri (&optional (stream *standard-output*)) |
|---|
| 130 | (let* ((stream (%real-print-stream stream))) |
|---|
| 131 | (if (typep stream 'basic-stream) |
|---|
| 132 | (let* ((ioblock (basic-stream-ioblock stream))) |
|---|
| 133 | (funcall (ioblock-write-char-function ioblock) ioblock #\newline)) |
|---|
| 134 | (stream-write-char stream #\newline)) |
|---|
| 135 | nil)) |
|---|
| 136 | |
|---|
| 137 | ;;;; ---------------------------------------------------------------------- |
|---|
| 138 | |
|---|
| 139 | |
|---|
| 140 | |
|---|
| 141 | ;;;; ====================================================================== |
|---|
| 142 | ;;;; The Lisp Printer |
|---|
| 143 | |
|---|
| 144 | |
|---|
| 145 | ;; coral extensions |
|---|
| 146 | (defvar *print-abbreviate-quote* t |
|---|
| 147 | "Non-NIL means that the normal lisp printer -- |
|---|
| 148 | not just the pretty-printer -- should print |
|---|
| 149 | lists whose first element is QUOTE or FUNCTION specially. |
|---|
| 150 | This variable is not part of standard Common Lisp.") |
|---|
| 151 | |
|---|
| 152 | (defvar *print-structure* t |
|---|
| 153 | "Non-NIL means that lisp structures should be printed using |
|---|
| 154 | \"#S(...)\" syntax. if nil, structures are printed using \"#<...>\". |
|---|
| 155 | This variable is not part of standard Common Lisp.") |
|---|
| 156 | |
|---|
| 157 | ;; things Richard Mlynarik likes. |
|---|
| 158 | (defvar *print-simple-vector* nil |
|---|
| 159 | "Non-NIL means that simple-vectors whose length is less than |
|---|
| 160 | the value of this variable are printed even if *PRINT-ARRAY* is false. |
|---|
| 161 | this variable is not part of standard Common Lisp.") |
|---|
| 162 | |
|---|
| 163 | (defvar *print-simple-bit-vector* nil |
|---|
| 164 | "Non-NIL means that simple-bit-vectors whose length is less than |
|---|
| 165 | the value of this variable are printed even if *PRINT-ARRAY* is false. |
|---|
| 166 | This variable is not part of standard Common Lisp.") |
|---|
| 167 | |
|---|
| 168 | (defvar *print-string-length* nil |
|---|
| 169 | "Non-NIL means that strings longer than this are printed |
|---|
| 170 | using abbreviated #<string ...> syntax. |
|---|
| 171 | This variable is not part of standard Common Lisp.") |
|---|
| 172 | |
|---|
| 173 | (defvar *print-escape* t |
|---|
| 174 | "Non-NIL means that the lisp printer should -attempt- to output |
|---|
| 175 | expressions `readably.' When NIL the attempts to produce output |
|---|
| 176 | which is a little more human-readable (for example, pathnames |
|---|
| 177 | are represented by the characters of their namestring.)") |
|---|
| 178 | |
|---|
| 179 | (defvar *print-pretty* nil |
|---|
| 180 | "Non-NIL means that the lisp printer should insert extra |
|---|
| 181 | indentation and newlines to make output more readable and `prettier.'") |
|---|
| 182 | |
|---|
| 183 | (defvar *print-base* 10. |
|---|
| 184 | "The output base for integers and rationals. |
|---|
| 185 | Must be an integer between 2 and 36.") |
|---|
| 186 | |
|---|
| 187 | (defvar *print-radix* nil |
|---|
| 188 | "Non-NIL means that the lisp printer will explicitly indicate |
|---|
| 189 | the output radix (see *PRINT-BASE*) which is used to print |
|---|
| 190 | integers and rational numbers.") |
|---|
| 191 | |
|---|
| 192 | (defvar *print-level* nil |
|---|
| 193 | "Specifies the depth at which printing of lisp expressions |
|---|
| 194 | should be truncated. NIL means that no such truncation should occur. |
|---|
| 195 | Truncation is indicated by printing \"#\" instead of the |
|---|
| 196 | representation of the too-deeply-nested structure. |
|---|
| 197 | See also *PRINT-LENGTH*") |
|---|
| 198 | |
|---|
| 199 | (defvar *print-length* nil |
|---|
| 200 | "Specifies the length at which printing of lisp expressions |
|---|
| 201 | should be truncated. NIL means that no such truncation should occur. |
|---|
| 202 | truncation is indicated by printing \"...\" instead of the |
|---|
| 203 | rest of the overly-long list or vector. |
|---|
| 204 | See also *PRINT-LEVEL*") |
|---|
| 205 | |
|---|
| 206 | (defvar *print-circle* nil |
|---|
| 207 | "Non-NIL means that the lisp printer should attempt to detect |
|---|
| 208 | circular structures, indicating them by using \"#n=\" and \"#n#\" syntax. |
|---|
| 209 | If this variable is false then an attempt to |
|---|
| 210 | output circular structure may cause unbounded output.") |
|---|
| 211 | |
|---|
| 212 | (defvar *print-case* ':upcase |
|---|
| 213 | "Specifies the alphabetic case in which symbols should |
|---|
| 214 | be printed. Possible values include :UPCASE, :DOWNCASE and :CAPITALIZE") ; and :StuDLy |
|---|
| 215 | |
|---|
| 216 | (defvar *print-array* t |
|---|
| 217 | "Non-NIL means that arrays should be printed using \"#(...)\" or |
|---|
| 218 | \"=#nA(...)\" syntax to show their contents. |
|---|
| 219 | If NIL, arrays other than strings are printed using \"#<...>\". |
|---|
| 220 | See also the (non-Common Lisp) variables *PRINT-SIMPLE-VECTOR* |
|---|
| 221 | and *PRINT-SIMPLE-BIT-VECTOR*") |
|---|
| 222 | |
|---|
| 223 | (defvar *print-gensym* t |
|---|
| 224 | "Non-NIL means that symbols with no home package should be |
|---|
| 225 | printed using \"#:\" syntax. NIL means no prefix is printed.") |
|---|
| 226 | |
|---|
| 227 | (defvar *print-readably* nil |
|---|
| 228 | "Non-NIL means that attempts to print unreadable objects |
|---|
| 229 | signal PRINT-NOT-READABLE errors. NIL doesn't.") |
|---|
| 230 | |
|---|
| 231 | (defvar *PRINT-RIGHT-MARGIN* nil |
|---|
| 232 | "+#/NIL the right margin for pretty printing") |
|---|
| 233 | |
|---|
| 234 | (defvar *PRINT-MISER-WIDTH* 40. |
|---|
| 235 | "+#/NIL miser format starts when there is less than this width left") |
|---|
| 236 | |
|---|
| 237 | (defvar *PRINT-LINES* nil |
|---|
| 238 | "+#/NIL truncates printing after # lines") |
|---|
| 239 | |
|---|
| 240 | (defvar *DEFAULT-RIGHT-MARGIN* 70 |
|---|
| 241 | "Controls default line length; Must be a non-negative integer") |
|---|
| 242 | |
|---|
| 243 | (defvar *PRINT-PPRINT-DISPATCH* nil) ; We have to support this. |
|---|
| 244 | |
|---|
| 245 | (defvar *xp-current-object* nil) ; from xp |
|---|
| 246 | |
|---|
| 247 | (defvar *circularity-hash-table* nil) ; ditto |
|---|
| 248 | |
|---|
| 249 | (defvar *current-level* nil) |
|---|
| 250 | |
|---|
| 251 | (defvar *current-length* nil) ; must be nil at top level |
|---|
| 252 | |
|---|
| 253 | (defvar *print-catch-errors* nil) |
|---|
| 254 | |
|---|
| 255 | ;;;; ====================================================================== |
|---|
| 256 | |
|---|
| 257 | (defclass xp-stream (output-stream) |
|---|
| 258 | (xp-structure)) |
|---|
| 259 | |
|---|
| 260 | (defun %write-string (string stream) |
|---|
| 261 | (if (characterp string) |
|---|
| 262 | (stream-write-char stream string) |
|---|
| 263 | (stream-write-entire-string stream string))) |
|---|
| 264 | |
|---|
| 265 | |
|---|
| 266 | ;; *print-simple-vector* |
|---|
| 267 | ;; *print-simple-bit-vector* |
|---|
| 268 | ;; *print-string-length* |
|---|
| 269 | ;; for things like *print-level* which must [no longer] be integers > 0 |
|---|
| 270 | (defun get-*print-frob* (symbol |
|---|
| 271 | &optional (nil-means target::target-most-positive-fixnum) |
|---|
| 272 | (t-means nil)) |
|---|
| 273 | (declare (type symbol symbol)) |
|---|
| 274 | (let ((value (symbol-value symbol))) |
|---|
| 275 | (when *print-readably* |
|---|
| 276 | (case symbol |
|---|
| 277 | ((*print-length* *print-level* *print-lines* *print-string-length*) |
|---|
| 278 | (setq value nil)) |
|---|
| 279 | ((*print-escape* *print-gensym* *print-array* *print-simple-vector* |
|---|
| 280 | *print-simple-bit-vector*) |
|---|
| 281 | (setq value t)) |
|---|
| 282 | (t nil))) |
|---|
| 283 | (cond ((null value) |
|---|
| 284 | nil-means) |
|---|
| 285 | ((and (integerp value)) ; (> value 0)) |
|---|
| 286 | (min (max value -1) value target::target-most-positive-fixnum)) |
|---|
| 287 | ((and t-means (eq value 't)) |
|---|
| 288 | t-means) |
|---|
| 289 | (t |
|---|
| 290 | (setf (symbol-value symbol) nil) |
|---|
| 291 | (error "~s had illegal value ~s. reset to ~s" |
|---|
| 292 | symbol value 'nil))))) |
|---|
| 293 | |
|---|
| 294 | |
|---|
| 295 | (defun pp-newline (stream kind) |
|---|
| 296 | (case kind |
|---|
| 297 | ((:newline) |
|---|
| 298 | (fresh-line stream)) |
|---|
| 299 | ((:unconditional :mandatory) |
|---|
| 300 | (stream-write-char stream #\Newline)) |
|---|
| 301 | (t nil))) |
|---|
| 302 | |
|---|
| 303 | |
|---|
| 304 | (defun pp-space (stream &optional (newline-kind ':fill)) |
|---|
| 305 | (stream-write-char stream #\space) |
|---|
| 306 | (pp-newline stream newline-kind)) |
|---|
| 307 | |
|---|
| 308 | (defun pp-start-block (stream &optional prefix) |
|---|
| 309 | (cond ((null prefix)) |
|---|
| 310 | ((characterp prefix) |
|---|
| 311 | (stream-write-char stream prefix)) |
|---|
| 312 | ((stringp prefix) |
|---|
| 313 | (%write-string prefix stream)) |
|---|
| 314 | (t (report-bad-arg prefix '(or character string (eql nil)))))) |
|---|
| 315 | |
|---|
| 316 | |
|---|
| 317 | (defun pp-end-block (stream &optional suffix) |
|---|
| 318 | (cond ((null suffix)) |
|---|
| 319 | ((characterp suffix) |
|---|
| 320 | (stream-write-char stream suffix)) |
|---|
| 321 | ((stringp suffix) |
|---|
| 322 | (%write-string suffix stream)) |
|---|
| 323 | (t (report-bad-arg suffix '(or character string (eql nil)))))) |
|---|
| 324 | |
|---|
| 325 | |
|---|
| 326 | #| |
|---|
| 327 | (defmethod pp-set-indentation ((stream stream) kind n) |
|---|
| 328 | (declare (ignore kind n)) |
|---|
| 329 | nil) |
|---|
| 330 | |# |
|---|
| 331 | |
|---|
| 332 | |
|---|
| 333 | ;;;; ====================================================================== |
|---|
| 334 | ;; list-kludge is so that we can simultaneously detect shared list tails |
|---|
| 335 | ;; and avoid printing lists as (foo . (bar . (baz . nil))) |
|---|
| 336 | ;; if non-nil, it is the remaining *print-length* and object is |
|---|
| 337 | ;; a list tail |
|---|
| 338 | |
|---|
| 339 | |
|---|
| 340 | |
|---|
| 341 | (defmethod write-internal-1 ((stream t) object level list-kludge) |
|---|
| 342 | (declare (type fixnum level) (type (or null fixnum) list-kludge)) |
|---|
| 343 | ;;>> Anybody passing in list-kludge had better be internal to the lisp printer. |
|---|
| 344 | ;(if list-kludge (error "Internal printer error")) |
|---|
| 345 | (let ((circle *print-circle*) |
|---|
| 346 | (pretty *print-pretty*)) |
|---|
| 347 | (cond ((or pretty circle) |
|---|
| 348 | ; what about this level stuff?? |
|---|
| 349 | ; most peculiar |
|---|
| 350 | (maybe-initiate-xp-printing |
|---|
| 351 | #'(lambda (s o) (write+ o s)) stream object)) |
|---|
| 352 | ((not list-kludge) |
|---|
| 353 | (write-a-frob object stream level list-kludge)) |
|---|
| 354 | ((null object)) |
|---|
| 355 | (t |
|---|
| 356 | (stream-write-char stream #\space) |
|---|
| 357 | (when (not (consp object)) |
|---|
| 358 | (stream-write-char stream #\.) |
|---|
| 359 | (stream-write-char stream #\space)) |
|---|
| 360 | (write-a-frob object stream level list-kludge))))) |
|---|
| 361 | |
|---|
| 362 | |
|---|
| 363 | |
|---|
| 364 | (defmethod write-internal-1 ((stream xp-stream) object level list-kludge) |
|---|
| 365 | (when level |
|---|
| 366 | (setq *current-level* (if (and *print-level* (not *print-readably*)) |
|---|
| 367 | (- *print-level* level) |
|---|
| 368 | 0))) |
|---|
| 369 | (write+ object (slot-value stream 'xp-structure) list-kludge)) |
|---|
| 370 | |
|---|
| 371 | |
|---|
| 372 | (defvar *inside-printer-error* nil) |
|---|
| 373 | |
|---|
| 374 | (defvar *signal-printing-errors* nil) |
|---|
| 375 | (queue-fixup (setq *signal-printing-errors* t)) |
|---|
| 376 | |
|---|
| 377 | (defun write-internal (stream object level list-kludge) |
|---|
| 378 | (if (bogus-thing-p object) |
|---|
| 379 | (print-unreadable-object |
|---|
| 380 | (object stream) |
|---|
| 381 | (princ (%str-cat "BOGUS object @ #x" (%integer-to-string (%address-of object) 16.)) |
|---|
| 382 | stream)) |
|---|
| 383 | (progn |
|---|
| 384 | (flet ((handler (condition) |
|---|
| 385 | (declare (ignore condition)) |
|---|
| 386 | (unless *signal-printing-errors* |
|---|
| 387 | (return-from write-internal |
|---|
| 388 | (let ((*print-pretty* nil) |
|---|
| 389 | (*print-circle* nil)) |
|---|
| 390 | (if *inside-printer-error* |
|---|
| 391 | (when (eql 1 (incf *inside-printer-error*)) |
|---|
| 392 | (%write-string "#<Recursive printing error " stream) |
|---|
| 393 | (stream-write-char stream #\space) |
|---|
| 394 | (%write-address (%address-of object) stream) |
|---|
| 395 | (stream-write-char stream #\>)) |
|---|
| 396 | (let ((*inside-printer-error* 0)) |
|---|
| 397 | ; using format here considered harmful. |
|---|
| 398 | (%write-string "#<error printing " stream) |
|---|
| 399 | (write-internal stream (type-of object) (max level 2) nil) |
|---|
| 400 | (stream-write-char stream #\space) |
|---|
| 401 | (%write-address (%address-of object) stream) |
|---|
| 402 | (stream-write-char stream #\>)))))))) |
|---|
| 403 | (declare (dynamic-extent #'handler)) |
|---|
| 404 | (handler-bind |
|---|
| 405 | ((error #'handler)) |
|---|
| 406 | (write-internal-1 stream object level list-kludge))) |
|---|
| 407 | object))) |
|---|
| 408 | |
|---|
| 409 | |
|---|
| 410 | ;;;; ====================================================================== |
|---|
| 411 | ;;;; internals of write-internal |
|---|
| 412 | |
|---|
| 413 | ;; bd common-lisp (and lisp machine) printer depth counts |
|---|
| 414 | ;; count from 0 upto *print-level* instead of from |
|---|
| 415 | ;; *print-level* down to 0 (which this printer sensibly does.) |
|---|
| 416 | (defun backtranslate-level (level) |
|---|
| 417 | (let ((print-level (get-*print-frob* '*print-level*))) |
|---|
| 418 | (if (not (and level print-level)) |
|---|
| 419 | target::target-most-positive-fixnum |
|---|
| 420 | (if (> level print-level) |
|---|
| 421 | ;; wtf! |
|---|
| 422 | 1 |
|---|
| 423 | (- print-level level))))) |
|---|
| 424 | |
|---|
| 425 | ; so we can print-circle for print-object methods. |
|---|
| 426 | (defvar %current-write-level% nil) |
|---|
| 427 | (defvar %current-write-stream% nil) |
|---|
| 428 | (defun %current-write-level% (stream &optional decrement?) |
|---|
| 429 | (if (eq stream %current-write-stream%) |
|---|
| 430 | (if decrement? (1- %current-write-level%) %current-write-level%) |
|---|
| 431 | (get-*print-frob* '*print-level*))) |
|---|
| 432 | |
|---|
| 433 | ;;>> Some notes: |
|---|
| 434 | ;;>> CL defining print-object to be a multmethod dispatching on |
|---|
| 435 | ;;>> both the object and the stream just can't work |
|---|
| 436 | ;;>> There are a couple of reasons: |
|---|
| 437 | ;;>> - CL wants *print-circle* structure to be automatically detected |
|---|
| 438 | ;;>> This means that there must be a printing pre-pass to some stream |
|---|
| 439 | ;;>> other than the one specified by the user, which means that any |
|---|
| 440 | ;;>> print-object method which specialises on its second argument is |
|---|
| 441 | ;;>> going to lose big. |
|---|
| 442 | |
|---|
| 443 | ;;>> - CL wants *print-level* truncation to happen automatically |
|---|
| 444 | ;;>> and doesn't pass a level argument to print-object (as it should) |
|---|
| 445 | ;;>> This means that the current level must be associated with the |
|---|
| 446 | ;;>> stream in some fashion. The quicky kludge Bill uses here |
|---|
| 447 | ;;>> (binding a special variable) loses for |
|---|
| 448 | ;;>> + Entering a break loop whilst printing to a stream |
|---|
| 449 | ;;>> (Should start level from (get-*print-level*) again) |
|---|
| 450 | ;;>> + Performing output to more than one stream in an interleaved fashion |
|---|
| 451 | ;;>> (Say a print-object method which writes to *trace-output*) |
|---|
| 452 | ;;>> The solution, again, is to actually call the print-object methods |
|---|
| 453 | ;;>> on a write-aux-stream, where that stream is responsible for |
|---|
| 454 | ;;>> doing *print-level* truncation. |
|---|
| 455 | ;;>> - BTW The select-method-order should be (stream object) to even have |
|---|
| 456 | ;;>> a chance of winning. Not that it could win in any case, for the above reasons. |
|---|
| 457 | ;;>> It isn't that much work to change the printer to always use an |
|---|
| 458 | ;;>> automatically-level-truncating write-aux-stream |
|---|
| 459 | ;;>> It is a pity that CL is so BD. |
|---|
| 460 | ;;>> |
|---|
| 461 | |
|---|
| 462 | (defun write-a-frob (object stream level list-kludge) |
|---|
| 463 | (declare (type stream stream) (type fixnum level) |
|---|
| 464 | (type (or null fixnum) list-kludge)) |
|---|
| 465 | (cond ((not list-kludge) |
|---|
| 466 | (let ((%current-write-stream% stream) ;>> SIGH |
|---|
| 467 | (%current-write-level% level)) |
|---|
| 468 | (print-object object stream))) |
|---|
| 469 | ((%i< list-kludge 1) |
|---|
| 470 | ;; *print-length* truncation |
|---|
| 471 | (stream-write-entire-string stream "...")) |
|---|
| 472 | ((not (consp object)) |
|---|
| 473 | (write-a-frob object stream level nil)) |
|---|
| 474 | (t |
|---|
| 475 | (write-internal stream (%car object) level nil) |
|---|
| 476 | ;;>> must do a tail-call!! |
|---|
| 477 | (write-internal-1 stream (%cdr object) level (if (consp (%cdr object)) |
|---|
| 478 | (%i- list-kludge 1) |
|---|
| 479 | list-kludge))))) |
|---|
| 480 | |
|---|
| 481 | (defmethod print-object :around ((object t) stream) |
|---|
| 482 | (if *print-catch-errors* |
|---|
| 483 | (handler-case (call-next-method) |
|---|
| 484 | (error () (write-string "#<error printing object>" stream))) |
|---|
| 485 | (call-next-method))) |
|---|
| 486 | |
|---|
| 487 | (defmethod print-object ((object t) stream) |
|---|
| 488 | (let ((level (%current-write-level% stream)) ; what an abortion. This should be an ARGUMENT! |
|---|
| 489 | (%type (%type-of object))) |
|---|
| 490 | (declare (type symbol %type) |
|---|
| 491 | (type fixnum level)) |
|---|
| 492 | (flet ((depth (stream v) |
|---|
| 493 | (declare (type fixnum v) (type stream stream)) |
|---|
| 494 | (when (%i<= v 0) |
|---|
| 495 | ;; *print-level* truncation |
|---|
| 496 | (stream-write-entire-string stream "#") |
|---|
| 497 | t))) |
|---|
| 498 | (cond |
|---|
| 499 | ((eq %type 'cons) |
|---|
| 500 | (unless (depth stream level) |
|---|
| 501 | (write-a-cons object stream level))) |
|---|
| 502 | ;; Don't do *print-level* truncation for anything between |
|---|
| 503 | ;; here and the (depth ...) case. |
|---|
| 504 | ((or (eq %type 'symbol) |
|---|
| 505 | (null object)) |
|---|
| 506 | (write-a-symbol object stream)) |
|---|
| 507 | ((or (stringp object) |
|---|
| 508 | (bit-vector-p object)) |
|---|
| 509 | (cond ((or (not (stringp object)) |
|---|
| 510 | (%i> (length (the string object)) |
|---|
| 511 | (get-*print-frob* '*print-string-length*))) |
|---|
| 512 | (write-an-array object stream level)) |
|---|
| 513 | ((or *print-escape* *print-readably*) |
|---|
| 514 | (write-escaped-string object stream)) |
|---|
| 515 | (t |
|---|
| 516 | (%write-string object stream)))) |
|---|
| 517 | ((and (eq %type 'structure) |
|---|
| 518 | (not (null (ccl::struct-def object))) |
|---|
| 519 | (null (cdr (sd-slots (ccl::struct-def object))))) |
|---|
| 520 | ;; else fall through to write-a-uvector |
|---|
| 521 | (write-a-structure object stream level)) |
|---|
| 522 | ((depth stream level)) |
|---|
| 523 | ((eq %type 'package) |
|---|
| 524 | (write-a-package object stream)) |
|---|
| 525 | ((eq %type 'macptr) |
|---|
| 526 | (write-a-macptr object stream)) |
|---|
| 527 | ((eq %type 'dead-macptr) |
|---|
| 528 | (write-a-dead-macptr object stream)) |
|---|
| 529 | ((eq %type 'internal-structure) |
|---|
| 530 | (write-an-istruct object stream level)) |
|---|
| 531 | ((and (eq %type 'structure) |
|---|
| 532 | (not (null (ccl::struct-def object)))) |
|---|
| 533 | ;; else fall through to write-a-uvector |
|---|
| 534 | (if (and *print-pretty* *print-structure*) |
|---|
| 535 | (let ((*current-level* (if (and *print-level* (not *print-readably*)) |
|---|
| 536 | (- *print-level* level) |
|---|
| 537 | 0))) |
|---|
| 538 | (pretty-structure stream object)) |
|---|
| 539 | (write-a-structure object stream level))) |
|---|
| 540 | ((functionp object) |
|---|
| 541 | (write-a-function object stream level)) |
|---|
| 542 | ((arrayp object) |
|---|
| 543 | (cond ((or (not (stringp object)) |
|---|
| 544 | (%i> (length (the string object)) |
|---|
| 545 | (get-*print-frob* '*print-string-length*))) |
|---|
| 546 | (write-an-array object stream level)) |
|---|
| 547 | ((or *print-escape* *print-readably*) |
|---|
| 548 | (write-escaped-string object stream)) |
|---|
| 549 | (t |
|---|
| 550 | (%write-string object stream)))) |
|---|
| 551 | |
|---|
| 552 | ; whazzat |
|---|
| 553 | ((uvectorp object) |
|---|
| 554 | (write-a-uvector object stream level)) |
|---|
| 555 | (t |
|---|
| 556 | (print-unreadable-object (object stream) |
|---|
| 557 | (let* ((address (%address-of object))) |
|---|
| 558 | (cond ((eq object (%unbound-marker-8)) |
|---|
| 559 | (%write-string "Unbound" stream)) |
|---|
| 560 | ((eq object (%slot-unbound-marker)) |
|---|
| 561 | (%write-string "Slot-Unbound" stream)) |
|---|
| 562 | (t |
|---|
| 563 | (cond |
|---|
| 564 | (t |
|---|
| 565 | (%write-string "Unprintable " stream) |
|---|
| 566 | (write-a-symbol %type stream) |
|---|
| 567 | (%write-string " : " stream))) |
|---|
| 568 | (%write-address address stream)))))))) |
|---|
| 569 | nil)) |
|---|
| 570 | |
|---|
| 571 | (defun write-a-dead-macptr (macptr stream) |
|---|
| 572 | (print-unreadable-object (macptr stream) |
|---|
| 573 | (%write-string "A Dead Mac Pointer" stream))) |
|---|
| 574 | |
|---|
| 575 | |
|---|
| 576 | ;;;; ====================================================================== |
|---|
| 577 | ;;;; Powerful, wonderful tools for printing unreadable objects. |
|---|
| 578 | |
|---|
| 579 | (defun print-not-readable-error (object stream) |
|---|
| 580 | (error (make-condition 'print-not-readable :object object :stream stream))) |
|---|
| 581 | |
|---|
| 582 | ; Start writing an unreadable OBJECT on STREAM, error out if *PRINT-READABLY* is true. |
|---|
| 583 | (defun write-unreadable-start (object stream) |
|---|
| 584 | (if *print-readably* |
|---|
| 585 | (print-not-readable-error object stream) |
|---|
| 586 | (pp-start-block stream "#<"))) |
|---|
| 587 | |
|---|
| 588 | (defun %print-unreadable-object (object stream type id thunk) |
|---|
| 589 | (cond ((null stream) (setq stream *standard-output*)) |
|---|
| 590 | ((eq stream t) (setq stream *terminal-io*))) |
|---|
| 591 | (write-unreadable-start object stream) |
|---|
| 592 | (when type |
|---|
| 593 | (princ (type-of object) stream)) |
|---|
| 594 | (when thunk |
|---|
| 595 | (when type (stream-write-char stream #\space)) |
|---|
| 596 | (funcall thunk)) |
|---|
| 597 | (if id |
|---|
| 598 | (%write-address object stream #\>) |
|---|
| 599 | (pp-end-block stream ">")) |
|---|
| 600 | nil) |
|---|
| 601 | |
|---|
| 602 | ;;;; ====================================================================== |
|---|
| 603 | ;;;; internals of internals of write-internal |
|---|
| 604 | |
|---|
| 605 | (defmethod print-object ((char character) stream &aux name) |
|---|
| 606 | (cond ((or *print-escape* *print-readably*) ;print #\ for read-ability |
|---|
| 607 | (stream-write-char stream #\#) |
|---|
| 608 | (stream-write-char stream #\\) |
|---|
| 609 | (if (and (or (eql char #\newline) |
|---|
| 610 | (not (standard-char-p char))) |
|---|
| 611 | (setq name (char-name char))) |
|---|
| 612 | (%write-string name stream) |
|---|
| 613 | (stream-write-char stream char))) |
|---|
| 614 | (t |
|---|
| 615 | (stream-write-char stream char)))) |
|---|
| 616 | |
|---|
| 617 | (defun get-*print-base* () |
|---|
| 618 | (let ((base *print-base*)) |
|---|
| 619 | (unless (and (fixnump base) |
|---|
| 620 | (%i< 1 base) (%i< base 37.)) |
|---|
| 621 | (setq *print-base* 10.) |
|---|
| 622 | (error "~S had illegal value ~S. Reset to ~S" |
|---|
| 623 | '*print-base* base 10)) |
|---|
| 624 | base)) |
|---|
| 625 | |
|---|
| 626 | (defun write-radix (base stream) |
|---|
| 627 | (stream-write-char stream #\#) |
|---|
| 628 | (case base |
|---|
| 629 | (2 (stream-write-char stream #\b)) |
|---|
| 630 | (8 (stream-write-char stream #\o)) |
|---|
| 631 | (16 (stream-write-char stream #\x)) |
|---|
| 632 | (t (%pr-integer base 10. stream) |
|---|
| 633 | (stream-write-char stream #\r)))) |
|---|
| 634 | |
|---|
| 635 | (defun write-an-integer (num stream |
|---|
| 636 | &optional (base (get-*print-base*)) |
|---|
| 637 | (print-radix *print-radix*)) |
|---|
| 638 | (when (and print-radix (not (eq base 10))) |
|---|
| 639 | (write-radix base stream)) |
|---|
| 640 | (%pr-integer num base stream) |
|---|
| 641 | (when (and print-radix (eq base 10)) |
|---|
| 642 | (stream-write-char stream #\.))) |
|---|
| 643 | |
|---|
| 644 | (defmethod print-object ((num integer) stream) |
|---|
| 645 | (write-an-integer num stream)) |
|---|
| 646 | |
|---|
| 647 | (defun %write-address (object stream &optional foo) |
|---|
| 648 | (if foo (pp-space stream)) |
|---|
| 649 | (write-an-integer (if (integerp object) object (%address-of object)) stream 16. t) |
|---|
| 650 | (if foo (pp-end-block stream foo))) |
|---|
| 651 | |
|---|
| 652 | (defmethod print-object ((num ratio) stream) |
|---|
| 653 | (let ((base (get-*print-base*))) |
|---|
| 654 | ;;>> What to do when for *print-radix* and *print-base* = 10? |
|---|
| 655 | (when (and *print-radix* (not (eq base 10))) |
|---|
| 656 | (write-radix base stream)) |
|---|
| 657 | (%pr-integer (numerator num) base stream) |
|---|
| 658 | (stream-write-char stream #\/) |
|---|
| 659 | (%pr-integer (denominator num) base stream))) |
|---|
| 660 | |
|---|
| 661 | ;;>> Doesn't do *print-level* truncation |
|---|
| 662 | (defmethod print-object ((c complex) stream) |
|---|
| 663 | (pp-start-block stream "#C(") |
|---|
| 664 | (print-object (realpart c) stream) |
|---|
| 665 | (pp-space stream) |
|---|
| 666 | (print-object (imagpart c) stream) |
|---|
| 667 | (pp-end-block stream #\))) |
|---|
| 668 | |
|---|
| 669 | (defmethod print-object ((float float) stream) |
|---|
| 670 | (print-a-float float stream)) |
|---|
| 671 | |
|---|
| 672 | (defun float-exponent-char (float) |
|---|
| 673 | (if (case *read-default-float-format* |
|---|
| 674 | (single-float (typep float 'single-float)) |
|---|
| 675 | (double-float (typep float 'double-float)) |
|---|
| 676 | (t (typep float *read-default-float-format*))) |
|---|
| 677 | #\E |
|---|
| 678 | (if (typep float 'double-float) |
|---|
| 679 | #\D |
|---|
| 680 | #\S))) |
|---|
| 681 | |
|---|
| 682 | (defun default-float-p (float) |
|---|
| 683 | (case *read-default-float-format* |
|---|
| 684 | (single-float (typep float 'single-float)) |
|---|
| 685 | (double-float (typep float 'double-float)) |
|---|
| 686 | (t (typep float *read-default-float-format*)))) |
|---|
| 687 | |
|---|
| 688 | |
|---|
| 689 | (defun print-a-nan (float stream) |
|---|
| 690 | (if (infinity-p float) |
|---|
| 691 | (output-float-infinity float stream) |
|---|
| 692 | (output-float-nan float stream))) |
|---|
| 693 | |
|---|
| 694 | (defun output-float-infinity (x stream) |
|---|
| 695 | (declare (float x) (stream stream)) |
|---|
| 696 | (format stream "~:[-~;~]1~c++0" |
|---|
| 697 | (plusp x) |
|---|
| 698 | (if (typep x *read-default-float-format*) |
|---|
| 699 | #\E |
|---|
| 700 | (typecase x |
|---|
| 701 | (double-float #\D) |
|---|
| 702 | (single-float #\S))))) |
|---|
| 703 | |
|---|
| 704 | (defun output-float-nan (x stream) |
|---|
| 705 | (declare (float x) (stream stream)) |
|---|
| 706 | (format stream "1~c+-0 #| not-a-number |#" |
|---|
| 707 | (if (typep x *read-default-float-format*) |
|---|
| 708 | #\E |
|---|
| 709 | (etypecase x |
|---|
| 710 | (double-float #\D) |
|---|
| 711 | (single-float #\S))))) |
|---|
| 712 | |
|---|
| 713 | |
|---|
| 714 | ;; nanning => recursive from print-a-nan - don't check again |
|---|
| 715 | (defun print-a-float (float stream &optional exp-p nanning) |
|---|
| 716 | (let ((strlen 0) (exponent-char (float-exponent-char float))) |
|---|
| 717 | (declare (fixnum strlen)) |
|---|
| 718 | (setq stream (%real-print-stream stream)) |
|---|
| 719 | (if (and (not nanning)(nan-or-infinity-p float)) |
|---|
| 720 | (print-a-nan float stream) |
|---|
| 721 | (multiple-value-bind (string before-pt #|after-pt|#) |
|---|
| 722 | (flonum-to-string float) |
|---|
| 723 | (declare (fixnum before-pt #|after-pt|#)) |
|---|
| 724 | (setq strlen (length string)) |
|---|
| 725 | (when (minusp (float-sign float)) |
|---|
| 726 | (stream-write-char stream #\-)) |
|---|
| 727 | (cond |
|---|
| 728 | ((and (not exp-p) (zerop strlen)) |
|---|
| 729 | (stream-write-entire-string stream "0.0")) |
|---|
| 730 | ((and (> before-pt 0)(<= before-pt 7)(not exp-p)) |
|---|
| 731 | (cond ((> strlen before-pt) |
|---|
| 732 | (write-string string stream :start 0 :end before-pt) |
|---|
| 733 | (stream-write-char stream #\.) |
|---|
| 734 | (write-string string stream :start before-pt :end strlen)) |
|---|
| 735 | (t ; 0's after |
|---|
| 736 | (stream-write-entire-string stream string) |
|---|
| 737 | (dotimes (i (- before-pt strlen)) |
|---|
| 738 | (stream-write-char stream #\0)) |
|---|
| 739 | (stream-write-entire-string stream ".0")))) |
|---|
| 740 | ((and (> before-pt -3)(<= before-pt 0)(not exp-p)) |
|---|
| 741 | (stream-write-entire-string stream "0.") |
|---|
| 742 | (dotimes (i (- before-pt)) |
|---|
| 743 | (stream-write-char stream #\0)) |
|---|
| 744 | (stream-write-entire-string stream string)) |
|---|
| 745 | (t |
|---|
| 746 | (setq exp-p t) |
|---|
| 747 | (stream-write-char stream (if (> strlen 0)(char string 0) #\0)) |
|---|
| 748 | (stream-write-char stream #\.) |
|---|
| 749 | (if (> strlen 1) |
|---|
| 750 | (write-string string stream :start 1 :end strlen) |
|---|
| 751 | (stream-write-char stream #\0)) |
|---|
| 752 | (stream-write-char stream exponent-char) |
|---|
| 753 | (when (and exp-p (not (minusp (1- before-pt)))) |
|---|
| 754 | (stream-write-char stream #\+)) |
|---|
| 755 | (let ((*print-base* 10) |
|---|
| 756 | (*print-radix* nil)) |
|---|
| 757 | (princ (1- before-pt) stream)))) |
|---|
| 758 | (when (and (not exp-p) |
|---|
| 759 | (not (default-float-p float))) |
|---|
| 760 | (stream-write-char stream exponent-char) |
|---|
| 761 | (stream-write-char stream #\0)))))) |
|---|
| 762 | |
|---|
| 763 | ;;>> Doesn't do *print-level* truncation |
|---|
| 764 | (defmethod print-object ((class class) stream) |
|---|
| 765 | (print-unreadable-object (class stream) |
|---|
| 766 | (print-object (class-name (class-of class)) stream) |
|---|
| 767 | (pp-space stream) |
|---|
| 768 | (print-object (class-name class) stream))) |
|---|
| 769 | |
|---|
| 770 | |
|---|
| 771 | (defmethod print-object ((value-cell value-cell) stream) |
|---|
| 772 | (print-unreadable-object (value-cell stream :type t :identity t) |
|---|
| 773 | (prin1 (uvref value-cell target::value-cell.value-cell) stream))) |
|---|
| 774 | |
|---|
| 775 | ;(defun symbol-begins-with-vowel-p (sym) |
|---|
| 776 | ; (and (symbolp sym) |
|---|
| 777 | ; (not (%izerop (%str-length (setq sym (symbol-name sym))))) |
|---|
| 778 | ; (%str-member (schar sym 0) "AEIOU"))) |
|---|
| 779 | |
|---|
| 780 | ;;;; ---------------------------------------------------------------------- |
|---|
| 781 | ;;;; CLOSsage |
|---|
| 782 | |
|---|
| 783 | (defmethod print-object ((instance standard-object) stream) |
|---|
| 784 | (if (%i<= %current-write-level% 0) ; *print-level* truncation |
|---|
| 785 | (stream-write-entire-string stream "#") |
|---|
| 786 | (print-unreadable-object (instance stream :identity t) |
|---|
| 787 | (let* ((class (class-of instance)) |
|---|
| 788 | (class-name (class-name class))) |
|---|
| 789 | (cond ((not (and (symbolp class-name) |
|---|
| 790 | (eq class (find-class class-name nil)))) |
|---|
| 791 | (%write-string "An instance of" stream) |
|---|
| 792 | (pp-space stream) |
|---|
| 793 | (print-object class stream)) |
|---|
| 794 | (t |
|---|
| 795 | (write-a-symbol class-name stream))))))) |
|---|
| 796 | |
|---|
| 797 | (defmethod print-object ((method standard-method) stream) |
|---|
| 798 | (print-method method stream (%class.name (class-of method)))) |
|---|
| 799 | |
|---|
| 800 | (defmethod print-object ((method-function method-function) stream) |
|---|
| 801 | (let ((method (%method-function-method method-function))) |
|---|
| 802 | (if (typep method 'standard-method) |
|---|
| 803 | (print-method (%method-function-method method-function) |
|---|
| 804 | stream |
|---|
| 805 | (%class.name (class-of method-function))) |
|---|
| 806 | (call-next-method)))) |
|---|
| 807 | |
|---|
| 808 | |
|---|
| 809 | |
|---|
| 810 | (defun print-method (method stream type-string) |
|---|
| 811 | (print-unreadable-object (method stream) |
|---|
| 812 | (let ((name (%method-name method)) |
|---|
| 813 | (qualifiers (%method-qualifiers method)) |
|---|
| 814 | (specializers (mapcar #'(lambda (specializer) |
|---|
| 815 | (if (typep specializer 'eql-specializer) |
|---|
| 816 | (list 'eql |
|---|
| 817 | (eql-specializer-object specializer)) |
|---|
| 818 | (or (class-name specializer) |
|---|
| 819 | specializer))) |
|---|
| 820 | (%method-specializers method))) |
|---|
| 821 | (level-1 (%i- %current-write-level% 1))) |
|---|
| 822 | (cond |
|---|
| 823 | ((< level-1 0) |
|---|
| 824 | ;; *print-level* truncation |
|---|
| 825 | (stream-write-entire-string stream "#")) |
|---|
| 826 | (t |
|---|
| 827 | (prin1 type-string stream) |
|---|
| 828 | (pp-space stream) |
|---|
| 829 | (write-internal stream name level-1 nil) |
|---|
| 830 | (pp-space stream) |
|---|
| 831 | (when qualifiers |
|---|
| 832 | (write-internal stream (if (cdr qualifiers) qualifiers (car qualifiers)) |
|---|
| 833 | level-1 nil) |
|---|
| 834 | (pp-space stream)) |
|---|
| 835 | (write-internal stream specializers level-1 nil)))))) |
|---|
| 836 | |
|---|
| 837 | ;; Need this stub or we'll get the standard-object method |
|---|
| 838 | (defmethod print-object ((gf standard-generic-function) stream) |
|---|
| 839 | (write-a-function gf stream (%current-write-level% stream))) |
|---|
| 840 | |
|---|
| 841 | ;; This shouldn't ever happen, but if it does, don't want the standard-object method |
|---|
| 842 | (defmethod print-object ((mo metaobject) stream) |
|---|
| 843 | (print-unreadable-object (mo stream :type t :identity t))) |
|---|
| 844 | |
|---|
| 845 | (defmethod print-object ((cm combined-method) stream) |
|---|
| 846 | (print-unreadable-object (cm stream :identity t) |
|---|
| 847 | (%write-string "Combined-Method" stream) |
|---|
| 848 | (pp-space stream) |
|---|
| 849 | (let ((name (function-name cm))) |
|---|
| 850 | (if (and (functionp name) (function-is-current-definition? name)) |
|---|
| 851 | (setq name (function-name name))) |
|---|
| 852 | (write-internal stream name (%current-write-level% stream) nil)))) |
|---|
| 853 | |
|---|
| 854 | (defun print-specializer-names (specializers stream) |
|---|
| 855 | (flet ((print-specializer (spec stream) |
|---|
| 856 | (write-1 (if (typep spec 'class) (%class.name spec) spec) stream))) |
|---|
| 857 | (pp-start-block stream #\() |
|---|
| 858 | (if (atom specializers) |
|---|
| 859 | (print-specializer specializers stream) |
|---|
| 860 | (progn (print-specializer (car specializers) stream) |
|---|
| 861 | (dolist (spec (cdr specializers)) |
|---|
| 862 | (pp-space stream) |
|---|
| 863 | (print-specializer spec stream)))) |
|---|
| 864 | (pp-end-block stream #\)))) |
|---|
| 865 | |
|---|
| 866 | |
|---|
| 867 | ;;;; ---------------------------------------------------------------------- |
|---|
| 868 | |
|---|
| 869 | (defun write-a-cons (cons stream level) |
|---|
| 870 | (declare (type cons cons) (type stream stream) (type fixnum level)) |
|---|
| 871 | (let ((print-length (get-*print-frob* '*print-length*)) |
|---|
| 872 | (level-1 (%i- level 1)) |
|---|
| 873 | (head (%car cons)) |
|---|
| 874 | (tail (%cdr cons))) |
|---|
| 875 | (declare (type fixnum print-length) (type fixnum level-1)) |
|---|
| 876 | (unless (and *print-abbreviate-quote* |
|---|
| 877 | (write-abbreviate-quote head tail stream level-1)) |
|---|
| 878 | (progn |
|---|
| 879 | (pp-start-block stream #\() |
|---|
| 880 | (if (= print-length 0) |
|---|
| 881 | (%write-string "..." stream) |
|---|
| 882 | (progn |
|---|
| 883 | (write-internal stream head level-1 nil) |
|---|
| 884 | (write-internal stream tail level-1 |
|---|
| 885 | (if (atom tail) |
|---|
| 886 | print-length |
|---|
| 887 | (%i- print-length 1))))) |
|---|
| 888 | (pp-end-block stream #\)))))) |
|---|
| 889 | |
|---|
| 890 | ;;;; hack for quote and backquote |
|---|
| 891 | |
|---|
| 892 | ;; for debugging |
|---|
| 893 | ;(setq *backquote-expand* nil) |
|---|
| 894 | |
|---|
| 895 | (defvar *backquote-hack* (list '*backquote-hack*)) ;uid |
|---|
| 896 | (defun write-abbreviate-quote (head tail stream level-1) |
|---|
| 897 | (declare (type stream stream) (type fixnum level-1)) |
|---|
| 898 | (when (symbolp head) |
|---|
| 899 | (cond ((or (eq head 'quote) (eq head 'function)) |
|---|
| 900 | (when (and (consp tail) |
|---|
| 901 | (null (%cdr tail))) |
|---|
| 902 | (%write-string (if (eq head 'function) "#'" "'") stream) |
|---|
| 903 | (write-internal stream (%car tail) level-1 nil) |
|---|
| 904 | t)) |
|---|
| 905 | ((eq head 'backquote-expander) |
|---|
| 906 | (when (and (consp tail) |
|---|
| 907 | (consp (cdr tail)) |
|---|
| 908 | (consp (cddr tail)) |
|---|
| 909 | (consp (cdddr tail)) |
|---|
| 910 | (null (cddddr tail))) |
|---|
| 911 | (let ((tail tail)) |
|---|
| 912 | (set (%car tail) |
|---|
| 913 | *backquote-hack*) ;, |
|---|
| 914 | (set (%car (setq tail (%cdr tail))) |
|---|
| 915 | *backquote-hack*) ;,. |
|---|
| 916 | (set (%car (setq tail (%cdr tail))) |
|---|
| 917 | *backquote-hack*) ;,@ |
|---|
| 918 | (stream-write-char stream #\`) |
|---|
| 919 | (write-internal stream (%cadr tail) level-1 nil) |
|---|
| 920 | t))) |
|---|
| 921 | ((and (boundp head) |
|---|
| 922 | (eq (symbol-value head) *backquote-hack*)) |
|---|
| 923 | ;;",foo" = (#:|,| . foo) |
|---|
| 924 | (stream-write-char stream #\,) |
|---|
| 925 | (let* ((n (symbol-name head)) |
|---|
| 926 | (l (length n))) |
|---|
| 927 | (declare (type simple-string n) (type fixnum l)) |
|---|
| 928 | ;; possibilities are #:|`,| #:|,.| and #:|,@| |
|---|
| 929 | (if (eql l 3) |
|---|
| 930 | (stream-write-char stream (schar n 2))) |
|---|
| 931 | (write-internal stream tail level-1 nil) |
|---|
| 932 | t)) |
|---|
| 933 | (t nil)))) |
|---|
| 934 | |
|---|
| 935 | (eval-when (compile eval) |
|---|
| 936 | (defmacro %char-needs-escape-p (char escape &rest losers) |
|---|
| 937 | (setq losers (remove-duplicates (cons escape losers))) |
|---|
| 938 | (setq char (require-type char 'symbol)) |
|---|
| 939 | (dolist (c losers) |
|---|
| 940 | (unless (or (characterp c) (symbolp c)) (report-bad-arg c '(or character symbol)))) |
|---|
| 941 | (cond ((null (cdr losers)) |
|---|
| 942 | `(eq ,char ,escape)) |
|---|
| 943 | ((and (every #'characterp losers) |
|---|
| 944 | ;(every #'string-char-p losers) |
|---|
| 945 | (%i> (length losers) 2)) |
|---|
| 946 | `(%str-member ,char ,(concatenate 'string losers))) |
|---|
| 947 | (t |
|---|
| 948 | `(or ,@(mapcar #'(lambda (e) `(eq ,char ,e)) |
|---|
| 949 | losers))))) |
|---|
| 950 | |
|---|
| 951 | (defmacro %write-escaped-char (stream char escape &rest losers) |
|---|
| 952 | `(progn |
|---|
| 953 | (when (%char-needs-escape-p ,char ,escape ,@losers) |
|---|
| 954 | (stream-write-char ,stream ,escape)) |
|---|
| 955 | (stream-write-char ,stream ,char))) |
|---|
| 956 | ) |
|---|
| 957 | |
|---|
| 958 | (defun write-escaped-string (string stream &optional (delim #\")) |
|---|
| 959 | (declare (type string string) (type character delim) |
|---|
| 960 | (type stream stream)) |
|---|
| 961 | (write-char delim stream) |
|---|
| 962 | (do* ((limit (length string)) |
|---|
| 963 | (i 0 (1+ i))) |
|---|
| 964 | ((= i limit)) |
|---|
| 965 | (declare (type fixnum limit) (type fixnum i)) |
|---|
| 966 | (let* ((char (char string i)) |
|---|
| 967 | (needs-escape? (%char-needs-escape-p char #\\ delim))) |
|---|
| 968 | (if needs-escape? |
|---|
| 969 | (write-char #\\ stream)) |
|---|
| 970 | (write-char char stream))) |
|---|
| 971 | (write-char delim stream)) |
|---|
| 972 | |
|---|
| 973 | |
|---|
| 974 | ;;;; ---------------------------------------------------------------------- |
|---|
| 975 | ;;;; printing symbols |
|---|
| 976 | |
|---|
| 977 | (defun get-*print-case* () |
|---|
| 978 | (let ((case *print-case*)) |
|---|
| 979 | (unless (or (eq case ':upcase) (eq case ':downcase) |
|---|
| 980 | (eq case ':capitalize) (eq case ':studly)) |
|---|
| 981 | (setq *print-case* ':upcase) |
|---|
| 982 | (error "~S had illegal value ~S. Reset to ~S" |
|---|
| 983 | '*print-case* case ':upcase)) |
|---|
| 984 | case)) |
|---|
| 985 | |
|---|
| 986 | (defun write-a-symbol (symbol stream) |
|---|
| 987 | (declare (type symbol symbol) (type stream stream)) |
|---|
| 988 | (let ((case (get-*print-case*)) |
|---|
| 989 | (name (symbol-name symbol)) |
|---|
| 990 | (package (symbol-package symbol))) |
|---|
| 991 | (declare (type simple-string name)) |
|---|
| 992 | (when (or *print-readably* *print-escape*) |
|---|
| 993 | (cond ((keywordp symbol) |
|---|
| 994 | (stream-write-char stream #\:)) |
|---|
| 995 | ((null package) |
|---|
| 996 | (when (or *print-readably* *print-gensym*) |
|---|
| 997 | (stream-write-char stream #\#) |
|---|
| 998 | (stream-write-char stream #\:))) |
|---|
| 999 | (t |
|---|
| 1000 | (multiple-value-bind (s flag) |
|---|
| 1001 | (find-symbol name *package*) |
|---|
| 1002 | (unless (and flag (eq s symbol)) |
|---|
| 1003 | (multiple-value-setq (s flag) |
|---|
| 1004 | (find-symbol name package)) |
|---|
| 1005 | (unless (and flag (eq s symbol)) |
|---|
| 1006 | (%write-string "#|symbol not found in home package!!|#" |
|---|
| 1007 | stream)) |
|---|
| 1008 | (write-pname (package-name package) case stream) |
|---|
| 1009 | (stream-write-char stream #\:) |
|---|
| 1010 | (unless (eq flag ':external) |
|---|
| 1011 | (stream-write-char stream #\:))))))) |
|---|
| 1012 | (write-pname name case stream))) |
|---|
| 1013 | |
|---|
| 1014 | |
|---|
| 1015 | |
|---|
| 1016 | (defun write-pname (name case stream) |
|---|
| 1017 | (declare (type simple-string name) (stream stream) |
|---|
| 1018 | (optimize (speed 3)(safety 0))) |
|---|
| 1019 | (let* ((readtable *readtable*) |
|---|
| 1020 | (readcase (readtable-case (if *print-readably* |
|---|
| 1021 | %initial-readtable% |
|---|
| 1022 | readtable))) |
|---|
| 1023 | (escape? (or *print-readably* *print-escape*))) |
|---|
| 1024 | (flet ((slashify? (char) |
|---|
| 1025 | (declare (type character char)) |
|---|
| 1026 | (and escape? |
|---|
| 1027 | (if (alpha-char-p char) |
|---|
| 1028 | (if (eq readcase :upcase) |
|---|
| 1029 | (lower-case-p char) ; _tolower |
|---|
| 1030 | (if (eq readcase :downcase) |
|---|
| 1031 | (upper-case-p char))) |
|---|
| 1032 | ; should be using readtable here - but (get-macro-character #\|) is nil |
|---|
| 1033 | (not (%str-member |
|---|
| 1034 | char |
|---|
| 1035 | "!$%&*0123456789.<=>?@[]^_{}~+-/"))))) |
|---|
| 1036 | (single-case-p (name) |
|---|
| 1037 | (let ((sofar nil)) |
|---|
| 1038 | (dotimes (i (length name) sofar) |
|---|
| 1039 | (declare (type fixnum i)) |
|---|
| 1040 | (declare (type simple-string name)) |
|---|
| 1041 | (let* ((c (schar name i)) |
|---|
| 1042 | (c-case (if (upper-case-p c) |
|---|
| 1043 | :upcase |
|---|
| 1044 | (if (lower-case-p c) |
|---|
| 1045 | :downcase)))) |
|---|
| 1046 | (when c-case |
|---|
| 1047 | (if sofar |
|---|
| 1048 | (if (neq sofar c-case) |
|---|
| 1049 | (return nil)) |
|---|
| 1050 | (setq sofar c-case)))))))) |
|---|
| 1051 | (declare (dynamic-extent #'slashify? #'single-case-p)) |
|---|
| 1052 | (block alice |
|---|
| 1053 | (let ((len (length name)) |
|---|
| 1054 | (slash-count 0) |
|---|
| 1055 | (last-slash-pos 0)) |
|---|
| 1056 | (declare (type fixnum len) |
|---|
| 1057 | (type fixnum slash-count last-slash-pos)) |
|---|
| 1058 | (when escape? |
|---|
| 1059 | (when (or (%izerop len) |
|---|
| 1060 | ;; if more than a few \, just use |...| |
|---|
| 1061 | (and (not (memq readcase '(:invert :preserve))) ; these never slashify alpha-p |
|---|
| 1062 | (let ((m (max (floor len 4) 2))) |
|---|
| 1063 | (dotimes (i (the fixnum len) nil) |
|---|
| 1064 | (declare (type fixnum i)) |
|---|
| 1065 | (when (slashify? (schar name i)) |
|---|
| 1066 | (setq slash-count (%i+ slash-count 1)) |
|---|
| 1067 | (when (or (eql slash-count m) |
|---|
| 1068 | (eq i (1+ last-slash-pos))) |
|---|
| 1069 | (return t)) |
|---|
| 1070 | (setq last-slash-pos i))))) |
|---|
| 1071 | ;; or could be read as a number |
|---|
| 1072 | (%parse-number-token name 0 len *print-base*) |
|---|
| 1073 | ;; or symbol consisting entirely of .'s |
|---|
| 1074 | (dotimes (i len t) |
|---|
| 1075 | (declare (fixnum i)) |
|---|
| 1076 | (unless (eql (schar name i) #\.) |
|---|
| 1077 | (return nil)))) |
|---|
| 1078 | (return-from alice |
|---|
| 1079 | (write-escaped-string name stream #\|)))) |
|---|
| 1080 | (case readcase |
|---|
| 1081 | (:preserve (return-from alice (write-string name stream :start 0 :end len))) |
|---|
| 1082 | (:invert (return-from alice |
|---|
| 1083 | (cond ((single-case-p name)(write-perverted-string name stream len :invert)) |
|---|
| 1084 | (t (write-string name stream :start 0 :end len))))) |
|---|
| 1085 | (t |
|---|
| 1086 | (when (eql slash-count 0) |
|---|
| 1087 | (return-from alice |
|---|
| 1088 | (cond ((eq readcase case) |
|---|
| 1089 | (write-string name stream :start 0 :end len)) |
|---|
| 1090 | (t (write-perverted-string name stream len case))))))) |
|---|
| 1091 | (let* ((outbuf-len (+ len len)) |
|---|
| 1092 | (outbuf-ptr -1) |
|---|
| 1093 | (outbuf (make-string outbuf-len))) |
|---|
| 1094 | (declare (fixnum outbuf-ptr outbuf-len) |
|---|
| 1095 | (dynamic-extent outbuf) |
|---|
| 1096 | (simple-string outbuf)) |
|---|
| 1097 | (dotimes (pos (the fixnum len)) |
|---|
| 1098 | (declare (type fixnum pos)) |
|---|
| 1099 | (let* ((char (schar name pos)) |
|---|
| 1100 | (slashify? (cond ((eql slash-count 0) |
|---|
| 1101 | nil) |
|---|
| 1102 | ((eql slash-count 1) |
|---|
| 1103 | (eql pos last-slash-pos)) |
|---|
| 1104 | (t |
|---|
| 1105 | (slashify? char))))) |
|---|
| 1106 | (declare (type character char)) |
|---|
| 1107 | (when slashify? |
|---|
| 1108 | (setq slash-count (%i- slash-count 1)) |
|---|
| 1109 | (setf (schar outbuf (incf outbuf-ptr)) #\\)) |
|---|
| 1110 | (setf (schar outbuf (incf outbuf-ptr)) char))) |
|---|
| 1111 | (write-string outbuf stream :start 0 :end (1+ outbuf-ptr)))))))) |
|---|
| 1112 | |
|---|
| 1113 | #| |
|---|
| 1114 | (defun write-studly-string (string stream) |
|---|
| 1115 | (declare (type string string) (stream stream)) |
|---|
| 1116 | (let* ((offset 0) |
|---|
| 1117 | (end (length string)) |
|---|
| 1118 | (pool *pname-buffer*) |
|---|
| 1119 | (outbuf-ptr -1) |
|---|
| 1120 | (outbuf (pool.data pool))) |
|---|
| 1121 | (declare (fixnum offset end outbuf-ptr)) |
|---|
| 1122 | (setf (pool.data pool) nil) |
|---|
| 1123 | (unless (and outbuf (>= (length outbuf) end)) |
|---|
| 1124 | (setq outbuf (make-array end :element-type 'character))) |
|---|
| 1125 | (do ((i 0 (%i+ i 1))) |
|---|
| 1126 | ((%i>= i end)) |
|---|
| 1127 | (declare (type fixnum i)) |
|---|
| 1128 | (setq offset (%i+ offset (char-int (char string i))))) |
|---|
| 1129 | (do ((i 0 (%i+ i 1))) |
|---|
| 1130 | ((%i>= i end)) |
|---|
| 1131 | (declare (type fixnum i)) |
|---|
| 1132 | (let ((c (char string i))) |
|---|
| 1133 | (declare (type character c)) |
|---|
| 1134 | (cond ((not (and (%i< (%ilogand2 |
|---|
| 1135 | (%i+ (char-int c) offset) |
|---|
| 1136 | 15.) |
|---|
| 1137 | 6.) |
|---|
| 1138 | (alpha-char-p c)))) |
|---|
| 1139 | ((upper-case-p c) |
|---|
| 1140 | (setq c (char-downcase c))) |
|---|
| 1141 | (t |
|---|
| 1142 | (setq c (char-upcase c)))) |
|---|
| 1143 | (setf (schar outbuf (incf outbuf-ptr)) c))) |
|---|
| 1144 | (write-string outbuf stream :start 0 :end end) |
|---|
| 1145 | (setf (pool.data pool) outbuf))) |
|---|
| 1146 | |# |
|---|
| 1147 | |
|---|
| 1148 | (defun write-perverted-string (string stream end type) |
|---|
| 1149 | ; type :invert :upcase :downcase :capitalize or :studly |
|---|
| 1150 | (declare (fixnum end)) |
|---|
| 1151 | (let* ((readtable *readtable*) |
|---|
| 1152 | (readcase (readtable-case readtable)) |
|---|
| 1153 | (outbuf-ptr -1) |
|---|
| 1154 | (outbuf (make-string end)) |
|---|
| 1155 | (word-start t) |
|---|
| 1156 | (offset 0)) |
|---|
| 1157 | (declare (fixnum offset outbuf-ptr) |
|---|
| 1158 | (dynamic-extent outbuf)) |
|---|
| 1159 | (when (eq type :studly) |
|---|
| 1160 | (do ((i 0 (%i+ i 1))) |
|---|
| 1161 | ((%i>= i end)) |
|---|
| 1162 | (declare (type fixnum i)) |
|---|
| 1163 | (setq offset (%i+ offset (char-int (char string i)))))) |
|---|
| 1164 | (do ((i 0 (%i+ i 1))) |
|---|
| 1165 | ((%i>= i end)) |
|---|
| 1166 | (declare (type fixnum i)) |
|---|
| 1167 | (let ((c (char string i))) |
|---|
| 1168 | (declare (type character c)) |
|---|
| 1169 | (cond ((alpha-char-p c) |
|---|
| 1170 | (case type |
|---|
| 1171 | (:studly |
|---|
| 1172 | (cond ((not (%i< (%ilogand2 |
|---|
| 1173 | (%i+ (char-int c) offset) |
|---|
| 1174 | 15.) |
|---|
| 1175 | 6.))) |
|---|
| 1176 | ((upper-case-p c) |
|---|
| 1177 | (setq c (char-downcase c))) |
|---|
| 1178 | (t |
|---|
| 1179 | (setq c (char-upcase c))))) |
|---|
| 1180 | (:invert |
|---|
| 1181 | (setq c (if (upper-case-p c)(char-downcase c)(char-upcase c)))) |
|---|
| 1182 | (:upcase |
|---|
| 1183 | (setq c (char-upcase c))) |
|---|
| 1184 | (:downcase |
|---|
| 1185 | (setq c (char-downcase c))) |
|---|
| 1186 | (:capitalize (setq c (cond (word-start |
|---|
| 1187 | (setq word-start nil) |
|---|
| 1188 | (if (eq readcase :upcase) |
|---|
| 1189 | c |
|---|
| 1190 | (char-upcase c))) |
|---|
| 1191 | (t |
|---|
| 1192 | (if (eq readcase :upcase) |
|---|
| 1193 | (char-downcase c) |
|---|
| 1194 | c))))))) |
|---|
| 1195 | ((digit-char-p c)(setq word-start nil)) |
|---|
| 1196 | (t (setq word-start t))) |
|---|
| 1197 | (setf (schar outbuf (incf outbuf-ptr)) c))) |
|---|
| 1198 | (write-string outbuf stream :start 0 :end end))) |
|---|
| 1199 | |
|---|
| 1200 | |
|---|
| 1201 | ;;;; ---------------------------------------------------------------------- |
|---|
| 1202 | ;;;; printing arrays |
|---|
| 1203 | |
|---|
| 1204 | ;; *print-array* |
|---|
| 1205 | ;; *print-simple-vector* |
|---|
| 1206 | ;; *print-simple-bit-vector* |
|---|
| 1207 | ;; *print-string-length* |
|---|
| 1208 | |
|---|
| 1209 | (defun array-readably-printable-p (array) |
|---|
| 1210 | (let ((dims (array-dimensions array))) |
|---|
| 1211 | (and (eq (array-element-type array) t) |
|---|
| 1212 | (let ((zero (position 0 dims)) |
|---|
| 1213 | (number (position 0 dims |
|---|
| 1214 | :test (complement #'eql) |
|---|
| 1215 | :from-end t))) |
|---|
| 1216 | (or (null zero) (null number) (> zero number)))))) |
|---|
| 1217 | |
|---|
| 1218 | (defun write-an-array (array stream level) |
|---|
| 1219 | (declare (type array array) (type stream stream) (type fixnum level)) |
|---|
| 1220 | (let* ((rank (array-rank array)) |
|---|
| 1221 | (vector? (eql rank 1)) |
|---|
| 1222 | (simple? (simple-array-p array)) |
|---|
| 1223 | (simple-vector? (simple-vector-p array)) |
|---|
| 1224 | ;; non-*print-string-length*-truncated strings are printed by |
|---|
| 1225 | ;; write-a-frob |
|---|
| 1226 | (string? (stringp array)) |
|---|
| 1227 | (bit-vector? (bit-vector-p array)) |
|---|
| 1228 | (fill-pointer? (array-has-fill-pointer-p array)) |
|---|
| 1229 | (adjustable? (adjustable-array-p array)) |
|---|
| 1230 | (displaced? (displaced-array-p array)) |
|---|
| 1231 | (total-size (array-total-size array)) |
|---|
| 1232 | (length (and vector? (length array))) |
|---|
| 1233 | (print-length (get-*print-frob* '*print-length*)) |
|---|
| 1234 | (print-array (get-*print-frob* '*print-array* nil t))) |
|---|
| 1235 | (declare (type fixnum rank) (type fixnum total-size) |
|---|
| 1236 | (type fixnum print-length)) |
|---|
| 1237 | (unless |
|---|
| 1238 | (cond (string? |
|---|
| 1239 | nil) |
|---|
| 1240 | ((and bit-vector? print-array) |
|---|
| 1241 | (stream-write-char stream #\#) (stream-write-char stream #\*) |
|---|
| 1242 | (do ((i 0 (%i+ i 1)) |
|---|
| 1243 | (l print-length (%i- l 1))) |
|---|
| 1244 | (nil) |
|---|
| 1245 | (declare (type fixnum i) (type fixnum l)) |
|---|
| 1246 | (cond ((eql i length) |
|---|
| 1247 | (return)) |
|---|
| 1248 | (t |
|---|
| 1249 | (stream-write-char stream (if (eql (bit array i) 0) #\0 #\1))))) |
|---|
| 1250 | t) |
|---|
| 1251 | ((and *print-readably* |
|---|
| 1252 | (not (array-readably-printable-p array))) |
|---|
| 1253 | nil) |
|---|
| 1254 | ((and *print-pretty* print-array) |
|---|
| 1255 | (let ((*current-level* (if (and *print-level* (not *print-readably*)) |
|---|
| 1256 | (- *print-level* level) |
|---|
| 1257 | 0))) |
|---|
| 1258 | (pretty-array stream array)) |
|---|
| 1259 | t) |
|---|
| 1260 | (vector? |
|---|
| 1261 | (when (or print-array |
|---|
| 1262 | (and simple-vector? |
|---|
| 1263 | (%i<= length (get-*print-frob* |
|---|
| 1264 | '*print-simple-vector* |
|---|
| 1265 | 0 |
|---|
| 1266 | target::target-most-positive-fixnum)))) |
|---|
| 1267 | (pp-start-block stream "#(") |
|---|
| 1268 | (do ((i 0 (%i+ i 1)) |
|---|
| 1269 | (l print-length (%i- l 1))) |
|---|
| 1270 | (nil) |
|---|
| 1271 | (declare (type fixnum i) (type fixnum l)) |
|---|
| 1272 | (cond ((eql i length) |
|---|
| 1273 | (return)) |
|---|
| 1274 | ((eql l 0) |
|---|
| 1275 | ;; can't use write-abbreviation since there is |
|---|
| 1276 | ;; no `object' for the abbreviation to represent |
|---|
| 1277 | (unless (eql i 0) (pp-space stream)) |
|---|
| 1278 | (%write-string "..." stream) |
|---|
| 1279 | (return)) |
|---|
| 1280 | (t (unless (eql i 0) (pp-space stream)) |
|---|
| 1281 | (write-internal stream (aref array i) (%i- level 1) nil)))) |
|---|
| 1282 | (pp-end-block stream #\)) |
|---|
| 1283 | t)) |
|---|
| 1284 | ((and print-array (not fill-pointer?)) |
|---|
| 1285 | (let ((rank (array-rank array))) |
|---|
| 1286 | (stream-write-char stream #\#) |
|---|
| 1287 | (%pr-integer rank 10. stream) |
|---|
| 1288 | (stream-write-char stream #\A) |
|---|
| 1289 | (if (eql rank 0) |
|---|
| 1290 | (write-internal stream (aref array) (%i- level 1) nil) |
|---|
| 1291 | (multiple-value-bind (array-data offset) |
|---|
| 1292 | (array-data-and-offset array) |
|---|
| 1293 | (write-array-elements-1 |
|---|
| 1294 | stream level |
|---|
| 1295 | array-data offset |
|---|
| 1296 | (array-dimensions array))))) |
|---|
| 1297 | t) |
|---|
| 1298 | (t |
|---|
| 1299 | ;; fall through -- print randomly |
|---|
| 1300 | nil)) |
|---|
| 1301 | ;; print array using #<...> |
|---|
| 1302 | (print-unreadable-object (array stream) |
|---|
| 1303 | (if vector? |
|---|
| 1304 | (progn |
|---|
| 1305 | (write-a-symbol (cond (simple-vector? |
|---|
| 1306 | 'simple-vector) |
|---|
| 1307 | (string? |
|---|
| 1308 | (if simple? 'simple-string 'string)) |
|---|
| 1309 | (bit-vector? |
|---|
| 1310 | (if simple? 'simple-bit-vector 'bit-vector)) |
|---|
| 1311 | (t 'vector)) |
|---|
| 1312 | stream) |
|---|
| 1313 | (pp-space stream) |
|---|
| 1314 | (%pr-integer total-size 10. stream) |
|---|
| 1315 | (when fill-pointer? |
|---|
| 1316 | (let ((fill-pointer (fill-pointer array))) |
|---|
| 1317 | (declare (fixnum fill-pointer)) |
|---|
| 1318 | (pp-space stream) |
|---|
| 1319 | (%write-string "fill-pointer" stream) |
|---|
| 1320 | (unless (eql fill-pointer total-size) |
|---|
| 1321 | (stream-write-char stream #\space) |
|---|
| 1322 | (%pr-integer fill-pointer 10. stream))))) |
|---|
| 1323 | (progn |
|---|
| 1324 | (write-a-symbol 'array stream) |
|---|
| 1325 | (pp-space stream) |
|---|
| 1326 | (if (eql rank 0) (%write-string "0-dimensional" stream)) |
|---|
| 1327 | (dotimes (i (the fixnum rank)) |
|---|
| 1328 | (unless (eql i 0) (stream-write-char stream #\x)) |
|---|
| 1329 | (%pr-integer (array-dimension array i) 10. stream)))) |
|---|
| 1330 | (let ((type (array-element-type array))) |
|---|
| 1331 | (unless (or simple-vector? string? bit-vector? ; already written "#<string" or whatever |
|---|
| 1332 | (eq type 't)) |
|---|
| 1333 | (pp-space stream) |
|---|
| 1334 | (%write-string "type " stream) |
|---|
| 1335 | (write-internal stream type |
|---|
| 1336 | ;; yes, I mean level, not (1- level) |
|---|
| 1337 | ;; otherwise we end up printing things |
|---|
| 1338 | ;; like "#<array 4 type #>" |
|---|
| 1339 | level nil))) |
|---|
| 1340 | (cond (simple? |
|---|
| 1341 | (unless (or simple-vector? string? bit-vector?) |
|---|
| 1342 | ;; already written "#<simple-xxx" |
|---|
| 1343 | (stream-write-char stream #\,) |
|---|
| 1344 | (pp-space stream) |
|---|
| 1345 | (%write-string "simple" stream))) |
|---|
| 1346 | (adjustable? |
|---|
| 1347 | (stream-write-char stream #\,) |
|---|
| 1348 | (pp-space stream) |
|---|
| 1349 | (%write-string "adjustable" stream)) |
|---|
| 1350 | (displaced? |
|---|
| 1351 | ;; all multidimensional (and adjustable) arrays in ccl are |
|---|
| 1352 | ;; displaced, even when they are simple-array-p |
|---|
| 1353 | (stream-write-char stream #\,) |
|---|
| 1354 | (pp-space stream) |
|---|
| 1355 | (%write-string "displaced" stream))) |
|---|
| 1356 | ;; (when stack-allocated? ...) etc, etc |
|---|
| 1357 | (when (and string? (%i> length 20)) |
|---|
| 1358 | (flet ((foo (stream string start end) |
|---|
| 1359 | (declare (type fixnum start) (type fixnum end) |
|---|
| 1360 | (type string string)) |
|---|
| 1361 | (do ((i start (%i+ i 1))) |
|---|
| 1362 | ((%i>= i end)) |
|---|
| 1363 | (let ((c (char string i))) |
|---|
| 1364 | (declare (type character c)) |
|---|
| 1365 | (if (not (graphic-char-p c)) |
|---|
| 1366 | (return) |
|---|
| 1367 | (%write-escaped-char stream c #\\ #\")))))) |
|---|
| 1368 | #|(%write-string " \"" stream)|# (pp-space stream) |
|---|
| 1369 | (foo stream array 0 12) |
|---|
| 1370 | (%write-string "..." stream) |
|---|
| 1371 | (foo stream array (%i- length 6) length) |
|---|
| 1372 | #|(stream-write-char stream #\")|#)))))) |
|---|
| 1373 | |
|---|
| 1374 | (defun write-array-elements-1 (stream level |
|---|
| 1375 | array-data offset |
|---|
| 1376 | dimensions) |
|---|
| 1377 | (declare (type stream stream) (type fixnum level) |
|---|
| 1378 | (type vector array-data) (type fixnum offset) |
|---|
| 1379 | (type list dimensions)) |
|---|
| 1380 | (block written |
|---|
| 1381 | (let ((tail (%cdr dimensions)) |
|---|
| 1382 | (print-length (get-*print-frob* '*print-length*)) |
|---|
| 1383 | (level-1 (%i- level 1)) |
|---|
| 1384 | (limit (%car dimensions)) |
|---|
| 1385 | (step 1)) |
|---|
| 1386 | (when (and (null tail) |
|---|
| 1387 | (%i> level-1 0) |
|---|
| 1388 | (or (bit-vector-p array-data) |
|---|
| 1389 | (and (stringp array-data) |
|---|
| 1390 | (%i<= limit print-length)))) |
|---|
| 1391 | (return-from written |
|---|
| 1392 | ;;>> cons cons. I was lazy. |
|---|
| 1393 | ;;>> Should code a loop to write the elements instead |
|---|
| 1394 | (write-an-array (%make-displaced-array |
|---|
| 1395 | ;; dimensions displaced-to |
|---|
| 1396 | limit array-data |
|---|
| 1397 | ;; fill-pointer adjustable |
|---|
| 1398 | nil nil |
|---|
| 1399 | ;; displaced-index-offset |
|---|
| 1400 | offset) |
|---|
| 1401 | stream level-1))) |
|---|
| 1402 | (pp-start-block stream #\() |
|---|
| 1403 | (dolist (e tail) (setq step (%i* e step))) |
|---|
| 1404 | (do* ((o offset (%i+ o step)) |
|---|
| 1405 | (i 0 (1+ i))) |
|---|
| 1406 | (nil) |
|---|
| 1407 | (declare (type fixnum o) (type fixnum i) (type fixnum limit) |
|---|
| 1408 | (type fixnum step) (type fixnum print-length) |
|---|
| 1409 | (type fixnum level-1)) |
|---|
| 1410 | (cond ((eql i print-length) |
|---|
| 1411 | (%write-string " ..." stream) |
|---|
| 1412 | (return)) |
|---|
| 1413 | ((eql i limit) |
|---|
| 1414 | (return)) |
|---|
| 1415 | ((= i 0)) |
|---|
| 1416 | (t |
|---|
| 1417 | (pp-space stream (if (null tail) ':fill ':linear)))) |
|---|
| 1418 | (cond ((null tail) |
|---|
| 1419 | (write-internal stream (aref array-data o) level-1 nil)) |
|---|
| 1420 | ((eql level-1 0) |
|---|
| 1421 | ;; can't use write-abbreviation since this doesn't really |
|---|
| 1422 | ;; abbreviate a single object |
|---|
| 1423 | (stream-write-char stream #\#)) |
|---|
| 1424 | (t |
|---|
| 1425 | (write-array-elements-1 stream level-1 |
|---|
| 1426 | array-data o tail)))) |
|---|
| 1427 | (pp-end-block stream #\))))) |
|---|
| 1428 | |
|---|
| 1429 | ;;;; ---------------------------------------------------------------------- |
|---|
| 1430 | |
|---|
| 1431 | ; A "0" in the sd-print-function => inherit from superclass. |
|---|
| 1432 | (defun structure-print-function (class) |
|---|
| 1433 | (let* ((pf (ccl::sd-print-function class)) |
|---|
| 1434 | (supers (cdr (sd-superclasses class)))) |
|---|
| 1435 | (do* () |
|---|
| 1436 | ((neq pf 0) pf) |
|---|
| 1437 | (if supers |
|---|
| 1438 | (setq pf (sd-print-function (gethash (pop supers) %defstructs%))) |
|---|
| 1439 | (return))))) |
|---|
| 1440 | |
|---|
| 1441 | (defun write-a-structure (object stream level) |
|---|
| 1442 | (declare (type stream stream) (type fixnum level)) |
|---|
| 1443 | (let* ((class (ccl::struct-def object)) ;;guaranteed non-NIL if this function is called |
|---|
| 1444 | (pf (structure-print-function class))) |
|---|
| 1445 | (cond (pf |
|---|
| 1446 | (if (consp pf) |
|---|
| 1447 | (funcall (%car pf) object stream) |
|---|
| 1448 | (funcall pf |
|---|
| 1449 | object stream (backtranslate-level level)))) |
|---|
| 1450 | ((and (not *print-structure*) (not *print-readably*)) |
|---|
| 1451 | (print-unreadable-object (object stream :identity t) |
|---|
| 1452 | (write-a-symbol (ccl::sd-name class) stream))) |
|---|
| 1453 | (t |
|---|
| 1454 | (let ((level-1 (ccl::%i- level 1)) |
|---|
| 1455 | (slots (cdr (ccl::sd-slots class))) |
|---|
| 1456 | (print-length (get-*print-frob* '*print-length*))) |
|---|
| 1457 | (declare (type fixnum level-1) (type list slots)) |
|---|
| 1458 | (%write-string "#S(" stream) |
|---|
| 1459 | (if (%i> print-length 0) |
|---|
| 1460 | (write-a-symbol (ccl::sd-name class) stream) |
|---|
| 1461 | (progn (%write-string "...)" stream) |
|---|
| 1462 | (return-from write-a-structure))) |
|---|
| 1463 | (when (and slots (%i> print-length 1)) |
|---|
| 1464 | (pp-start-block stream #\Space)) |
|---|
| 1465 | (do ((l (%i- print-length 1) (%i- l 2)) |
|---|
| 1466 | (first? t) |
|---|
| 1467 | (print-case (get-*print-case*))) |
|---|
| 1468 | (nil) |
|---|
| 1469 | (declare (type fixnum l)) |
|---|
| 1470 | (cond ((null slots) |
|---|
| 1471 | (return)) |
|---|
| 1472 | ((%i< l 1) |
|---|
| 1473 | ;; Note write-abbreviation since it isn't abbreviating an object |
|---|
| 1474 | (%write-string " ..." stream) |
|---|
| 1475 | (return))) |
|---|
| 1476 | (let* ((slot (prog1 (%car slots) |
|---|
| 1477 | (setq slots (%cdr slots)))) |
|---|
| 1478 | (symbol (ccl::ssd-name slot))) |
|---|
| 1479 | (when (symbolp symbol) |
|---|
| 1480 | (if first? |
|---|
| 1481 | (setq first? nil) |
|---|
| 1482 | (pp-space stream ':linear)) |
|---|
| 1483 | (stream-write-char stream #\:) |
|---|
| 1484 | (write-pname (symbol-name symbol) print-case stream) |
|---|
| 1485 | (cond ((%i> l 1) |
|---|
| 1486 | (pp-space stream) |
|---|
| 1487 | (write-internal stream (uvref object (ccl::ssd-offset slot)) |
|---|
| 1488 | level-1 nil)) |
|---|
| 1489 | (t (%write-string " ..." stream) |
|---|
| 1490 | (return))))))) |
|---|
| 1491 | (pp-end-block stream #\)))))) |
|---|
| 1492 | |
|---|
| 1493 | (%fhave 'encapsulated-function-name ;(fn) ;Redefined in encapsulate |
|---|
| 1494 | (qlfun bootstrapping-encapsulated-function-name (fn) |
|---|
| 1495 | (declare (ignore fn)) |
|---|
| 1496 | nil)) |
|---|
| 1497 | |
|---|
| 1498 | |
|---|
| 1499 | (%fhave '%traced-p ;(fn) ;Redefined in encapsulate |
|---|
| 1500 | (qlfun bootstrapping-%traced-p (fn) |
|---|
| 1501 | (declare (ignore fn)) |
|---|
| 1502 | nil)) |
|---|
| 1503 | |
|---|
| 1504 | (%fhave '%advised-p ;(fn) ;Redefined in encapsulate |
|---|
| 1505 | (qlfun bootstrapping-%advised-p (fn) |
|---|
| 1506 | (declare (ignore fn)) |
|---|
| 1507 | nil)) |
|---|
| 1508 | |
|---|
| 1509 | |
|---|
| 1510 | |
|---|
| 1511 | (defun write-a-function (lfun stream level) ; screwed up |
|---|
| 1512 | (print-unreadable-object (lfun stream :identity t) |
|---|
| 1513 | (let* ((name (function-name lfun)) |
|---|
| 1514 | ; actually combined-method has its oun print-object method and doesn't get here. |
|---|
| 1515 | ; standard-generic-function has a print-object method that just calls this. |
|---|
| 1516 | (gf-or-cm (or (standard-generic-function-p lfun) (combined-method-p lfun)))) |
|---|
| 1517 | (cond ((and (not (compiled-function-p lfun)) |
|---|
| 1518 | (not gf-or-cm)) |
|---|
| 1519 | ; i.e. closures |
|---|
| 1520 | (write-internal stream (%type-of lfun) level nil) |
|---|
| 1521 | (when name |
|---|
| 1522 | (pp-space stream) |
|---|
| 1523 | (write-internal stream name (%i- level 1) nil))) |
|---|
| 1524 | ((not name) |
|---|
| 1525 | (%lfun-name-string lfun stream t)) |
|---|
| 1526 | (t |
|---|
| 1527 | (if gf-or-cm |
|---|
| 1528 | (write-internal stream (class-name (class-of lfun)) level nil) |
|---|
| 1529 | (%write-string (cond ((typep lfun 'method-function) |
|---|
| 1530 | "Compiled Method-function") |
|---|
| 1531 | (t "Compiled-function")) |
|---|
| 1532 | stream)) |
|---|
| 1533 | (stream-write-char stream #\space) |
|---|
| 1534 | (write-internal stream name (%i- level 1) nil) |
|---|
| 1535 | (cond ((and (symbolp name) (eq lfun (macro-function name))) |
|---|
| 1536 | (%write-string " Macroexpander" stream)) ;What better? |
|---|
| 1537 | ((not (function-is-current-definition? lfun)) |
|---|
| 1538 | ;;>> Nice if it could print (Traced), (Internal), (Superseded), etc |
|---|
| 1539 | (cond ((%traced-p name) |
|---|
| 1540 | (%write-string " (Traced Original) " stream)) |
|---|
| 1541 | ((%advised-p name) |
|---|
| 1542 | (%write-string " (Advised Original) " stream)) |
|---|
| 1543 | (t (%write-string " (Non-Global) " stream)))))))))) |
|---|
| 1544 | |
|---|
| 1545 | |
|---|
| 1546 | (defun function-is-current-definition? (function) |
|---|
| 1547 | (let ((name (function-name function))) |
|---|
| 1548 | (and name |
|---|
| 1549 | (valid-function-name-p name) |
|---|
| 1550 | (eq function (fboundp name))))) |
|---|
| 1551 | |
|---|
| 1552 | ;; outputs to stream or returns a string. Barf! |
|---|
| 1553 | ;; Making not matters not worse ... |
|---|
| 1554 | (defun %lfun-name-string (lfun &optional stream suppress-address) |
|---|
| 1555 | (unless (functionp lfun) (report-bad-arg lfun 'function)) |
|---|
| 1556 | (if (null stream) |
|---|
| 1557 | (with-output-to-string (s) (%lfun-name-string lfun s)) |
|---|
| 1558 | (let ((name (function-name lfun))) |
|---|
| 1559 | (if name |
|---|
| 1560 | (prin1 name stream) |
|---|
| 1561 | (let* ((fnaddr (%address-of lfun)) |
|---|
| 1562 | (kernel-function-p (kernel-function-p lfun))) |
|---|
| 1563 | (%write-string (if kernel-function-p |
|---|
| 1564 | "Internal " "Anonymous ") |
|---|
| 1565 | stream) |
|---|
| 1566 | (if (standard-generic-function-p lfun) |
|---|
| 1567 | (prin1 (class-name (class-of lfun)) stream) |
|---|
| 1568 | (%write-string "Function" stream)) |
|---|
| 1569 | (unless suppress-address |
|---|
| 1570 | (stream-write-char stream #\ ) |
|---|
| 1571 | (write-an-integer fnaddr |
|---|
| 1572 | stream 16. t))))))) |
|---|
| 1573 | |
|---|
| 1574 | |
|---|
| 1575 | ;;;; ---------------------------------------------------------------------- |
|---|
| 1576 | |
|---|
| 1577 | (defun write-a-package (pkg stream) |
|---|
| 1578 | (print-unreadable-object (pkg stream) |
|---|
| 1579 | (if (null (pkg.names pkg)) |
|---|
| 1580 | (%write-string "Deleted Package" stream) |
|---|
| 1581 | (progn |
|---|
| 1582 | (%write-string "Package " stream) |
|---|
| 1583 | (write-escaped-string (package-name pkg) stream))))) |
|---|
| 1584 | |
|---|
| 1585 | |
|---|
| 1586 | |
|---|
| 1587 | (defun write-a-macptr (macptr stream) |
|---|
| 1588 | (let* ((null (%null-ptr-p macptr))) |
|---|
| 1589 | (print-unreadable-object (macptr stream) |
|---|
| 1590 | (if null |
|---|
| 1591 | (progn |
|---|
| 1592 | (%write-string "A Null Foreign Pointer" stream)) |
|---|
| 1593 | (progn |
|---|
| 1594 | (pp-start-block stream "A Foreign Pointer") |
|---|
| 1595 | (%write-macptr-allocation-info macptr stream) |
|---|
| 1596 | (stream-write-char stream #\ ) |
|---|
| 1597 | (%write-macptr-type-info macptr stream) |
|---|
| 1598 | (write-an-integer (%ptr-to-int macptr) stream 16. t)))))) |
|---|
| 1599 | |
|---|
| 1600 | (defun %macptr-allocation-string (macptr) |
|---|
| 1601 | (if (or (on-any-csp-stack macptr) |
|---|
| 1602 | (on-any-tsp-stack macptr)) |
|---|
| 1603 | "[stack-allocated]" |
|---|
| 1604 | (if (eql (uvsize macptr) target::xmacptr.element-count) |
|---|
| 1605 | "[gcable]"))) |
|---|
| 1606 | |
|---|
| 1607 | (defun %write-macptr-allocation-info (macptr stream) |
|---|
| 1608 | (let* ((s (%macptr-allocation-string macptr))) |
|---|
| 1609 | (if s (format stream " ~a" s)))) |
|---|
| 1610 | |
|---|
| 1611 | (defun %write-macptr-type-info (macptr stream) |
|---|
| 1612 | (let* ((ordinal (%macptr-type macptr))) |
|---|
| 1613 | (unless (eql 0 ordinal) |
|---|
| 1614 | (let* ((type (gethash ordinal (ftd-ordinal-types *target-ftd*))) |
|---|
| 1615 | (form |
|---|
| 1616 | (if (typep type 'foreign-record-type) |
|---|
| 1617 | `(:* (,(foreign-record-type-kind type) |
|---|
| 1618 | ,(foreign-record-type-name type))) |
|---|
| 1619 | `(:* ,(unparse-foreign-type type))))) |
|---|
| 1620 | (when form (format stream "~s " form)))))) |
|---|
| 1621 | |
|---|
| 1622 | |
|---|
| 1623 | |
|---|
| 1624 | ; This special-casing for wrappers is cheaper than consing a class |
|---|
| 1625 | (defun write-an-istruct (istruct stream level) |
|---|
| 1626 | (let* ((type (istruct-cell-name (uvref istruct 0))) |
|---|
| 1627 | (wrapper-p (eq type 'class-wrapper))) |
|---|
| 1628 | (print-unreadable-object (istruct stream :identity t) |
|---|
| 1629 | (write-internal stream type (%i- level 1) nil) |
|---|
| 1630 | (when wrapper-p |
|---|
| 1631 | (pp-space stream) |
|---|
| 1632 | (print-object (class-name (%wrapper-class istruct)) stream))))) |
|---|
| 1633 | |
|---|
| 1634 | (defun write-a-uvector (uvec stream level) |
|---|
| 1635 | (declare (ignore level)) |
|---|
| 1636 | (print-unreadable-object (uvec stream :identity t :type t))) |
|---|
| 1637 | |
|---|
| 1638 | |
|---|
| 1639 | (defmethod print-object ((slotdef slot-definition) stream) |
|---|
| 1640 | (print-unreadable-object (slotdef stream :identity t :type t) |
|---|
| 1641 | (format stream "for ~a slot ~s" |
|---|
| 1642 | (string-downcase (slot-definition-allocation slotdef)) |
|---|
| 1643 | (standard-slot-definition.name slotdef)))) |
|---|
| 1644 | |
|---|
| 1645 | (defmethod print-object ((spec eql-specializer) stream) |
|---|
| 1646 | (print-unreadable-object (spec stream :identity t :type t) |
|---|
| 1647 | (format stream "~s" (if (slot-boundp spec 'object) |
|---|
| 1648 | (eql-specializer-object spec) |
|---|
| 1649 | "<unbound>")))) |
|---|
| 1650 | |
|---|
| 1651 | |
|---|
| 1652 | (defmethod print-object ((slot-id slot-id) stream) |
|---|
| 1653 | (print-unreadable-object (slot-id stream :identity t :type t) |
|---|
| 1654 | (format stream "for ~s/~d" |
|---|
| 1655 | (slot-id.name slot-id) |
|---|
| 1656 | (slot-id.index slot-id)))) |
|---|
| 1657 | |
|---|
| 1658 | #+x86-target |
|---|
| 1659 | (defmethod print-object ((tra tagged-return-address) stream) |
|---|
| 1660 | (print-unreadable-object (tra stream :identity t :type t) |
|---|
| 1661 | (let* ((f (%return-address-function tra)) |
|---|
| 1662 | (offset (if f (%return-address-offset tra)))) |
|---|
| 1663 | (when offset |
|---|
| 1664 | (format stream "in function ") |
|---|
| 1665 | (%lfun-name-string f stream) |
|---|
| 1666 | (format stream " (+~d)" offset))))) |
|---|
| 1667 | |
|---|
| 1668 | #+x8664-target |
|---|
| 1669 | (defmethod print-object ((sv symbol-vector) stream) |
|---|
| 1670 | (print-unreadable-object (sv stream :identity t :type t) |
|---|
| 1671 | (format stream "for ~s" (%symptr->symbol (%symvector->symptr sv))))) |
|---|
| 1672 | |
|---|
| 1673 | #+x8664-target |
|---|
| 1674 | (defmethod print-object ((fv function-vector) stream) |
|---|
| 1675 | (print-unreadable-object (fv stream :identity t :type t) |
|---|
| 1676 | (format stream "for ") |
|---|
| 1677 | (%lfun-name-string (%function-vector-to-function fv) stream))) |
|---|
| 1678 | |
|---|
| 1679 | (defmethod print-object ((c class-cell) stream) |
|---|
| 1680 | (print-unreadable-object (c stream :type t :identity t) |
|---|
| 1681 | (format stream "for ~s" (class-cell-name c)))) |
|---|
| 1682 | |
|---|
| 1683 | |
|---|
| 1684 | |
|---|
| 1685 | ;;; ====================================================================== |
|---|
| 1686 | |
|---|
| 1687 | |
|---|
| 1688 | (defun real-print-stream (&optional (stream nil)) |
|---|
| 1689 | (cond ((null stream) |
|---|
| 1690 | *standard-output*) |
|---|
| 1691 | ((eq stream t) |
|---|
| 1692 | *terminal-io*) |
|---|
| 1693 | ((streamp stream) |
|---|
| 1694 | stream) |
|---|
| 1695 | ;; This never gets called because streamp is true for xp-structure... |
|---|
| 1696 | ((istruct-typep stream 'xp-structure) |
|---|
| 1697 | (get-xp-stream stream)) |
|---|
| 1698 | (t |
|---|
| 1699 | (report-bad-arg stream '(or stream (member nil t)))))) |
|---|
| 1700 | |
|---|
| 1701 | (defun write-1 (object stream &optional levels-left) |
|---|
| 1702 | (setq stream (%real-print-stream stream)) |
|---|
| 1703 | (when (not levels-left) |
|---|
| 1704 | (setq levels-left |
|---|
| 1705 | (if *current-level* |
|---|
| 1706 | (if *print-level* |
|---|
| 1707 | (- *print-level* *current-level*) |
|---|
| 1708 | target::target-most-positive-fixnum) |
|---|
| 1709 | (%current-write-level% stream t)))) |
|---|
| 1710 | (cond |
|---|
| 1711 | ((< levels-left 0) |
|---|
| 1712 | ;; *print-level* truncation |
|---|
| 1713 | (stream-write-entire-string stream "#")) |
|---|
| 1714 | (t (write-internal stream |
|---|
| 1715 | object |
|---|
| 1716 | (min levels-left target::target-most-positive-fixnum) |
|---|
| 1717 | nil))) |
|---|
| 1718 | object) |
|---|
| 1719 | |
|---|
| 1720 | ;;;; ---------------------------------------------------------------------- |
|---|
| 1721 | ;;;; User-level interface to the printer |
|---|
| 1722 | |
|---|
| 1723 | |
|---|
| 1724 | (defun write (object |
|---|
| 1725 | &key (stream *standard-output*) |
|---|
| 1726 | (escape *print-escape*) |
|---|
| 1727 | (radix *print-radix*) |
|---|
| 1728 | (base *print-base*) |
|---|
| 1729 | (circle *print-circle*) |
|---|
| 1730 | (pretty *print-pretty*) |
|---|
| 1731 | (level *print-level*) |
|---|
| 1732 | (length *print-length*) |
|---|
| 1733 | (case *print-case*) |
|---|
| 1734 | (gensym *print-gensym*) |
|---|
| 1735 | (array *print-array*) |
|---|
| 1736 | (readably *print-readably*) |
|---|
| 1737 | (right-margin *print-right-margin*) |
|---|
| 1738 | (miser-width *print-miser-width*) |
|---|
| 1739 | (lines *print-lines*) |
|---|
| 1740 | (pprint-dispatch *print-pprint-dispatch*) |
|---|
| 1741 | ;;>> Do I really want to add these to WRITE?? |
|---|
| 1742 | (structure *print-structure*) |
|---|
| 1743 | (simple-vector *print-simple-vector*) |
|---|
| 1744 | (simple-bit-vector *print-simple-bit-vector*) |
|---|
| 1745 | (string-length *print-string-length*)) |
|---|
| 1746 | "Output OBJECT to the specified stream, defaulting to *STANDARD-OUTPUT*" |
|---|
| 1747 | (let ((*print-escape* escape) |
|---|
| 1748 | (*print-radix* radix) |
|---|
| 1749 | (*print-base* base) |
|---|
| 1750 | (*print-circle* circle) |
|---|
| 1751 | (*print-pretty* pretty) |
|---|
| 1752 | (*print-level* level) |
|---|
| 1753 | (*print-length* length) |
|---|
| 1754 | (*print-case* case) |
|---|
| 1755 | (*print-gensym* gensym) |
|---|
| 1756 | (*print-array* array) |
|---|
| 1757 | (*print-readably* readably) |
|---|
| 1758 | (*print-right-margin* right-margin) |
|---|
| 1759 | (*print-miser-width* miser-width) |
|---|
| 1760 | (*print-lines* lines) |
|---|
| 1761 | (*print-pprint-dispatch* pprint-dispatch) |
|---|
| 1762 | ;;>> Do I really want to add these to WRITE?? |
|---|
| 1763 | (*print-structure* structure) |
|---|
| 1764 | (*print-simple-vector* simple-vector) |
|---|
| 1765 | (*print-simple-bit-vector* simple-bit-vector) |
|---|
| 1766 | (*print-string-length* string-length)) |
|---|
| 1767 | (write-1 object stream))) |
|---|
| 1768 | |
|---|
| 1769 | (defun write-to-string (object |
|---|
| 1770 | &key (escape *print-escape*) |
|---|
| 1771 | (radix *print-radix*) |
|---|
| 1772 | (base *print-base*) |
|---|
| 1773 | (circle *print-circle*) |
|---|
| 1774 | (pretty *print-pretty*) |
|---|
| 1775 | (level *print-level*) |
|---|
| 1776 | (length *print-length*) |
|---|
| 1777 | (case *print-case*) |
|---|
| 1778 | (gensym *print-gensym*) |
|---|
| 1779 | (array *print-array*) |
|---|
| 1780 | (readably *print-readably*) |
|---|
| 1781 | (right-margin *print-right-margin*) |
|---|
| 1782 | (miser-width *print-miser-width*) |
|---|
| 1783 | (lines *print-lines*) |
|---|
| 1784 | (pprint-dispatch *print-pprint-dispatch*) |
|---|
| 1785 | ;;>> Do I really want to add these to WRITE?? |
|---|
| 1786 | (structure *print-structure*) |
|---|
| 1787 | (simple-vector *print-simple-vector*) |
|---|
| 1788 | (simple-bit-vector *print-simple-bit-vector*) |
|---|
| 1789 | (string-length *print-string-length*)) |
|---|
| 1790 | "Return the printed representation of OBJECT as a string." |
|---|
| 1791 | (let ((*print-escape* escape) |
|---|
| 1792 | (*print-radix* radix) |
|---|
| 1793 | (*print-base* base) |
|---|
| 1794 | (*print-circle* circle) |
|---|
| 1795 | (*print-pretty* pretty) |
|---|
| 1796 | (*print-level* level) |
|---|
| 1797 | (*print-length* length) |
|---|
| 1798 | (*print-case* case) |
|---|
| 1799 | (*print-gensym* gensym) |
|---|
| 1800 | (*print-array* array) |
|---|
| 1801 | ;; I didn't really wan't to add these, but I had to. |
|---|
| 1802 | (*print-readably* readably) |
|---|
| 1803 | (*print-right-margin* right-margin) |
|---|
| 1804 | (*print-miser-width* miser-width) |
|---|
| 1805 | (*print-lines* lines) |
|---|
| 1806 | (*print-pprint-dispatch* pprint-dispatch) |
|---|
| 1807 | ;;>> Do I really want to add these to WRITE?? |
|---|
| 1808 | (*print-structure* structure) |
|---|
| 1809 | (*print-simple-vector* simple-vector) |
|---|
| 1810 | (*print-simple-bit-vector* simple-bit-vector) |
|---|
| 1811 | (*print-string-length* string-length)) |
|---|
| 1812 | (with-output-to-string (stream) |
|---|
| 1813 | (write-1 object stream)))) |
|---|
| 1814 | |
|---|
| 1815 | (defun prin1-to-string (object) |
|---|
| 1816 | "Return the printed representation of OBJECT as a string with |
|---|
| 1817 | slashification on." |
|---|
| 1818 | (with-output-to-string (s) |
|---|
| 1819 | (prin1 object s))) |
|---|
| 1820 | |
|---|
| 1821 | (defun princ-to-string (object) |
|---|
| 1822 | "Return the printed representation of OBJECT as a string with |
|---|
| 1823 | slashification off." |
|---|
| 1824 | (with-output-to-string (s) |
|---|
| 1825 | (princ object s))) |
|---|
| 1826 | |
|---|
| 1827 | (defun prin1 (object &optional stream) |
|---|
| 1828 | "Output a mostly READable printed representation of OBJECT on the specified |
|---|
| 1829 | STREAM." |
|---|
| 1830 | (let ((*print-escape* t)) |
|---|
| 1831 | (write-1 object stream))) |
|---|
| 1832 | |
|---|
| 1833 | (defun princ (object &optional stream) |
|---|
| 1834 | "Output an aesthetic but not necessarily READable printed representation |
|---|
| 1835 | of OBJECT on the specified STREAM." |
|---|
| 1836 | (let ((*print-escape* nil) |
|---|
| 1837 | (*print-readably* nil)) |
|---|
| 1838 | (write-1 object stream))) |
|---|
| 1839 | |
|---|
| 1840 | (defun print (object &optional stream) |
|---|
| 1841 | "Output a newline, the mostly READable printed representation of OBJECT, and |
|---|
| 1842 | space to the specified STREAM." |
|---|
| 1843 | (terpri stream) |
|---|
| 1844 | (let ((*print-escape* t)) |
|---|
| 1845 | (write-1 object stream)) |
|---|
| 1846 | (write-char #\Space stream) |
|---|
| 1847 | object) |
|---|
| 1848 | |
|---|
| 1849 | ; redefined by pprint module if loaded |
|---|
| 1850 | (defun pprint (object &optional stream) |
|---|
| 1851 | (print object stream) |
|---|
| 1852 | nil) ; pprint returns nil |
|---|
| 1853 | |
|---|
| 1854 | |
|---|
| 1855 | (defun read-sequence (seq stream &key (start 0) end) |
|---|
| 1856 | "Destructively modify SEQ by reading elements from STREAM. |
|---|
| 1857 | That part of SEQ bounded by START and END is destructively modified by |
|---|
| 1858 | copying successive elements into it from STREAM. If the end of file |
|---|
| 1859 | for STREAM is reached before copying all elements of the subsequence, |
|---|
| 1860 | then the extra elements near the end of sequence are not updated, and |
|---|
| 1861 | the index of the next element is returned." |
|---|
| 1862 | (setq end (check-sequence-bounds seq start end)) |
|---|
| 1863 | (locally (declare (fixnum start end)) |
|---|
| 1864 | (if (= start end) |
|---|
| 1865 | start |
|---|
| 1866 | (seq-dispatch |
|---|
| 1867 | seq |
|---|
| 1868 | (+ start (the fixnum (stream-read-list |
|---|
| 1869 | stream |
|---|
| 1870 | (nthcdr start seq) |
|---|
| 1871 | (the fixnum (- end start))))) |
|---|
| 1872 | (multiple-value-bind (vector offset) (array-data-and-offset seq) |
|---|
| 1873 | (declare (fixnum offset)) |
|---|
| 1874 | (- |
|---|
| 1875 | (stream-read-vector |
|---|
| 1876 | stream |
|---|
| 1877 | vector |
|---|
| 1878 | (the fixnum (+ offset start)) |
|---|
| 1879 | (the fixnum (+ offset end))) |
|---|
| 1880 | offset)))))) |
|---|
| 1881 | |
|---|
| 1882 | |
|---|
| 1883 | |
|---|
| 1884 | (defun write-sequence (seq stream &key (start 0) end) |
|---|
| 1885 | "Write the elements of SEQ bounded by START and END to STREAM." |
|---|
| 1886 | (setq end (check-sequence-bounds seq start end)) |
|---|
| 1887 | (locally (declare (fixnum start end)) |
|---|
| 1888 | (seq-dispatch |
|---|
| 1889 | seq |
|---|
| 1890 | (stream-write-list stream (nthcdr start seq) (the fixnum (- end start))) |
|---|
| 1891 | (multiple-value-bind (vector offset) (array-data-and-offset seq) |
|---|
| 1892 | (stream-write-vector |
|---|
| 1893 | stream |
|---|
| 1894 | vector |
|---|
| 1895 | (the fixnum (+ offset start)) |
|---|
| 1896 | (the fixnum (+ offset end)))))) |
|---|
| 1897 | seq) |
|---|
| 1898 | |
|---|
| 1899 | (defpackage "GRAY" |
|---|
| 1900 | (:use) |
|---|
| 1901 | (:import-from "CCL" |
|---|
| 1902 | "FUNDAMENTAL-STREAM" |
|---|
| 1903 | "FUNDAMENTAL-INPUT-STREAM" |
|---|
| 1904 | "FUNDAMENTAL-OUTPUT-STREAM" |
|---|
| 1905 | "FUNDAMENTAL-CHARACTER-STREAM" |
|---|
| 1906 | "FUNDAMENTAL-CHARACTER-INPUT-STREAM" |
|---|
| 1907 | "FUNDAMENTAL-CHARACTER-OUTPUT-STREAM" |
|---|
| 1908 | "FUNDAMENTAL-BINARY-STREAM" |
|---|
| 1909 | "FUNDAMENTAL-BINARY-INPUT-STREAM" |
|---|
| 1910 | "FUNDAMENTAL-BINARY-OUTPUT-STREAM" |
|---|
| 1911 | |
|---|
| 1912 | "STREAM-READ-CHAR" |
|---|
| 1913 | "STREAM-UNREAD-CHAR" |
|---|
| 1914 | "STREAM-READ-CHAR-NO-HANG" |
|---|
| 1915 | "STREAM-PEEK-CHAR" |
|---|
| 1916 | "STREAM-LISTEN" |
|---|
| 1917 | "STREAM-READ-LINE" |
|---|
| 1918 | "STREAM-CLEAR-INPUT" |
|---|
| 1919 | |
|---|
| 1920 | "STREAM-WRITE-CHAR" |
|---|
| 1921 | "STREAM-LINE-COLUMN" |
|---|
| 1922 | "STREAM-START-LINE-P" |
|---|
| 1923 | "STREAM-WRITE-STRING" |
|---|
| 1924 | "STREAM-TERPRI" |
|---|
| 1925 | "STREAM-FRESH-LINE" |
|---|
| 1926 | "STREAM-FORCE-OUTPUT" |
|---|
| 1927 | "STREAM-FINISH-OUTPUT" |
|---|
| 1928 | "STREAM-CLEAR-OUTPUT" |
|---|
| 1929 | "STREAM-ADVANCE-TO-COLUMN" |
|---|
| 1930 | |
|---|
| 1931 | "STREAM-READ-BYTE" |
|---|
| 1932 | "STREAM-WRITE-BYTE" |
|---|
| 1933 | ) |
|---|
| 1934 | (:export |
|---|
| 1935 | "FUNDAMENTAL-STREAM" |
|---|
| 1936 | "FUNDAMENTAL-INPUT-STREAM" |
|---|
| 1937 | "FUNDAMENTAL-OUTPUT-STREAM" |
|---|
| 1938 | "FUNDAMENTAL-CHARACTER-STREAM" |
|---|
| 1939 | "FUNDAMENTAL-CHARACTER-INPUT-STREAM" |
|---|
| 1940 | "FUNDAMENTAL-CHARACTER-OUTPUT-STREAM" |
|---|
| 1941 | "FUNDAMENTAL-BINARY-STREAM" |
|---|
| 1942 | "FUNDAMENTAL-BINARY-INPUT-STREAM" |
|---|
| 1943 | "FUNDAMENTAL-BINARY-OUTPUT-STREAM" |
|---|
| 1944 | |
|---|
| 1945 | "STREAM-READ-CHAR" |
|---|
| 1946 | "STREAM-UNREAD-CHAR" |
|---|
| 1947 | "STREAM-READ-CHAR-NO-HANG" |
|---|
| 1948 | "STREAM-PEEK-CHAR" |
|---|
| 1949 | "STREAM-LISTEN" |
|---|
| 1950 | "STREAM-READ-LINE" |
|---|
| 1951 | "STREAM-CLEAR-INPUT" |
|---|
| 1952 | |
|---|
| 1953 | "STREAM-WRITE-CHAR" |
|---|
| 1954 | "STREAM-LINE-COLUMN" |
|---|
| 1955 | "STREAM-START-LINE-P" |
|---|
| 1956 | "STREAM-WRITE-STRING" |
|---|
| 1957 | "STREAM-TERPRI" |
|---|
| 1958 | "STREAM-FRESH-LINE" |
|---|
| 1959 | "STREAM-FORCE-OUTPUT" |
|---|
| 1960 | "STREAM-FINISH-OUTPUT" |
|---|
| 1961 | "STREAM-CLEAR-OUTPUT" |
|---|
| 1962 | "STREAM-ADVANCE-TO-COLUMN" |
|---|
| 1963 | |
|---|
| 1964 | "STREAM-READ-BYTE" |
|---|
| 1965 | "STREAM-WRITE-BYTE" |
|---|
| 1966 | )) |
|---|
| 1967 | |
|---|
| 1968 | |
|---|
