source: release/1.2/source/level-1/l1-io.lisp @ 10220

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

Propagate recent changes from trunk:

l1-aprims.lisp: static value of *WHOSTATE* is "Reset".
l1-io.lisp: use stack-allocated temporary buffer in WRITE-PNAME.
l1-lisp-threads.lisp: in THREAD-ENABLE, default "wait" to 1 day.
l1-processes.lisp: PROCESS-WHOSTATE detects and handles static binding

of *WHOSTATE*. PROCESS-ENABLE waits for 1 day, which is effectively
infinite and avoids word-size issues.

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