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 | |
---|