Work at SourceForge, help us to make it a better place! We have an immediate need for a Support Technician in our San Francisco or Denver office.

Close

[2fb9cd]: contrib / sb-simple-streams / impl.lisp Maximize Restore History

Download this file

impl.lisp    1110 lines (1017 with data), 45.2 kB

   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
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
;;; -*- lisp -*-
;;;
;;; **********************************************************************
;;; This code was written by Paul Foley and has been placed in the public
;;; domain.
;;;
;;; Sbcl port by Rudi Schlatte.
(in-package "SB-SIMPLE-STREAMS")
;;;
;;; **********************************************************************
;;;
;;; Implementations of standard Common Lisp functions for simple-streams
(defun %uninitialized (stream)
(error "~S has not been initialized." stream))
(defun %check (stream kind)
(declare (type simple-stream stream)
(optimize (speed 3) (space 1) (debug 0) (safety 0)))
(with-stream-class (simple-stream stream)
(cond ((not (any-stream-instance-flags stream :simple))
(%uninitialized stream))
((and (eq kind :open)
(not (any-stream-instance-flags stream :input :output)))
(sb-kernel:closed-flame stream))
((and (or (eq kind :input) (eq kind :io))
(not (any-stream-instance-flags stream :input)))
(sb-kernel:ill-in stream))
((and (or (eq kind :output) (eq kind :io))
(not (any-stream-instance-flags stream :output)))
(sb-kernel:ill-out stream)))))
(defmethod input-stream-p ((stream simple-stream))
(any-stream-instance-flags stream :input))
(defmethod output-stream-p ((stream simple-stream))
(any-stream-instance-flags stream :output))
(defmethod open-stream-p ((stream simple-stream))
(any-stream-instance-flags stream :input :output))
;;; From the simple-streams documentation: "A generic function implies
;;; a specialization capability that does not exist for
;;; simple-streams; simple-stream specializations should be on
;;; device-close." So don't do it.
(defmethod close ((stream simple-stream) &key abort)
(device-close stream abort))
(defun %file-position (stream position)
(declare (type simple-stream stream)
(type (or (integer 0 *) (member nil :start :end)) position))
(with-stream-class (simple-stream stream)
(%check stream :open)
(if position
;; Adjust current position
(let ((position (case position (:start 0) (:end -1)
(otherwise position))))
(etypecase stream
(single-channel-simple-stream
(when (sc-dirty-p stream)
(flush-buffer stream t)))
(dual-channel-simple-stream
(with-stream-class (dual-channel-simple-stream stream)
(when (> (sm outpos stream) 0)
(device-write stream :flush 0 nil t))))
(string-simple-stream
nil))
(setf (sm last-char-read-size stream) 0)
(setf (sm buffpos stream) 0 ; set pointer to 0 to force a read
(sm buffer-ptr stream) 0)
(setf (sm charpos stream) nil)
(remove-stream-instance-flags stream :eof)
(setf (device-file-position stream) position))
;; Just report current position
(let ((posn (device-file-position stream)))
(when posn
(when (sm handler stream)
(dolist (queued (sm pending stream))
(incf posn (- (the sb-int:index (third queued))
(the sb-int:index (second queued))))))
(etypecase stream
(single-channel-simple-stream
(case (sm mode stream)
((0 3) ; read, read-modify
;; Note that posn can increase here if we wrote
;; past the end of previously-read data
(decf posn (- (sm buffer-ptr stream) (sm buffpos stream))))
(1 ; write
(incf posn (sm buffpos stream)))))
(dual-channel-simple-stream
(with-stream-class (dual-channel-simple-stream stream)
(incf posn (sm outpos stream))
(when (>= (sm buffer-ptr stream) 0)
(decf posn (- (sm buffer-ptr stream) (sm buffpos stream))))))
(string-simple-stream
nil)))
posn))))
(defun %file-length (stream)
(declare (type simple-stream stream))
(%check stream :open)
(device-file-length stream))
(defun %file-name (stream)
(declare (type simple-stream stream))
(%check stream nil)
(typecase stream
(file-simple-stream
(with-stream-class (file-simple-stream stream)
(sm pathname stream)))
(probe-simple-stream
(with-stream-class (probe-simple-stream stream)
(sm pathname stream)))
(otherwise
nil)))
(defun %file-rename (stream new-name)
(declare (type simple-stream stream))
(%check stream nil)
(if (typep stream 'file-simple-stream)
(with-stream-class (file-simple-stream stream)
(setf (sm pathname stream) new-name)
(setf (sm filename stream) (%file-namestring new-name))
t)
nil))
(defun %file-string-length (stream object)
(declare (type simple-stream stream))
(with-stream-class (simple-stream stream)
(%check stream :output)
;; FIXME: need to account for compositions on the stream...
(let ((count 0))
(flet ((fn (octet)
(declare (ignore octet))
(incf count)))
(etypecase object
(character
(let ((x nil))
(char-to-octets (sm external-format stream) object x #'fn)))
(string
(let ((x nil)
(ef (sm external-format stream)))
(dotimes (i (length object))
(declare (type sb-int:index i))
(char-to-octets ef (char object i) x #'fn))))))
count)))
(defun %read-line (stream eof-error-p eof-value recursive-p)
(declare (optimize (speed 3) (space 1) (safety 0) (debug 0))
(type simple-stream stream)
(ignore recursive-p))
(with-stream-class (simple-stream stream)
(%check stream :input)
(when (any-stream-instance-flags stream :eof)
(return-from %read-line
(sb-impl::eof-or-lose stream eof-error-p eof-value)))
;; for interactive streams, finish output first to force prompt
(when (and (any-stream-instance-flags stream :output)
(any-stream-instance-flags stream :interactive))
(%finish-output stream))
(let* ((encap (sm melded-stream stream)) ; encapsulating stream
(cbuf (make-string 80)) ; current buffer
(bufs (list cbuf)) ; list of buffers
(tail bufs) ; last cons of bufs list
(index 0) ; current index in current buffer
(total 0)) ; total characters
(declare (type simple-stream encap)
(type simple-string cbuf)
(type cons bufs tail)
(type sb-int:index index total))
(loop
(multiple-value-bind (chars done)
(funcall-stm-handler j-read-chars encap cbuf
#\Newline index (length cbuf) t)
(declare (type sb-int:index chars))
(incf index chars)
(incf total chars)
(when (and (eq done :eof) (zerop total))
(if eof-error-p
(error 'end-of-file :stream stream)
(return (values eof-value t))))
(when done
;; If there's only one buffer in use, return it directly
(when (null (cdr bufs))
(return (values (sb-kernel:shrink-vector cbuf total)
(eq done :eof))))
;; If total fits in final buffer, use it
(when (<= total (length cbuf))
(replace cbuf cbuf :start1 (- total index) :end2 index)
(let ((idx 0))
(declare (type sb-int:index idx))
(do ((list bufs (cdr list)))
((eq list tail))
(let ((buf (car list)))
(declare (type simple-string buf))
(replace cbuf buf :start1 idx)
(incf idx (length buf)))))
(return (values (sb-kernel:shrink-vector cbuf total)
(eq done :eof))))
;; Allocate new string of appropriate length
(let ((string (make-string total))
(index 0))
(declare (type sb-int:index index))
(dolist (buf bufs)
(declare (type simple-string buf))
(replace string buf :start1 index)
(incf index (length buf)))
(return (values string (eq done :eof)))))
(when (>= index (length cbuf))
(setf cbuf (make-string (the sb-int:index (* 2 index))))
(setf index 0)
(setf (cdr tail) (cons cbuf nil))
(setf tail (cdr tail))))))))
(defun %read-char (stream eof-error-p eof-value recursive-p blocking-p)
(declare (type simple-stream stream)
(ignore recursive-p))
(with-stream-class (simple-stream stream)
(%check stream :input)
(when (any-stream-instance-flags stream :eof)
(return-from %read-char
(sb-impl::eof-or-lose stream eof-error-p eof-value)))
;; for interactive streams, finish output first to force prompt
(when (and (any-stream-instance-flags stream :output)
(any-stream-instance-flags stream :interactive))
(%finish-output stream))
(funcall-stm-handler j-read-char (sm melded-stream stream)
eof-error-p eof-value blocking-p)))
(defun %unread-char (stream character)
(declare (type simple-stream stream) (ignore character))
(with-stream-class (simple-stream stream)
(%check stream :input)
(if (zerop (sm last-char-read-size stream))
(error "Nothing to unread.")
(progn
(funcall-stm-handler j-unread-char (sm melded-stream stream) nil)
(remove-stream-instance-flags stream :eof)
(setf (sm last-char-read-size stream) 0)))))
(defun %peek-char (stream peek-type eof-error-p eof-value recursive-p)
(declare (type simple-stream stream)
(ignore recursive-p))
(with-stream-class (simple-stream stream)
(%check stream :input)
(when (any-stream-instance-flags stream :eof)
(return-from %peek-char
(sb-impl::eof-or-lose stream eof-error-p eof-value)))
(let* ((encap (sm melded-stream stream))
(char (funcall-stm-handler j-read-char encap
eof-error-p stream t)))
(cond ((eq char stream) eof-value)
((characterp peek-type)
(do ((char char (funcall-stm-handler j-read-char encap
eof-error-p
stream t)))
((or (eq char stream) (char= char peek-type))
(unless (eq char stream)
(funcall-stm-handler j-unread-char encap t))
(if (eq char stream) eof-value char))))
((eq peek-type t)
(do ((char char (funcall-stm-handler j-read-char encap
eof-error-p
stream t)))
((or (eq char stream)
(not (sb-impl::whitespace[2]p char)))
(unless (eq char stream)
(funcall-stm-handler j-unread-char encap t))
(if (eq char stream) eof-value char))))
(t
(funcall-stm-handler j-unread-char encap t)
char)))))
(defun %listen (stream width)
(declare (type simple-stream stream))
;; WIDTH is number of octets which must be available; any value
;; other than 1 is treated as 'character.
(with-stream-class (simple-stream stream)
(%check stream :input)
(when (any-stream-instance-flags stream :eof)
(return-from %listen nil))
(if (not (or (eql width 1) (null width)))
(funcall-stm-handler j-listen (sm melded-stream stream))
(or (< (sm buffpos stream) (sm buffer-ptr stream))
;; Attempt buffer refill
(when (and (not (any-stream-instance-flags stream :dual :string))
(>= (sm mode stream) 0))
;; single-channel stream dirty -> write data before reading
(flush-buffer stream nil))
(>= (refill-buffer stream nil) width)))))
(defun %clear-input (stream buffer-only)
(declare (type simple-stream stream))
(with-stream-class (simple-stream stream)
(%check stream :input)
(setf (sm buffpos stream) 0
(sm buffer-ptr stream) 0
(sm last-char-read-size stream) 0
#|(sm unread-past-soft-eof stream) nil|#)
#| (setf (sm reread-count stream) 0) on dual-channel streams? |#
)
(device-clear-input stream buffer-only))
(defun %read-byte (stream eof-error-p eof-value)
(declare (type simple-stream stream))
(with-stream-class (simple-stream stream)
(%check stream :input)
(if (any-stream-instance-flags stream :eof)
(sb-impl::eof-or-lose stream eof-error-p eof-value)
(etypecase stream
(single-channel-simple-stream
(read-byte-internal stream eof-error-p eof-value t))
(dual-channel-simple-stream
(read-byte-internal stream eof-error-p eof-value t))
(string-simple-stream
(with-stream-class (string-simple-stream stream)
(let ((encap (sm input-handle stream)))
(unless encap
(error 'simple-type-error
:datum stream
:expected-type 'stream
:format-control "Can't read-byte on string streams"
:format-arguments '()))
(prog1
(read-byte encap eof-error-p eof-value)
(setf (sm last-char-read-size stream) 0
(sm encapsulated-char-read-size stream) 0)))))))))
(defun %write-char (stream character)
(declare (type simple-stream stream))
(with-stream-class (simple-stream stream)
(%check stream :output)
(funcall-stm-handler-2 j-write-char character (sm melded-stream stream))))
(defun %fresh-line (stream)
(declare (type simple-stream stream))
(with-stream-class (simple-stream stream)
(%check stream :output)
(when (/= (or (sm charpos stream) 1) 0)
(funcall-stm-handler-2 j-write-char #\Newline (sm melded-stream stream))
t)))
(defun %write-string (stream string start end)
(declare (type simple-stream stream))
(with-stream-class (simple-stream stream)
(%check stream :output)
(funcall-stm-handler-2 j-write-chars string (sm melded-stream stream)
start end)))
(defun %line-length (stream)
(declare (type simple-stream stream))
(%check stream :output)
;; implement me
nil)
(defun %finish-output (stream)
(declare (type simple-stream stream))
(with-stream-class (simple-stream stream)
(%check stream :output)
(when (sm handler stream)
(do ()
((null (sm pending stream)))
(sb-sys:serve-all-events)))
(etypecase stream
(single-channel-simple-stream
;(when (and (> (sm mode stream) 0) (> (sm buffer-ptr stream) 0))
; (setf (device-file-position stream)
; (- (device-file-position stream) (sm buffer-ptr stream))))
;(device-write stream :flush 0 nil t)
(flush-buffer stream t)
(setf (sm buffpos stream) 0))
(dual-channel-simple-stream
(with-stream-class (dual-channel-simple-stream stream)
(device-write stream :flush 0 nil t)
(setf (sm outpos stream) 0)))
(string-simple-stream
(device-write stream :flush 0 nil t))))
nil)
(defun %force-output (stream)
(declare (type simple-stream stream))
(with-stream-class (simple-stream stream)
(%check stream :output)
(etypecase stream
(single-channel-simple-stream
;(when (> (sm buffer-ptr stream) 0)
; (setf (device-file-position stream)
; (- (device-file-position stream) (sm buffer-ptr stream))))
;(device-write stream :flush 0 nil nil)
(flush-buffer stream nil)
(setf (sm buffpos stream) 0))
(dual-channel-simple-stream
(with-stream-class (dual-channel-simple-stream stream)
(device-write stream :flush 0 nil nil)
(setf (sm outpos stream) 0)))
(string-simple-stream
(device-write stream :flush 0 nil nil))))
nil)
(defun %clear-output (stream)
(declare (type simple-stream stream))
(with-stream-class (simple-stream stream)
(%check stream :output)
(when (sm handler stream)
(sb-sys:remove-fd-handler (sm handler stream))
(setf (sm handler stream) nil
(sm pending stream) nil))
(etypecase stream
(single-channel-simple-stream
(with-stream-class (single-channel-simple-stream stream)
(case (sm mode stream)
(1 (setf (sm buffpos stream) 0))
(3 (setf (sm mode stream) 0)))))
(dual-channel-simple-stream
(setf (sm outpos stream) 0))
(string-simple-stream
nil))
(device-clear-output stream)))
(defun %write-byte (stream integer)
(declare (type simple-stream stream))
(with-stream-class (simple-stream stream)
(%check stream :output)
(etypecase stream
(single-channel-simple-stream
(with-stream-class (single-channel-simple-stream stream)
(let ((ptr (sm buffpos stream)))
(when (>= ptr (sm buf-len stream))
(setf ptr (flush-buffer stream t)))
(setf (sm buffpos stream) (1+ ptr))
(setf (sm charpos stream) nil)
(setf (bref (sm buffer stream) ptr) integer)
(sc-set-dirty stream))))
(dual-channel-simple-stream
(with-stream-class (dual-channel-simple-stream stream)
(let ((ptr (sm outpos stream)))
(when (>= ptr (sm max-out-pos stream))
(setf ptr (flush-out-buffer stream t)))
(setf (sm outpos stream) (1+ ptr))
(setf (sm charpos stream) nil)
(setf (bref (sm out-buffer stream) ptr) integer))))
(string-simple-stream
(with-stream-class (string-simple-stream stream)
(let ((encap (sm output-handle stream)))
(unless encap
(error 'simple-type-error
:datum stream
:expected-type 'stream
:format-control "Can't write-byte on string streams."
:format-arguments '()))
(write-byte integer encap)))))))
(defun %read-sequence (stream seq start end partial-fill)
(declare (type simple-stream stream)
(type sequence seq)
(type sb-int:index start end)
(type boolean partial-fill))
(with-stream-class (simple-stream stream)
(%check stream :input)
(when (any-stream-instance-flags stream :eof)
(return-from %read-sequence 0))
(when (and (not (any-stream-instance-flags stream :dual :string))
(sc-dirty-p stream))
(flush-buffer stream t))
(etypecase seq
(string
(funcall-stm-handler j-read-chars (sm melded-stream stream) seq nil
start end
(if partial-fill :bnb t)))
((or (simple-array (unsigned-byte 8) (*))
(simple-array (signed-byte 8) (*)))
(when (any-stream-instance-flags stream :string)
(error "Can't read into byte sequence from a string stream."))
;; "read-vector" equivalent, but blocking if partial-fill is NIL
;; FIXME: this could be implemented faster via buffer-copy
(loop with encap = (sm melded-stream stream)
for index from start below end
for byte = (read-byte-internal encap nil nil t)
then (read-byte-internal encap nil nil partial-fill)
while byte
do (setf (bref seq index) byte)
finally (return index)))
;; extend to work on other sequences: repeated read-byte
)))
(defun %write-sequence (stream seq start end)
(declare (type simple-stream stream)
(type sequence seq)
(type sb-int:index start end))
(with-stream-class (simple-stream stream)
(%check stream :output)
(etypecase seq
(string
(funcall-stm-handler-2 j-write-chars seq (sm melded-stream stream)
start end))
((or (simple-array (unsigned-byte 8) (*))
(simple-array (signed-byte 8) (*)))
;; "write-vector" equivalent
(setf (sm charpos stream) nil)
(etypecase stream
(single-channel-simple-stream
(with-stream-class (single-channel-simple-stream stream)
(loop with max-ptr fixnum = (sm buf-len stream)
for src-pos fixnum = start then (+ src-pos count)
for src-rest fixnum = (- end src-pos)
while (> src-rest 0) ; FIXME: this is non-ANSI
for ptr fixnum = (let ((ptr (sm buffpos stream)))
(if (>= ptr max-ptr)
(flush-buffer stream t)
ptr))
for buf-rest fixnum = (- max-ptr ptr)
for count fixnum = (min buf-rest src-rest)
do (progn (setf (sm mode stream) 1)
(setf (sm buffpos stream) (+ ptr count))
(buffer-copy seq src-pos (sm buffer stream) ptr count)))))
(dual-channel-simple-stream
(with-stream-class (dual-channel-simple-stream stream)
(loop with max-ptr fixnum = (sm max-out-pos stream)
for src-pos fixnum = start then (+ src-pos count)
for src-rest fixnum = (- end src-pos)
while (> src-rest 0) ; FIXME: this is non-ANSI
for ptr fixnum = (let ((ptr (sm outpos stream)))
(if (>= ptr max-ptr)
(flush-out-buffer stream t)
ptr))
for buf-rest fixnum = (- max-ptr ptr)
for count fixnum = (min buf-rest src-rest)
do (progn (setf (sm outpos stream) (+ ptr count))
(buffer-copy seq src-pos (sm out-buffer stream) ptr count)))))
(string-simple-stream
(error 'simple-type-error
:datum stream
:expected-type 'stream
:format-control "Can't write a byte sequence to a string stream."
:format-arguments '())))
)
;; extend to work on other sequences: repeated write-byte
))
seq)
(defun read-vector (vector stream &key (start 0) end (endian-swap :byte-8))
(declare (type (sb-kernel:simple-unboxed-array (*)) vector)
(type stream stream))
;; START and END are octet offsets, not vector indices! [Except for strings]
;; Return value is index of next octet to be read into (i.e., start+count)
(etypecase stream
(simple-stream
(with-stream-class (simple-stream stream)
(cond ((stringp vector)
(let* ((start (or start 0))
(end (or end (length vector)))
(encap (sm melded-stream stream))
(char (funcall-stm-handler j-read-char encap nil nil t)))
(when char
(setf (schar vector start) char)
(incf start)
(+ start (funcall-stm-handler j-read-chars encap vector nil
start end nil)))))
((any-stream-instance-flags stream :string)
(error "Can't READ-BYTE on string streams."))
(t
(do* ((encap (sm melded-stream stream))
(index (or start 0) (1+ index))
(end (or end (* (length vector) (vector-elt-width vector))))
(endian-swap (endian-swap-value vector endian-swap))
(flag t nil))
((>= index end) index)
(let ((byte (read-byte-internal encap nil nil flag)))
(unless byte
(return index))
(setf (bref vector (logxor index endian-swap)) byte)))))))
((or ansi-stream fundamental-stream)
(unless (typep vector '(or string
(simple-array (signed-byte 8) (*))
(simple-array (unsigned-byte 8) (*))))
(error "Wrong vector type for read-vector on stream not of type simple-stream."))
(read-sequence vector stream :start (or start 0) :end end))))
;;;
;;; USER-LEVEL FUNCTIONS
;;;
(defmethod open-stream-p ((stream simple-stream))
(any-stream-instance-flags stream :input :output))
(defmethod input-stream-p ((stream simple-stream))
(any-stream-instance-flags stream :input))
(defmethod output-stream-p ((stream simple-stream))
(any-stream-instance-flags stream :output))
(defmethod stream-element-type ((stream simple-stream))
'(unsigned-byte 8))
(defun interactive-stream-p (stream)
"Return true if Stream does I/O on a terminal or other interactive device."
(etypecase stream
(simple-stream
(%check stream :open)
(any-stream-instance-flags stream :interactive))
(ansi-stream
(funcall (sb-kernel:ansi-stream-misc stream) stream :interactive-p))
(fundamental-stream
nil)))
(defun (setf interactive-stream-p) (flag stream)
(typecase stream
(simple-stream
(%check stream :open)
(if flag
(add-stream-instance-flags stream :interactive)
(remove-stream-instance-flags stream :interactive)))
(t
(error 'simple-type-error
:datum stream
:expected-type 'simple-stream
:format-control "Can't set interactive flag on ~S."
:format-arguments (list stream)))))
(defun file-string-length (stream object)
(declare (type (or string character) object) (type stream stream))
"Return the delta in STREAM's FILE-POSITION that would be caused by writing
OBJECT to STREAM. Non-trivial only in implementations that support
international character sets."
(typecase stream
(simple-stream (%file-string-length stream object))
(t
(etypecase object
(character 1)
(string (length object))))))
(defun stream-external-format (stream)
"Returns Stream's external-format."
(etypecase stream
(simple-stream
(with-stream-class (simple-stream)
(%check stream :open)
(sm external-format stream)))
(ansi-stream
:default)
(fundamental-stream
:default)))
(defun open (filename &rest options
&key (direction :input)
(element-type 'character element-type-given)
if-exists if-does-not-exist
(external-format :default)
class mapped input-handle output-handle
&allow-other-keys)
"Return a stream which reads from or writes to Filename.
Defined keywords:
:direction - one of :input, :output, :io, or :probe
:element-type - type of object to read or write, default BASE-CHAR
:if-exists - one of :error, :new-version, :rename, :rename-and-delete,
:overwrite, :append, :supersede or NIL
:if-does-not-exist - one of :error, :create or NIL
:external-format - :default
See the manual for details.
The following are simple-streams-specific additions:
:class - class of stream object to be created
:mapped - T to open a memory-mapped file
:input-handle - a stream or Unix file descriptor to read from
:output-handle - a stream or Unix file descriptor to write to"
(declare (ignore element-type external-format input-handle output-handle
if-exists if-does-not-exist))
(let ((class (or class 'sb-sys:fd-stream))
(options (copy-list options))
(filespec (merge-pathnames filename)))
(cond ((eq class 'sb-sys:fd-stream)
(remf options :class)
(remf options :mapped)
(remf options :input-handle)
(remf options :output-handle)
(apply #'open-fd-stream filespec options))
((subtypep class 'simple-stream)
(when element-type-given
(cerror "Do it anyway."
"Can't create simple-streams with an element-type."))
(when (and (eq class 'file-simple-stream) mapped)
(setq class 'mapped-file-simple-stream)
(setf (getf options :class) 'mapped-file-simple-stream))
(when (subtypep class 'file-simple-stream)
(when (eq direction :probe)
(setq class 'probe-simple-stream)))
(apply #'make-instance class :filename filespec options))
((subtypep class 'sb-gray:fundamental-stream)
(remf options :class)
(remf options :mapped)
(remf options :input-handle)
(remf options :output-handle)
(make-instance class :lisp-stream
(apply #'open-fd-stream filespec options)))
(t (error "Don't know how to handle the stream class ~A"
(etypecase class
(symbol (find-class class t))
(class class)))))))
(declaim (inline read-byte read-char read-char-no-hang unread-char))
(defun read-byte (stream &optional (eof-error-p t) eof-value)
"Returns the next byte of the Stream."
(let ((stream (sb-impl::in-synonym-of stream)))
(etypecase stream
(simple-stream
(%read-byte stream eof-error-p eof-value))
(ansi-stream
(sb-impl::ansi-stream-read-byte stream eof-error-p eof-value nil))
(fundamental-stream
(let ((char (sb-gray:stream-read-byte stream)))
(if (eq char :eof)
(sb-impl::eof-or-lose stream eof-error-p eof-value)
char))))))
(defun read-char (&optional (stream *standard-input*) (eof-error-p t)
eof-value recursive-p)
"Inputs a character from Stream and returns it."
(let ((stream (sb-impl::in-synonym-of stream)))
(etypecase stream
(simple-stream
(%read-char stream eof-error-p eof-value recursive-p t))
(ansi-stream
(sb-impl::ansi-stream-read-char stream eof-error-p eof-value
recursive-p))
(fundamental-stream
(let ((char (sb-gray:stream-read-char stream)))
(if (eq char :eof)
(sb-impl::eof-or-lose stream eof-error-p eof-value)
char))))))
(defun read-char-no-hang (&optional (stream *standard-input*) (eof-error-p t)
eof-value recursive-p)
"Returns the next character from the Stream if one is availible, or nil."
(let ((stream (sb-impl::in-synonym-of stream)))
(etypecase stream
(simple-stream
(%check stream :input)
(with-stream-class (simple-stream)
(funcall-stm-handler j-read-char stream eof-error-p eof-value nil)))
(ansi-stream
(sb-impl::ansi-stream-read-char-no-hang stream eof-error-p eof-value
recursive-p))
(fundamental-stream
(let ((char (sb-gray:stream-read-char-no-hang stream)))
(if (eq char :eof)
(sb-impl::eof-or-lose stream eof-error-p eof-value)
char))))))
(defun unread-char (character &optional (stream *standard-input*))
"Puts the Character back on the front of the input Stream."
(let ((stream (sb-impl::in-synonym-of stream)))
(etypecase stream
(simple-stream
(%unread-char stream character))
(ansi-stream
(sb-impl::ansi-stream-unread-char character stream))
(fundamental-stream
(sb-gray:stream-unread-char stream character))))
nil)
(declaim (notinline read-byte read-char read-char-no-hang unread-char))
(defun peek-char (&optional (peek-type nil) (stream *standard-input*)
(eof-error-p t) eof-value recursive-p)
"Peeks at the next character in the input Stream. See manual for details."
(let ((stream (sb-impl::in-synonym-of stream)))
(etypecase stream
(simple-stream
(%peek-char stream peek-type eof-error-p eof-value recursive-p))
;; FIXME: Broken on ECHO-STREAM (cf internal implementation?) --
;; CSR, 2004-01-19
(ansi-stream
(sb-impl::ansi-stream-peek-char peek-type stream eof-error-p eof-value
recursive-p))
(fundamental-stream
(cond ((characterp peek-type)
(do ((char (sb-gray:stream-read-char stream)
(sb-gray:stream-read-char stream)))
((or (eq char :eof) (char= char peek-type))
(cond ((eq char :eof)
(sb-impl::eof-or-lose stream eof-error-p eof-value))
(t
(sb-gray:stream-unread-char stream char)
char)))))
((eq peek-type t)
(do ((char (sb-gray:stream-read-char stream)
(sb-gray:stream-read-char stream)))
((or (eq char :eof) (not (sb-impl::whitespace[2]p char)))
(cond ((eq char :eof)
(sb-impl::eof-or-lose stream eof-error-p eof-value))
(t
(sb-gray:stream-unread-char stream char)
char)))))
(t
(let ((char (sb-gray:stream-peek-char stream)))
(if (eq char :eof)
(sb-impl::eof-or-lose stream eof-error-p eof-value)
char))))))))
(defun listen (&optional (stream *standard-input*) (width 1))
"Returns T if WIDTH octets are available on STREAM. If WIDTH is
given as 'CHARACTER, check for a character. Note: the WIDTH argument
is supported only on simple-streams."
;; WIDTH is number of octets which must be available; any value
;; other than 1 is treated as 'character.
(let ((stream (sb-impl::in-synonym-of stream)))
(etypecase stream
(simple-stream
(%listen stream width))
(ansi-stream
(sb-impl::ansi-stream-listen stream))
(fundamental-stream
(sb-gray:stream-listen stream)))))
(defun read-line (&optional (stream *standard-input*) (eof-error-p t)
eof-value recursive-p)
"Returns a line of text read from the Stream as a string, discarding the
newline character."
(let ((stream (sb-impl::in-synonym-of stream)))
(etypecase stream
(simple-stream
(%read-line stream eof-error-p eof-value recursive-p))
(ansi-stream
(sb-impl::ansi-stream-read-line stream eof-error-p eof-value
recursive-p))
(fundamental-stream
(multiple-value-bind (string eof) (sb-gray:stream-read-line stream)
(if (and eof (zerop (length string)))
(values (sb-impl::eof-or-lose stream eof-error-p eof-value) t)
(values string eof)))))))
(defun read-sequence (seq stream &key (start 0) (end nil) partial-fill)
"Destructively modify SEQ by reading elements from STREAM.
SEQ is bounded by START and END. SEQ is destructively modified by
copying successive elements into it from STREAM. If the end of file
for STREAM is reached before copying all elements of the subsequence,
then the extra elements near the end of sequence are not updated, and
the index of the next element is returned."
(let ((stream (sb-impl::in-synonym-of stream))
(end (or end (length seq))))
(etypecase stream
(simple-stream
(with-stream-class (simple-stream stream)
(%read-sequence stream seq start end partial-fill)))
(ansi-stream
(sb-impl::ansi-stream-read-sequence seq stream start end))
(fundamental-stream
(sb-gray:stream-read-sequence stream seq start end)))))
(defun clear-input (&optional (stream *standard-input*) buffer-only)
"Clears any buffered input associated with the Stream."
(let ((stream (sb-impl::in-synonym-of stream)))
(etypecase stream
(simple-stream
(%clear-input stream buffer-only))
(ansi-stream
(sb-impl::ansi-stream-clear-input stream))
(fundamental-stream
(sb-gray:stream-clear-input stream))))
nil)
(defun write-byte (integer stream)
"Outputs an octet to the Stream."
(let ((stream (sb-impl::out-synonym-of stream)))
(etypecase stream
(simple-stream
(%write-byte stream integer))
(ansi-stream
(funcall (sb-kernel:ansi-stream-bout stream) stream integer))
(fundamental-stream
(sb-gray:stream-write-byte stream integer))))
integer)
(defun write-char (character &optional (stream *standard-output*))
"Outputs the Character to the Stream."
(let ((stream (sb-impl::out-synonym-of stream)))
(etypecase stream
(simple-stream
(%write-char stream character))
(ansi-stream
(funcall (sb-kernel:ansi-stream-out stream) stream character))
(fundamental-stream
(sb-gray:stream-write-char stream character))))
character)
(defun write-string (string &optional (stream *standard-output*)
&key (start 0) (end nil))
"Outputs the String to the given Stream."
(let ((stream (sb-impl::out-synonym-of stream))
(end (sb-impl::%check-vector-sequence-bounds string start end)))
(etypecase stream
(simple-stream
(%write-string stream string start end)
string)
(ansi-stream
(sb-impl::ansi-stream-write-string string stream start end))
(fundamental-stream
(sb-gray:stream-write-string stream string start end)))))
(defun write-line (string &optional (stream *standard-output*)
&key (start 0) end)
(declare (type string string))
(let ((stream (sb-impl::out-synonym-of stream))
(end (sb-impl::%check-vector-sequence-bounds string start end)))
(etypecase stream
(simple-stream
(%check stream :output)
(with-stream-class (simple-stream stream)
(funcall-stm-handler-2 j-write-chars string stream start end)
(funcall-stm-handler-2 j-write-char #\Newline stream)))
(ansi-stream
(sb-impl::ansi-stream-write-string string stream start end)
(funcall (sb-kernel:ansi-stream-out stream) stream #\Newline))
(fundamental-stream
(sb-gray:stream-write-string stream string start end)
(sb-gray:stream-terpri stream))))
string)
(defun write-sequence (seq stream &key (start 0) (end nil))
"Write the elements of SEQ bounded by START and END to STREAM."
(let ((stream (sb-impl::out-synonym-of stream))
(end (or end (length seq))))
(etypecase stream
(simple-stream
(%write-sequence stream seq start end))
(ansi-stream
(sb-impl::ansi-stream-write-sequence seq stream start end))
(fundamental-stream
(sb-gray:stream-write-sequence stream seq start end)))))
(defun terpri (&optional (stream *standard-output*))
"Outputs a new line to the Stream."
(let ((stream (sb-impl::out-synonym-of stream)))
(etypecase stream
(simple-stream
(%check stream :output)
(with-stream-class (simple-stream stream)
(funcall-stm-handler-2 j-write-char #\Newline stream)))
(ansi-stream
(funcall (sb-kernel:ansi-stream-out stream) stream #\Newline))
(fundamental-stream
(sb-gray:stream-terpri stream))))
nil)
(defun fresh-line (&optional (stream *standard-output*))
"Outputs a new line to the Stream if it is not positioned at the beginning of
a line. Returns T if it output a new line, nil otherwise."
(let ((stream (sb-impl::out-synonym-of stream)))
(etypecase stream
(simple-stream
(%fresh-line stream))
(ansi-stream
(sb-impl::ansi-stream-fresh-line stream))
(fundamental-stream
(sb-gray:stream-fresh-line stream)))))
(defun finish-output (&optional (stream *standard-output*))
"Attempts to ensure that all output sent to the Stream has reached its
destination, and only then returns."
(let ((stream (sb-impl::out-synonym-of stream)))
(etypecase stream
(simple-stream
(%finish-output stream))
(ansi-stream
(funcall (sb-kernel:ansi-stream-misc stream) stream :finish-output))
(fundamental-stream
(sb-gray:stream-finish-output stream))))
nil)
(defun force-output (&optional (stream *standard-output*))
"Attempts to force any buffered output to be sent."
(let ((stream (sb-impl::out-synonym-of stream)))
(etypecase stream
(simple-stream
(%force-output stream))
(ansi-stream
(funcall (sb-kernel:ansi-stream-misc stream) stream :force-output))
(fundamental-stream
(sb-gray:stream-force-output stream))))
nil)
(defun clear-output (&optional (stream *standard-output*))
"Clears the given output Stream."
(let ((stream (sb-impl::out-synonym-of stream)))
(etypecase stream
(simple-stream
(%clear-output stream))
(ansi-stream
(funcall (sb-kernel:ansi-stream-misc stream) stream :clear-output))
(fundamental-stream
(sb-gray:stream-clear-output stream))))
nil)
(defun file-position (stream &optional position)
"With one argument returns the current position within the file
File-Stream is open to. If the second argument is supplied, then
this becomes the new file position. The second argument may also
be :start or :end for the start and end of the file, respectively."
(declare (type (or sb-int:index (member nil :start :end)) position))
(etypecase stream
(simple-stream
(%file-position stream position))
(ansi-stream
(sb-impl::ansi-stream-file-position stream position))))
(defun file-length (stream)
"This function returns the length of the file that File-Stream is open to."
(etypecase stream
(simple-stream
(%file-length stream))
(ansi-stream
(sb-impl::stream-must-be-associated-with-file stream)
(funcall (sb-kernel:ansi-stream-misc stream) stream :file-length))))
(defun charpos (&optional (stream *standard-output*))
"Returns the number of characters on the current line of output of the given
Stream, or Nil if that information is not availible."
(let ((stream (sb-impl::out-synonym-of stream)))
(etypecase stream
(simple-stream
(with-stream-class (simple-stream stream)
(%check stream :open)
(sm charpos stream)))
(ansi-stream
(funcall (sb-kernel:ansi-stream-misc stream) stream :charpos))
(fundamental-stream
(sb-gray:stream-line-column stream)))))
(defun line-length (&optional (stream *standard-output*))
"Returns the number of characters in a line of output of the given
Stream, or Nil if that information is not availible."
(let ((stream (sb-impl::out-synonym-of stream)))
(etypecase stream
(simple-stream
(%check stream :output)
;; TODO (sat 2003-04-02): a way to specify a line length would
;; be good, I suppose. Returning nil here means
;; sb-pretty::default-line-length is used.
nil)
(ansi-stream
(funcall (sb-kernel:ansi-stream-misc stream) stream :line-length))
(fundamental-stream
(sb-gray:stream-line-length stream)))))
(defun wait-for-input-available (stream &optional timeout)
"Waits for input to become available on the Stream and returns T. If
Timeout expires, Nil is returned."
(let ((stream (sb-impl::in-synonym-of stream)))
(etypecase stream
(fixnum
(sb-sys:wait-until-fd-usable stream :input timeout))
(simple-stream
(%check stream :input)
(with-stream-class (simple-stream stream)
(or (< (sm buffpos stream) (sm buffer-ptr stream))
(wait-for-input-available (sm input-handle stream) timeout))))
(two-way-stream
(wait-for-input-available (two-way-stream-input-stream stream) timeout))
(synonym-stream
(wait-for-input-available (symbol-value (synonym-stream-symbol stream))
timeout))
(sb-sys:fd-stream
(or (< (sb-impl::fd-stream-in-index stream)
(length (sb-impl::fd-stream-in-buffer stream)))
(wait-for-input-available (sb-sys:fd-stream-fd stream) timeout))))))
;; Make PATHNAME and NAMESTRING work
(defun sb-int:file-name (stream &optional new-name)
(typecase stream
(file-simple-stream
(with-stream-class (file-simple-stream stream)
(cond (new-name
(%file-rename stream new-name))
(t
(%file-name stream)))))
(sb-sys:fd-stream
(cond (new-name
(setf (sb-impl::fd-stream-pathname stream) new-name)
(setf (sb-impl::fd-stream-file stream)
(%file-namestring new-name))
t)
(t
(sb-impl::fd-stream-pathname stream))))))