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

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

Compiler macros for write-string -> write-simple-string, and some common cases of format.

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