source: trunk/ccl/level-1/l1-io.lisp @ 6192

Last change on this file since 6192 was 6192, checked in by gb, 13 years ago

Change pointer printing.

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