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

Last change on this file since 13563 was 13067, checked in by rme, 10 years ago

Update copyright notices.

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