source: branches/working-0711/ccl/level-1/l1-io.lisp @ 9408

Last change on this file since 9408 was 9408, checked in by gz, 12 years ago

real-print-stream -> %real-print-stream, less redundant streamp checking

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