-
Notifications
You must be signed in to change notification settings - Fork 7
/
stream.lisp
2100 lines (1952 loc) · 87.9 KB
/
stream.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;;; os-independent stream functions
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!IMPL")
;;;; standard streams
;;; The initialization of these streams is performed by
;;; STREAM-COLD-INIT-OR-RESET.
(defvar *terminal-io* () #!+sb-doc "terminal I/O stream")
(defvar *standard-input* () #!+sb-doc "default input stream")
(defvar *standard-output* () #!+sb-doc "default output stream")
(defvar *error-output* () #!+sb-doc "error output stream")
(defvar *query-io* () #!+sb-doc "query I/O stream")
(defvar *trace-output* () #!+sb-doc "trace output stream")
(defvar *debug-io* () #!+sb-doc "interactive debugging stream")
(defun ill-in (stream &rest ignore)
(declare (ignore ignore))
(error 'simple-type-error
:datum stream
:expected-type '(satisfies input-stream-p)
:format-control "~S is not a character input stream."
:format-arguments (list stream)))
(defun ill-out (stream &rest ignore)
(declare (ignore ignore))
(error 'simple-type-error
:datum stream
:expected-type '(satisfies output-stream-p)
:format-control "~S is not a character output stream."
:format-arguments (list stream)))
(defun ill-bin (stream &rest ignore)
(declare (ignore ignore))
(error 'simple-type-error
:datum stream
:expected-type '(satisfies input-stream-p)
:format-control "~S is not a binary input stream."
:format-arguments (list stream)))
(defun ill-bout (stream &rest ignore)
(declare (ignore ignore))
(error 'simple-type-error
:datum stream
:expected-type '(satisfies output-stream-p)
:format-control "~S is not a binary output stream."
:format-arguments (list stream)))
(defun closed-flame (stream &rest ignore)
(declare (ignore ignore))
(error 'closed-stream-error :stream stream))
(defun no-op-placeholder (&rest ignore)
(declare (ignore ignore)))
;;; stream manipulation functions
(defun ansi-stream-input-stream-p (stream)
(declare (type ansi-stream stream))
(if (synonym-stream-p stream)
(input-stream-p (symbol-value (synonym-stream-symbol stream)))
(and (not (eq (ansi-stream-in stream) #'closed-flame))
;;; KLUDGE: It's probably not good to have EQ tests on function
;;; values like this. What if someone's redefined the function?
;;; Is there a better way? (Perhaps just VALID-FOR-INPUT and
;;; VALID-FOR-OUTPUT flags? -- WHN 19990902
(or (not (eq (ansi-stream-in stream) #'ill-in))
(not (eq (ansi-stream-bin stream) #'ill-bin))))))
(defun input-stream-p (stream)
(declare (type stream stream))
(and (ansi-stream-p stream)
(ansi-stream-input-stream-p stream)))
(defun ansi-stream-output-stream-p (stream)
(declare (type ansi-stream stream))
(if (synonym-stream-p stream)
(output-stream-p (symbol-value (synonym-stream-symbol stream)))
(and (not (eq (ansi-stream-in stream) #'closed-flame))
(or (not (eq (ansi-stream-out stream) #'ill-out))
(not (eq (ansi-stream-bout stream) #'ill-bout))))))
(defun output-stream-p (stream)
(declare (type stream stream))
(and (ansi-stream-p stream)
(ansi-stream-output-stream-p stream)))
(declaim (inline ansi-stream-open-stream-p))
(defun ansi-stream-open-stream-p (stream)
(declare (type ansi-stream stream))
;; CLHS 22.1.4 lets us not worry about synonym streams here.
(not (eq (ansi-stream-in stream) #'closed-flame)))
(defun open-stream-p (stream)
(ansi-stream-open-stream-p stream))
(declaim (inline ansi-stream-element-type))
(defun ansi-stream-element-type (stream)
(declare (type ansi-stream stream))
(funcall (ansi-stream-misc stream) stream :element-type))
(defun stream-element-type (stream)
(ansi-stream-element-type stream))
(defun stream-external-format (stream)
(funcall (ansi-stream-misc stream) stream :external-format))
(defun interactive-stream-p (stream)
(declare (type stream stream))
(funcall (ansi-stream-misc stream) stream :interactive-p))
(declaim (inline ansi-stream-close))
(defun ansi-stream-close (stream abort)
(declare (type ansi-stream stream))
(when (open-stream-p stream)
(funcall (ansi-stream-misc stream) stream :close abort))
t)
(defun close (stream &key abort)
(ansi-stream-close stream abort))
(defun set-closed-flame (stream)
(setf (ansi-stream-in stream) #'closed-flame)
(setf (ansi-stream-bin stream) #'closed-flame)
(setf (ansi-stream-n-bin stream) #'closed-flame)
(setf (ansi-stream-out stream) #'closed-flame)
(setf (ansi-stream-bout stream) #'closed-flame)
(setf (ansi-stream-sout stream) #'closed-flame)
(setf (ansi-stream-misc stream) #'closed-flame))
;;;; file position and file length
(defun external-format-char-size (external-format)
(let ((ef-entry (find-external-format external-format)))
(if (variable-width-external-format-p ef-entry)
(bytes-for-char-fun ef-entry)
(funcall (bytes-for-char-fun ef-entry) #\x))))
;;; Call the MISC method with the :FILE-POSITION operation.
#!-sb-fluid (declaim (inline ansi-stream-file-position))
(defun ansi-stream-file-position (stream position)
(declare (type stream stream))
(declare (type (or index (alien sb!unix:off-t) (member nil :start :end))
position))
;; FIXME: It woud be good to comment on the stuff that is done here...
;; FIXME: This doesn't look interrupt safe.
(cond
(position
(setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
(funcall (ansi-stream-misc stream) stream :file-position position))
(t
(let ((res (funcall (ansi-stream-misc stream) stream :file-position nil)))
(when res
#!-sb-unicode
(- res
(- +ansi-stream-in-buffer-length+
(ansi-stream-in-index stream)))
#!+sb-unicode
(let ((char-size (if (fd-stream-p stream)
(fd-stream-char-size stream)
(external-format-char-size (stream-external-format stream)))))
(- res
(etypecase char-size
(function
(loop with buffer = (ansi-stream-cin-buffer stream)
with start = (ansi-stream-in-index stream)
for i from start below +ansi-stream-in-buffer-length+
sum (funcall char-size (aref buffer i))))
(fixnum
(* char-size
(- +ansi-stream-in-buffer-length+
(ansi-stream-in-index stream))))))))))))
(defun file-position (stream &optional position)
(if (ansi-stream-p stream)
(ansi-stream-file-position stream position)
(stream-file-position stream position)))
;;; This is a literal translation of the ANSI glossary entry "stream
;;; associated with a file".
;;;
;;; KLUDGE: Note that since Unix famously thinks "everything is a
;;; file", and in particular stdin, stdout, and stderr are files, we
;;; end up with this test being satisfied for weird things like
;;; *STANDARD-OUTPUT* (to a tty). That seems unlikely to be what the
;;; ANSI spec really had in mind, especially since this is used as a
;;; qualification for operations like FILE-LENGTH (so that ANSI was
;;; probably thinking of something like what Unix calls block devices)
;;; but I can't see any better way to do it. -- WHN 2001-04-14
(defun stream-associated-with-file-p (x)
"Test for the ANSI concept \"stream associated with a file\"."
(or (typep x 'file-stream)
(and (synonym-stream-p x)
(stream-associated-with-file-p (symbol-value
(synonym-stream-symbol x))))))
(defun stream-must-be-associated-with-file (stream)
(declare (type stream stream))
(unless (stream-associated-with-file-p stream)
(error 'simple-type-error
;; KLUDGE: The ANSI spec for FILE-LENGTH specifically says
;; this should be TYPE-ERROR. But what then can we use for
;; EXPECTED-TYPE? This SATISFIES type (with a nonstandard
;; private predicate function..) is ugly and confusing, but
;; I can't see any other way. -- WHN 2001-04-14
:datum stream
:expected-type '(satisfies stream-associated-with-file-p)
:format-control
"~@<The stream ~2I~_~S ~I~_isn't associated with a file.~:>"
:format-arguments (list stream))))
;;; like FILE-POSITION, only using :FILE-LENGTH
(defun file-length (stream)
;; FIXME: The following declaration uses yet undefined types, which
;; cause cross-compiler hangup.
;;
;; (declare (type (or file-stream synonym-stream) stream))
;;
;; The description for FILE-LENGTH says that an error must be raised
;; for streams not associated with files (which broadcast streams
;; aren't according to the glossary). However, the behaviour of
;; FILE-LENGTH for broadcast streams is explicitly described in the
;; BROADCAST-STREAM entry.
(unless (typep stream 'broadcast-stream)
(stream-must-be-associated-with-file stream))
(funcall (ansi-stream-misc stream) stream :file-length))
(defun file-string-length (stream object)
(funcall (ansi-stream-misc stream) stream :file-string-length object))
;;;; input functions
(defun ansi-stream-read-line-from-frc-buffer (stream eof-error-p eof-value)
(prepare-for-fast-read-char stream
(declare (ignore %frc-method%))
(let ((chunks-total-length 0)
(chunks nil))
(declare (type index chunks-total-length)
(list chunks))
(labels ((refill-buffer ()
(prog1
(fast-read-char-refill stream nil nil)
(setf %frc-index% (ansi-stream-in-index %frc-stream%))))
(newline-position ()
(position #\Newline (the (simple-array character (*))
%frc-buffer%)
:test #'char=
:start %frc-index%))
(make-and-return-result-string (pos)
(let* ((len (+ (- (or pos %frc-index%)
%frc-index%)
chunks-total-length))
(res (make-string len))
(start 0))
(declare (type index start))
(when chunks
(dolist (chunk (nreverse chunks))
(declare (type (simple-array character) chunk))
(replace res chunk :start1 start)
(incf start (length chunk))))
(unless (null pos)
(replace res %frc-buffer%
:start1 start
:start2 %frc-index% :end2 pos)
(setf %frc-index% (1+ pos)))
(done-with-fast-read-char)
(return-from ansi-stream-read-line-from-frc-buffer (values res (null pos)))))
(add-chunk ()
(let* ((end (length %frc-buffer%))
(len (- end %frc-index%))
(chunk (make-string len)))
(replace chunk %frc-buffer% :start2 %frc-index% :end2 end)
(push chunk chunks)
(incf chunks-total-length len)
(when (refill-buffer)
(make-and-return-result-string nil)))))
(declare (inline make-and-return-result-string
refill-buffer))
(when (and (= %frc-index% +ansi-stream-in-buffer-length+)
(refill-buffer))
;; EOF had been reached before we read anything
;; at all. Return the EOF value or signal the error.
(done-with-fast-read-char)
(return-from ansi-stream-read-line-from-frc-buffer
(values (eof-or-lose stream eof-error-p eof-value) t)))
(loop
(let ((pos (newline-position)))
(if pos
(make-and-return-result-string pos)
(add-chunk))))))))
#!-sb-fluid (declaim (inline ansi-stream-read-line))
(defun ansi-stream-read-line (stream eof-error-p eof-value recursive-p)
(declare (ignore recursive-p))
(if (ansi-stream-cin-buffer stream)
;; Stream has a fast-read-char buffer. Copy large chunks directly
;; out of the buffer.
(ansi-stream-read-line-from-frc-buffer stream eof-error-p eof-value)
;; Slow path, character by character.
(prepare-for-fast-read-char stream
(let ((res (make-string 80))
(len 80)
(index 0))
(loop
(let ((ch (fast-read-char nil nil)))
(cond (ch
(when (char= ch #\newline)
(done-with-fast-read-char)
(return (values (%shrink-vector res index) nil)))
(when (= index len)
(setq len (* len 2))
(let ((new (make-string len)))
(replace new res)
(setq res new)))
(setf (schar res index) ch)
(incf index))
((zerop index)
(done-with-fast-read-char)
(return (values (eof-or-lose stream
eof-error-p
eof-value)
t)))
;; Since FAST-READ-CHAR already hit the eof char, we
;; shouldn't do another READ-CHAR.
(t
(done-with-fast-read-char)
(return (values (%shrink-vector res index) t))))))))))
(defun read-line (&optional (stream *standard-input*) (eof-error-p t) eof-value
recursive-p)
(let ((stream (in-synonym-of stream)))
(if (ansi-stream-p stream)
(ansi-stream-read-line stream eof-error-p eof-value recursive-p)
;; must be Gray streams FUNDAMENTAL-STREAM
(multiple-value-bind (string eof) (stream-read-line stream)
(if (and eof (zerop (length string)))
(values (eof-or-lose stream eof-error-p eof-value) t)
(values string eof))))))
;;; We proclaim them INLINE here, then proclaim them NOTINLINE later on,
;;; so, except in this file, they are not inline by default, but they can be.
#!-sb-fluid (declaim (inline read-char unread-char read-byte listen))
#!-sb-fluid (declaim (inline ansi-stream-read-char))
(defun ansi-stream-read-char (stream eof-error-p eof-value recursive-p)
(declare (ignore recursive-p))
(prepare-for-fast-read-char stream
(prog1
(fast-read-char eof-error-p eof-value)
(done-with-fast-read-char))))
(defun read-char (&optional (stream *standard-input*)
(eof-error-p t)
eof-value
recursive-p)
(let ((stream (in-synonym-of stream)))
(if (ansi-stream-p stream)
(ansi-stream-read-char stream eof-error-p eof-value recursive-p)
;; must be Gray streams FUNDAMENTAL-STREAM
(let ((char (stream-read-char stream)))
(if (eq char :eof)
(eof-or-lose stream eof-error-p eof-value)
char)))))
#!-sb-fluid (declaim (inline ansi-stream-unread-char))
(defun ansi-stream-unread-char (character stream)
(let ((index (1- (ansi-stream-in-index stream)))
(buffer (ansi-stream-cin-buffer stream)))
(declare (fixnum index))
(when (minusp index) (error "nothing to unread"))
(cond (buffer
(setf (aref buffer index) character)
(setf (ansi-stream-in-index stream) index))
(t
(funcall (ansi-stream-misc stream) stream
:unread character)))))
(defun unread-char (character &optional (stream *standard-input*))
(let ((stream (in-synonym-of stream)))
(if (ansi-stream-p stream)
(ansi-stream-unread-char character stream)
;; must be Gray streams FUNDAMENTAL-STREAM
(stream-unread-char stream character)))
nil)
#!-sb-fluid (declaim (inline ansi-stream-listen))
(defun ansi-stream-listen (stream)
(or (/= (the fixnum (ansi-stream-in-index stream))
+ansi-stream-in-buffer-length+)
;; Handle :EOF return from misc methods specially
(let ((result (funcall (ansi-stream-misc stream) stream :listen)))
(if (eq result :eof)
nil
result))))
(defun listen (&optional (stream *standard-input*))
(let ((stream (in-synonym-of stream)))
(if (ansi-stream-p stream)
(ansi-stream-listen stream)
;; Fall through to Gray streams FUNDAMENTAL-STREAM case.
(stream-listen stream))))
#!-sb-fluid (declaim (inline ansi-stream-read-char-no-hang))
(defun ansi-stream-read-char-no-hang (stream eof-error-p eof-value recursive-p)
(if (funcall (ansi-stream-misc stream) stream :listen)
;; On T or :EOF get READ-CHAR to do the work.
(ansi-stream-read-char stream eof-error-p eof-value recursive-p)
nil))
(defun read-char-no-hang (&optional (stream *standard-input*)
(eof-error-p t)
eof-value
recursive-p)
(let ((stream (in-synonym-of stream)))
(if (ansi-stream-p stream)
(ansi-stream-read-char-no-hang stream eof-error-p eof-value
recursive-p)
;; must be Gray streams FUNDAMENTAL-STREAM
(let ((char (stream-read-char-no-hang stream)))
(if (eq char :eof)
(eof-or-lose stream eof-error-p eof-value)
char)))))
#!-sb-fluid (declaim (inline ansi-stream-clear-input))
(defun ansi-stream-clear-input (stream)
(setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
(funcall (ansi-stream-misc stream) stream :clear-input))
(defun clear-input (&optional (stream *standard-input*))
(let ((stream (in-synonym-of stream)))
(if (ansi-stream-p stream)
(ansi-stream-clear-input stream)
;; must be Gray streams FUNDAMENTAL-STREAM
(stream-clear-input stream)))
nil)
#!-sb-fluid (declaim (inline ansi-stream-read-byte))
(defun ansi-stream-read-byte (stream eof-error-p eof-value recursive-p)
;; Why the "recursive-p" parameter? a-s-r-b is funcall'ed from
;; a-s-read-sequence and needs a lambda list that's congruent with
;; that of a-s-read-char
(declare (ignore recursive-p))
(prepare-for-fast-read-byte stream
(prog1
(fast-read-byte eof-error-p eof-value t)
(done-with-fast-read-byte))))
(defun read-byte (stream &optional (eof-error-p t) eof-value)
(if (ansi-stream-p stream)
(ansi-stream-read-byte stream eof-error-p eof-value nil)
;; must be Gray streams FUNDAMENTAL-STREAM
(let ((char (stream-read-byte stream)))
(if (eq char :eof)
(eof-or-lose stream eof-error-p eof-value)
char))))
;;; Read NUMBYTES bytes into BUFFER beginning at START, and return the
;;; number of bytes read.
;;;
;;; Note: CMU CL's version of this had a special interpretation of
;;; EOF-ERROR-P which SBCL does not have. (In the EOF-ERROR-P=NIL
;;; case, CMU CL's version would return as soon as any data became
;;; available.) This could be useful behavior for things like pipes in
;;; some cases, but it wasn't being used in SBCL, so it was dropped.
;;; If we ever need it, it could be added later as a new variant N-BIN
;;; method (perhaps N-BIN-ASAP?) or something.
#!-sb-fluid (declaim (inline read-n-bytes))
(defun read-n-bytes (stream buffer start numbytes &optional (eof-error-p t))
(if (ansi-stream-p stream)
(ansi-stream-read-n-bytes stream buffer start numbytes eof-error-p)
;; We don't need to worry about element-type size here is that
;; callers are supposed to have checked everything is kosher.
(let* ((end (+ start numbytes))
(read-end (stream-read-sequence stream buffer start end)))
(eof-or-lose stream (and eof-error-p (< read-end end)) (- read-end start)))))
(defun ansi-stream-read-n-bytes (stream buffer start numbytes eof-error-p)
(declare (type ansi-stream stream)
(type index numbytes start)
(type (or (simple-array * (*)) system-area-pointer) buffer))
(let* ((stream (in-synonym-of stream ansi-stream))
(in-buffer (ansi-stream-in-buffer stream))
(index (ansi-stream-in-index stream))
(num-buffered (- +ansi-stream-in-buffer-length+ index)))
(declare (fixnum index num-buffered))
(cond
((not in-buffer)
(funcall (ansi-stream-n-bin stream)
stream
buffer
start
numbytes
eof-error-p))
((<= numbytes num-buffered)
#+nil
(let ((copy-function (typecase buffer
((simple-array * (*)) #'ub8-bash-copy)
(system-area-pointer #'copy-ub8-to-system-area))))
(funcall copy-function in-buffer index buffer start numbytes))
(%byte-blt in-buffer index
buffer start (+ start numbytes))
(setf (ansi-stream-in-index stream) (+ index numbytes))
numbytes)
(t
(let ((end (+ start num-buffered)))
#+nil
(let ((copy-function (typecase buffer
((simple-array * (*)) #'ub8-bash-copy)
(system-area-pointer #'copy-ub8-to-system-area))))
(funcall copy-function in-buffer index buffer start num-buffered))
(%byte-blt in-buffer index buffer start end)
(setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
(+ (funcall (ansi-stream-n-bin stream)
stream
buffer
end
(- numbytes num-buffered)
eof-error-p)
num-buffered))))))
;;; the amount of space we leave at the start of the in-buffer for
;;; unreading
;;;
;;; (It's 4 instead of 1 to allow word-aligned copies.)
(defconstant +ansi-stream-in-buffer-extra+
4) ; FIXME: should be symbolic constant
;;; This function is called by the FAST-READ-CHAR expansion to refill
;;; the IN-BUFFER for text streams. There is definitely an IN-BUFFER,
;;; and hence must be an N-BIN method. It's also called by other stream
;;; functions which directly peek into the frc buffer.
(defun fast-read-char-refill (stream eof-error-p eof-value)
(let* ((ibuf (ansi-stream-cin-buffer stream))
(count (funcall (ansi-stream-n-bin stream)
stream
ibuf
+ansi-stream-in-buffer-extra+
(- +ansi-stream-in-buffer-length+
+ansi-stream-in-buffer-extra+)
nil))
(start (- +ansi-stream-in-buffer-length+ count)))
(declare (type index start count))
(cond ((zerop count)
;; An empty count does not necessarily mean that we reached
;; the EOF, it's also possible that it's e.g. due to a
;; invalid octet sequence in a multibyte stream. To handle
;; the resyncing case correctly we need to call the
;; single-character reading function and check whether an
;; EOF was really reached. If not, we can just fill the
;; buffer by one character, and hope that the next refill
;; will not need to resync.
(let* ((value (funcall (ansi-stream-in stream) stream nil :eof))
(index (1- +ansi-stream-in-buffer-length+)))
(case value
((:eof)
;; Mark buffer as empty.
(setf (ansi-stream-in-index stream)
+ansi-stream-in-buffer-length+)
;; EOF. Redo the read, this time with the real eof parameters.
(values t (funcall (ansi-stream-in stream)
stream eof-error-p eof-value)))
(otherwise
(setf (aref ibuf index) value)
(values nil (setf (ansi-stream-in-index stream) index))))))
(t
(when (/= start +ansi-stream-in-buffer-extra+)
(#.(let* ((n-character-array-bits
(sb!vm:saetp-n-bits
(find 'character
sb!vm:*specialized-array-element-type-properties*
:key #'sb!vm:saetp-specifier)))
(bash-function (intern (format nil "UB~D-BASH-COPY" n-character-array-bits)
(find-package "SB!KERNEL"))))
bash-function)
ibuf +ansi-stream-in-buffer-extra+
ibuf start
count))
(values nil
(setf (ansi-stream-in-index stream) start))))))
;;; This is similar to FAST-READ-CHAR-REFILL, but we don't have to
;;; leave room for unreading.
(defun fast-read-byte-refill (stream eof-error-p eof-value)
(let* ((ibuf (ansi-stream-in-buffer stream))
(count (funcall (ansi-stream-n-bin stream) stream
ibuf 0 +ansi-stream-in-buffer-length+
nil))
(start (- +ansi-stream-in-buffer-length+ count)))
(declare (type index start count))
(cond ((zerop count)
(setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
(funcall (ansi-stream-bin stream) stream eof-error-p eof-value))
(t
(unless (zerop start)
(ub8-bash-copy ibuf 0
ibuf start
count))
(setf (ansi-stream-in-index stream) (1+ start))
(aref ibuf start)))))
;;; output functions
(defun write-char (character &optional (stream *standard-output*))
(with-out-stream stream (ansi-stream-out character)
(stream-write-char character))
character)
(defun terpri (&optional (stream *standard-output*))
(with-out-stream stream (ansi-stream-out #\newline) (stream-terpri))
nil)
#!-sb-fluid (declaim (inline ansi-stream-fresh-line))
(defun ansi-stream-fresh-line (stream)
(when (/= (or (charpos stream) 1) 0)
(funcall (ansi-stream-out stream) stream #\newline)
t))
(defun fresh-line (&optional (stream *standard-output*))
(let ((stream (out-synonym-of stream)))
(if (ansi-stream-p stream)
(ansi-stream-fresh-line stream)
;; must be Gray streams FUNDAMENTAL-STREAM
(stream-fresh-line stream))))
#!-sb-fluid (declaim (inline ansi-stream-write-string))
(defun ansi-stream-write-string (string stream start end)
(with-array-data ((data string) (offset-start start)
(offset-end end)
:check-fill-pointer t)
(funcall (ansi-stream-sout stream)
stream data offset-start offset-end)))
(defun %write-string (string stream start end)
(let ((stream (out-synonym-of stream)))
(if (ansi-stream-p stream)
(ansi-stream-write-string string stream start end)
;; must be Gray streams FUNDAMENTAL-STREAM
(stream-write-string stream string start end)))
string)
(defun write-string (string &optional (stream *standard-output*)
&key (start 0) end)
(declare (type string string))
(declare (type stream-designator stream))
(%write-string string stream start end))
;;; A wrapper function for all those (MACROLET OUT-FUN) definitions,
;;; which cannot deal with keyword arguments. %WRITE-STRING cannot
;;; replace this, as this needs to deal with simple-strings as well.
(declaim (inline write-string-no-key))
(defun write-string-no-key (string stream start end)
(write-string string stream :start start :end end))
(defun write-line (string &optional (stream *standard-output*)
&key (start 0) end)
(declare (type string string))
(declare (type stream-designator stream))
(let ((stream (out-synonym-of stream)))
(cond ((ansi-stream-p stream)
(ansi-stream-write-string string stream start end)
(funcall (ansi-stream-out stream) stream #\newline))
(t
(stream-write-string stream string start end)
(stream-write-char stream #\newline))))
string)
(defun charpos (&optional (stream *standard-output*))
(with-out-stream stream (ansi-stream-misc :charpos) (stream-line-column)))
(defun line-length (&optional (stream *standard-output*))
(with-out-stream stream (ansi-stream-misc :line-length)
(stream-line-length)))
(defun finish-output (&optional (stream *standard-output*))
(with-out-stream stream (ansi-stream-misc :finish-output)
(stream-finish-output))
nil)
(defun force-output (&optional (stream *standard-output*))
(with-out-stream stream (ansi-stream-misc :force-output)
(stream-force-output))
nil)
(defun clear-output (&optional (stream *standard-output*))
(with-out-stream stream (ansi-stream-misc :clear-output)
(stream-force-output))
nil)
(defun write-byte (integer stream)
(with-out-stream/no-synonym stream (ansi-stream-bout integer)
(stream-write-byte integer))
integer)
;;; (These were inline throughout this file, but that's not appropriate
;;; globally. And we must not inline them in the rest of this file if
;;; dispatch to gray or simple streams is to work, since both redefine
;;; these functions later.)
(declaim (notinline read-char unread-char read-byte listen))
;;; This is called from ANSI-STREAM routines that encapsulate CLOS
;;; streams to handle the misc routines and dispatch to the
;;; appropriate SIMPLE- or FUNDAMENTAL-STREAM functions.
(defun stream-misc-dispatch (stream operation &optional arg1 arg2)
(declare (type stream stream) (ignore arg2))
(ecase operation
(:listen
;; Return T if input available, :EOF for end-of-file, otherwise NIL.
(let ((char (read-char-no-hang stream nil :eof)))
(when (characterp char)
(unread-char char stream))
char))
(:unread
(unread-char arg1 stream))
(:close
(close stream))
(:clear-input
(clear-input stream))
(:force-output
(force-output stream))
(:finish-output
(finish-output stream))
(:element-type
(stream-element-type stream))
(:stream-external-format
(stream-external-format stream))
(:interactive-p
(interactive-stream-p stream))
(:line-length
(line-length stream))
(:charpos
(charpos stream))
(:file-length
(file-length stream))
(:file-string-length
(file-string-length stream arg1))
(:file-position
(file-position stream arg1))))
;;;; broadcast streams
(defstruct (broadcast-stream (:include ansi-stream
(out #'broadcast-out)
(bout #'broadcast-bout)
(sout #'broadcast-sout)
(misc #'broadcast-misc))
(:constructor %make-broadcast-stream
(&rest streams))
(:copier nil))
;; a list of all the streams we broadcast to
(streams () :type list :read-only t))
(defun make-broadcast-stream (&rest streams)
(dolist (stream streams)
(unless (output-stream-p stream)
(error 'type-error
:datum stream
:expected-type '(satisfies output-stream-p))))
(apply #'%make-broadcast-stream streams))
(macrolet ((out-fun (name fun &rest args)
`(defun ,name (stream ,@args)
(dolist (stream (broadcast-stream-streams stream))
(,fun ,(car args) stream ,@(cdr args))))))
(out-fun broadcast-out write-char char)
(out-fun broadcast-bout write-byte byte)
(out-fun broadcast-sout write-string-no-key string start end))
(defun broadcast-misc (stream operation &optional arg1 arg2)
(let ((streams (broadcast-stream-streams stream)))
(case operation
;; FIXME: This may not be the best place to note this, but I
;; think the :CHARPOS protocol needs revision. Firstly, I think
;; this is the last place where a NULL return value was possible
;; (before adjusting it to be 0), so a bunch of conditionals IF
;; CHARPOS can be removed; secondly, it is my belief that
;; FD-STREAMS, when running FILE-POSITION, do not update the
;; CHARPOS, and consequently there will be much wrongness.
;;
;; FIXME: see also TWO-WAY-STREAM treatment of :CHARPOS -- why
;; is it testing the :charpos of an input stream?
;;
;; -- CSR, 2004-02-04
(:charpos
(dolist (stream streams 0)
(let ((charpos (charpos stream)))
(if charpos (return charpos)))))
(:line-length
(let ((min nil))
(dolist (stream streams min)
(let ((res (line-length stream)))
(when res (setq min (if min (min res min) res)))))))
(:element-type
#+nil ; old, arguably more logical, version
(let (res)
(dolist (stream streams (if (> (length res) 1) `(and ,@res) t))
(pushnew (stream-element-type stream) res :test #'equal)))
;; ANSI-specified version (under System Class BROADCAST-STREAM)
(let ((res t))
(do ((streams streams (cdr streams)))
((null streams) res)
(when (null (cdr streams))
(setq res (stream-element-type (car streams)))))))
(:external-format
(let ((res :default))
(dolist (stream streams res)
(setq res (stream-external-format stream)))))
(:file-length
(let ((last (last streams)))
(if last
(file-length (car last))
0)))
(:file-position
(if arg1
(let ((res (or (eql arg1 :start) (eql arg1 0))))
(dolist (stream streams res)
(setq res (file-position stream arg1))))
(let ((res 0))
(dolist (stream streams res)
(setq res (file-position stream))))))
(:file-string-length
(let ((res 1))
(dolist (stream streams res)
(setq res (file-string-length stream arg1)))))
(:close
(set-closed-flame stream))
(t
(let ((res nil))
(dolist (stream streams res)
(setq res
(if (ansi-stream-p stream)
(funcall (ansi-stream-misc stream) stream operation
arg1 arg2)
(stream-misc-dispatch stream operation arg1 arg2)))))))))
;;;; synonym streams
(defstruct (synonym-stream (:include ansi-stream
(in #'synonym-in)
(bin #'synonym-bin)
(n-bin #'synonym-n-bin)
(out #'synonym-out)
(bout #'synonym-bout)
(sout #'synonym-sout)
(misc #'synonym-misc))
(:constructor make-synonym-stream (symbol))
(:copier nil))
;; This is the symbol, the value of which is the stream we are synonym to.
(symbol nil :type symbol :read-only t))
(def!method print-object ((x synonym-stream) stream)
(print-unreadable-object (x stream :type t :identity t)
(format stream ":SYMBOL ~S" (synonym-stream-symbol x))))
;;; The output simple output methods just call the corresponding
;;; function on the synonymed stream.
(macrolet ((out-fun (name fun &rest args)
`(defun ,name (stream ,@args)
(declare (optimize (safety 1)))
(let ((syn (symbol-value (synonym-stream-symbol stream))))
(,fun ,(car args) syn ,@(cdr args))))))
(out-fun synonym-out write-char ch)
(out-fun synonym-bout write-byte n)
(out-fun synonym-sout write-string-no-key string start end))
;;; For the input methods, we just call the corresponding function on the
;;; synonymed stream. These functions deal with getting input out of
;;; the In-Buffer if there is any.
(macrolet ((in-fun (name fun &rest args)
`(defun ,name (stream ,@args)
(declare (optimize (safety 1)))
(,fun (symbol-value (synonym-stream-symbol stream))
,@args))))
(in-fun synonym-in read-char eof-error-p eof-value)
(in-fun synonym-bin read-byte eof-error-p eof-value)
(in-fun synonym-n-bin read-n-bytes buffer start numbytes eof-error-p))
(defun synonym-misc (stream operation &optional arg1 arg2)
(declare (optimize (safety 1)))
(let ((syn (symbol-value (synonym-stream-symbol stream))))
(if (ansi-stream-p syn)
;; We have to special-case some operations which interact with
;; the in-buffer of the wrapped stream, since just calling
;; ANSI-STREAM-MISC on them
(case operation
(:listen (or (/= (the fixnum (ansi-stream-in-index syn))
+ansi-stream-in-buffer-length+)
(funcall (ansi-stream-misc syn) syn :listen)))
(:clear-input (clear-input syn))
(:unread (unread-char arg1 syn))
(t
(funcall (ansi-stream-misc syn) syn operation arg1 arg2)))
(stream-misc-dispatch syn operation arg1 arg2))))
;;;; two-way streams
(defstruct (two-way-stream
(:include ansi-stream
(in #'two-way-in)
(bin #'two-way-bin)
(n-bin #'two-way-n-bin)
(out #'two-way-out)
(bout #'two-way-bout)
(sout #'two-way-sout)
(misc #'two-way-misc))
(:constructor %make-two-way-stream (input-stream output-stream))
(:copier nil))
(input-stream (missing-arg) :type stream :read-only t)
(output-stream (missing-arg) :type stream :read-only t))
(defprinter (two-way-stream) input-stream output-stream)
(defun make-two-way-stream (input-stream output-stream)
#!+sb-doc
"Return a bidirectional stream which gets its input from INPUT-STREAM and
sends its output to OUTPUT-STREAM."
;; FIXME: This idiom of the-real-stream-of-a-possibly-synonym-stream
;; should be encapsulated in a function, and used here and most of
;; the other places that SYNONYM-STREAM-P appears.
(unless (output-stream-p output-stream)
(error 'type-error
:datum output-stream
:expected-type '(satisfies output-stream-p)))
(unless (input-stream-p input-stream)
(error 'type-error
:datum input-stream
:expected-type '(satisfies input-stream-p)))
(funcall #'%make-two-way-stream input-stream output-stream))
(macrolet ((out-fun (name fun &rest args)
`(defun ,name (stream ,@args)
(let ((syn (two-way-stream-output-stream stream)))
(,fun ,(car args) syn ,@(cdr args))))))
(out-fun two-way-out write-char ch)
(out-fun two-way-bout write-byte n)
(out-fun two-way-sout write-string-no-key string start end))
(macrolet ((in-fun (name fun &rest args)
`(defun ,name (stream ,@args)
(force-output (two-way-stream-output-stream stream))
(,fun (two-way-stream-input-stream stream) ,@args))))
(in-fun two-way-in read-char eof-error-p eof-value)
(in-fun two-way-bin read-byte eof-error-p eof-value)
(in-fun two-way-n-bin read-n-bytes buffer start numbytes eof-error-p))
(defun two-way-misc (stream operation &optional arg1 arg2)
(let* ((in (two-way-stream-input-stream stream))
(out (two-way-stream-output-stream stream))
(in-ansi-stream-p (ansi-stream-p in))
(out-ansi-stream-p (ansi-stream-p out)))
(case operation
(:listen
(if in-ansi-stream-p
(or (/= (the fixnum (ansi-stream-in-index in))
+ansi-stream-in-buffer-length+)
(funcall (ansi-stream-misc in) in :listen))
(listen in)))
((:finish-output :force-output :clear-output)
(if out-ansi-stream-p
(funcall (ansi-stream-misc out) out operation arg1 arg2)
(stream-misc-dispatch out operation arg1 arg2)))
(:clear-input (clear-input in))
(:unread (unread-char arg1 in))
(:element-type
(let ((in-type (stream-element-type in))
(out-type (stream-element-type out)))
(if (equal in-type out-type)
in-type `(and ,in-type ,out-type))))
(:close
(set-closed-flame stream))
(t
(or (if in-ansi-stream-p
(funcall (ansi-stream-misc in) in operation arg1 arg2)
(stream-misc-dispatch in operation arg1 arg2))
(if out-ansi-stream-p
(funcall (ansi-stream-misc out) out operation arg1 arg2)
(stream-misc-dispatch out operation arg1 arg2)))))))
;;;; concatenated streams
(defstruct (concatenated-stream
(:include ansi-stream
(in #'concatenated-in)
(bin #'concatenated-bin)
(n-bin #'concatenated-n-bin)
(misc #'concatenated-misc))
(:constructor %make-concatenated-stream (&rest streams))
(:copier nil))
;; The car of this is the substream we are reading from now.
(streams nil :type list))
(def!method print-object ((x concatenated-stream) stream)
(print-unreadable-object (x stream :type t :identity t)
(format stream
":STREAMS ~S"
(concatenated-stream-streams x))))
(defun make-concatenated-stream (&rest streams)
#!+sb-doc