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

Last change on this file was 16802, checked in by svspire, 3 years ago

Add *print-string-length* control for tracing, backtracing, and errors.
Fixes ticket:1390 in trunk.

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