Newer
Older
`(defun ,name (stream eof-errorp eof-value)
(or (pop (echo-stream-unread-stuff stream))
(let* ((in (echo-stream-input-stream stream))
(out (echo-stream-output-stream stream))
(result (,fun in nil :eof)))
(cond ((eq result :eof)
(eof-or-lose stream eof-errorp eof-value))
(t
(if (lisp-stream-p out)
(funcall (,out-slot out) out result)
(,stream-method out result))
result)))))))
(in-fun echo-in read-char lisp-stream-out stream-write-char)
(in-fun echo-bin read-byte lisp-stream-bout stream-write-byte))
(defun echo-misc (stream operation &optional arg1 arg2)
(let* ((in (two-way-stream-input-stream stream))
(out (two-way-stream-output-stream stream)))
(:listen
(or (not (null (echo-stream-unread-stuff stream)))
(if (lisp-stream-p in)
(or (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length)
(funcall (lisp-stream-misc in) in :listen))
(stream-misc-dispatch in :listen))))
(:unread (push arg1 (echo-stream-unread-stuff stream)))
(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 (lisp-stream-p in)
(funcall (lisp-stream-misc in) in operation arg1 arg2)
(stream-misc-dispatch in operation arg1 arg2))
(if (lisp-stream-p out)
(funcall (lisp-stream-misc out) out operation arg1 arg2)
(stream-misc-dispatch out operation arg1 arg2)))))))
(defun %print-echo-stream (s stream d)
(declare (ignore d))
(format stream "#<Echo Stream, Input = ~S, Output = ~S>"
(two-way-stream-input-stream s)
(two-way-stream-output-stream s)))
(setf (documentation 'make-echo-stream 'function)
"Returns a bidirectional stream which gets its input from Input-Stream and
sends its output to Output-Stream. In addition, all input is echoed to
the output stream")
;;;; String Input Streams:
(defstruct (string-input-stream
(in #'string-inch)
(bin #'string-binch)
(n-bin #'string-stream-read-n-bytes)
(misc #'string-in-misc))
(:print-function %print-string-input-stream)
;(:constructor nil)
(:constructor internal-make-string-input-stream
(string current end)))
(current nil :type index)
(end nil :type index))
(defun %print-string-input-stream (s stream d)
(declare (ignore s d))
(write-string "#<String-Input Stream>" stream))
(defun string-inch (stream eof-errorp eof-value)
(let ((string (string-input-stream-string stream))
(index (string-input-stream-current stream)))
(declare (simple-string string) (fixnum index))
(cond ((= index (the index (string-input-stream-end stream)))
(eof-or-lose stream eof-errorp eof-value))
(t
(setf (string-input-stream-current stream) (1+ index))
(aref string index)))))
(defun string-binch (stream eof-errorp eof-value)
(let ((string (string-input-stream-string stream))
(index (string-input-stream-current stream)))
(declare (simple-string string)
(type index index))
(cond ((= index (the index (string-input-stream-end stream)))
(eof-or-lose stream eof-errorp eof-value))
(t
(setf (string-input-stream-current stream) (1+ index))
(char-code (aref string index))))))
(defun string-stream-read-n-bytes (stream buffer start requested eof-errorp)
(declare (type string-input-stream stream)
(type index start requested))
(let* ((string (string-input-stream-string stream))
(index (string-input-stream-current stream))
(available (- (string-input-stream-end stream) index))
(copy (min available requested)))
(declare (simple-string string)
(type index index available copy))
(when (plusp copy)
(setf (string-input-stream-current stream)
(truly-the index (+ index copy)))
(system:without-gcing
(system-area-copy (vector-sap string)
(* index vm:byte-bits)
(if (typep buffer 'system-area-pointer)
buffer
(vector-sap buffer))
(* start vm:byte-bits)
(* copy vm:byte-bits))))
(if (and (> requested copy) eof-errorp)
(error 'end-of-file :stream stream)
copy)))
(:file-position
(if arg1
(setf (string-input-stream-current stream) arg1)
(string-input-stream-current stream)))
(:file-length (length (string-input-stream-string stream)))
(:listen (or (/= (the fixnum (string-input-stream-current stream))
(the fixnum (string-input-stream-end stream)))
:eof))
(:element-type 'base-char)))
(defun make-string-input-stream (string &optional
(start 0) (end (length string)))
"Returns an input stream which will supply the characters of String between
Start and End in order."
(declare (type string string)
(type index start)
(internal-make-string-input-stream (coerce string 'simple-string)
start end))
;;;; String Output Streams:
(defstruct (string-output-stream
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
(out #'string-ouch)
(sout #'string-sout)
(misc #'string-out-misc))
(:print-function %print-string-output-stream)
(:constructor make-string-output-stream ()))
;; The string we throw stuff in.
(string (make-string 40) :type simple-string)
;; Index of the next location to use.
(index 0 :type fixnum))
(defun %print-string-output-stream (s stream d)
(declare (ignore s d))
(write-string "#<String-Output Stream>" stream))
(setf (documentation 'make-string-output-stream 'function)
"Returns an Output stream which will accumulate all output given it for
the benefit of the function Get-Output-Stream-String.")
(defun string-ouch (stream character)
(let ((current (string-output-stream-index stream))
(workspace (string-output-stream-string stream)))
(declare (simple-string workspace) (fixnum current))
(if (= current (the fixnum (length workspace)))
(let ((new-workspace (make-string (* current 2))))
(replace new-workspace workspace)
(setf (aref new-workspace current) character)
(setf (string-output-stream-string stream) new-workspace))
(setf (aref workspace current) character))
(setf (string-output-stream-index stream) (1+ current))))
(defun string-sout (stream string start end)
(declare (simple-string string) (fixnum start end))
(let* ((current (string-output-stream-index stream))
(length (- end start))
(dst-end (+ length current))
(workspace (string-output-stream-string stream)))
(declare (simple-string workspace)
(fixnum current length dst-end))
(if (> dst-end (the fixnum (length workspace)))
(let ((new-workspace (make-string (+ (* current 2) length))))
(replace new-workspace workspace :end2 current)
(replace new-workspace string
:start1 current :end1 dst-end
:start2 start :end2 end)
(replace workspace string
:start1 current :end1 dst-end
:start2 start :end2 end))
(setf (string-output-stream-index stream) dst-end)))
(defun string-out-misc (stream operation &optional arg1 arg2)
(:file-position
(if (null arg1)
(:charpos
(do ((index (1- (the fixnum (string-output-stream-index stream)))
(1- index))
(count 0 (1+ count))
(string (string-output-stream-string stream)))
((< index 0) count)
(declare (simple-string string)
(fixnum index count))
(if (char= (schar string index) #\newline)
(return count))))
(:element-type 'base-char)))
(defun get-output-stream-string (stream)
"Returns a string of all the characters sent to a stream made by
Make-String-Output-Stream since the last call to this function."
(declare (type string-output-stream stream))
(let* ((length (string-output-stream-index stream))
(result (make-string length)))
(replace result (string-output-stream-string stream))
(setf (string-output-stream-index stream) 0)
result))
(defun dump-output-stream-string (in-stream out-stream)
"Dumps the characters buffer up in the In-Stream to the Out-Stream as
Get-Output-Stream-String would return them."
(write-string* (string-output-stream-string in-stream) out-stream
0 (string-output-stream-index in-stream))
(setf (string-output-stream-index in-stream) 0))
;;;; Fill-pointer streams:
;;;
;;; Fill pointer string output streams are not explicitly mentioned in
;;; the CLM, but they are required for the implementation of With-Output-To-String.
(defstruct (fill-pointer-output-stream
(out #'fill-pointer-ouch)
(sout #'fill-pointer-sout)
(misc #'fill-pointer-misc))
(:print-function
(lambda (s stream d)
(declare (ignore s d))
(write-string "#<Fill-Pointer String Output Stream>" stream)))
(:constructor make-fill-pointer-output-stream (string)))
;; The string we throw stuff in.
string)
(defun fill-pointer-ouch (stream character)
(let* ((buffer (fill-pointer-output-stream-string stream))
(current (fill-pointer buffer))
(current+1 (1+ current)))
(declare (fixnum current))
(with-array-data ((workspace buffer) (start) (end))
(declare (simple-string workspace))
(let ((offset-current (+ start current)))
(declare (fixnum offset-current))
(if (= offset-current end)
(let* ((new-length (if (zerop current) 1 (* current 2)))
(new-workspace (make-string new-length)))
(declare (simple-string new-workspace))
(%primitive byte-blt workspace start new-workspace 0 current)
(setf workspace new-workspace)
(setf offset-current current)
(set-array-header buffer workspace new-length
current+1 0 new-length nil))
(setf (fill-pointer buffer) current+1))
(setf (schar workspace offset-current) character)))
current+1))
(defun fill-pointer-sout (stream string start end)
(declare (simple-string string) (fixnum start end))
(let* ((buffer (fill-pointer-output-stream-string stream))
(current (fill-pointer buffer))
(string-len (- end start))
(dst-end (+ string-len current)))
(declare (fixnum current dst-end string-len))
(with-array-data ((workspace buffer) (dst-start) (dst-length))
(declare (simple-string workspace))
(let ((offset-dst-end (+ dst-start dst-end))
(offset-current (+ dst-start current)))
(declare (fixnum offset-dst-end offset-current))
(if (> offset-dst-end dst-length)
(let* ((new-length (+ (the fixnum (* current 2)) string-len))
(new-workspace (make-string new-length)))
(declare (simple-string new-workspace))
(%primitive byte-blt workspace dst-start new-workspace 0 current)
(setf workspace new-workspace)
(setf offset-current current)
(setf offset-dst-end dst-end)
(set-array-header buffer workspace new-length
dst-end 0 new-length nil))
(setf (fill-pointer buffer) dst-end))
(%primitive byte-blt string start
workspace offset-current offset-dst-end)))
dst-end))
(defun fill-pointer-misc (stream operation &optional arg1 arg2)
(declare (ignore arg1 arg2))
(case operation
(:charpos
(let* ((buffer (fill-pointer-output-stream-string stream))
(current (fill-pointer buffer)))
(with-array-data ((string buffer) (start) (end current))
(declare (simple-string string) (ignore start))
(let ((found (position #\newline string :test #'char=
:end end :from-end t)))
(if found
(- end (the fixnum found))
current)))))
(:element-type 'base-char)))
(out #'indenting-out)
(sout #'indenting-sout)
(misc #'indenting-misc))
(:print-function %print-indenting-stream)
(:constructor make-indenting-stream (stream)))
;; The stream we're based on:
stream
;; How much we indent on each line:
(indentation 0))
(setf (documentation 'make-indenting-stream 'function)
"Returns an output stream which indents its output by some amount.")
(defun %print-indenting-stream (s stream d)
(declare (ignore s d))
(write-string "#<Indenting Stream>" stream))
;;; Indenting-Indent writes the right number of spaces needed to indent output on
;;; the given Stream based on the specified Sub-Stream.
(defmacro indenting-indent (stream sub-stream)
`(do ((i 0 (+ i 60))
(indentation (indenting-stream-indentation ,stream)))
((>= i indentation))
(write-string*
" "
,sub-stream 0 (min 60 (- indentation i)))))
;;; Indenting-Out writes a character to an indenting stream.
(defun indenting-out (stream char)
(let ((sub-stream (indenting-stream-stream stream)))
(if (char= char #\newline)
(indenting-indent stream sub-stream))))
;;; Indenting-Sout writes a string to an indenting stream.
(defun indenting-sout (stream string start end)
(declare (simple-string string) (fixnum start end))
(do ((i start)
(sub-stream (indenting-stream-stream stream)))
((= i end))
(let ((newline (position #\newline string :start i :end end)))
(cond (newline
(indenting-indent stream sub-stream)
(setq i (+ newline 1)))
(t
(setq i end))))))
;;; Indenting-Misc just treats just the :Line-Length message differently.
;;; Indenting-Charpos says the charpos is the charpos of the base stream minus
;;; the stream's indentation.
(defun indenting-misc (stream operation &optional arg1 arg2)
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
(if (lisp-stream-p sub-stream)
(let ((method (lisp-stream-misc sub-stream)))
(case operation
(:line-length
(let ((line-length (funcall method sub-stream operation)))
(if line-length
(- line-length (indenting-stream-indentation stream)))))
(:charpos
(let ((charpos (funcall method sub-stream operation)))
(if charpos
(- charpos (indenting-stream-indentation stream)))))
(t
(funcall method sub-stream operation arg1 arg2))))
;; Fundamental-stream.
(case operation
(:line-length
(let ((line-length (stream-line-length sub-stream)))
(if line-length
(- line-length (indenting-stream-indentation stream)))))
(:charpos
(let ((charpos (stream-line-column sub-stream)))
(if charpos
(- charpos (indenting-stream-indentation stream)))))
(t
(stream-misc-dispatch sub-stream operation arg1 arg2))))))
(declaim (maybe-inline read-char unread-char read-byte listen))
;;;; Case frobbing streams, used by format ~(...~).
(defstruct (case-frob-stream
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
(:misc #'case-frob-misc))
(:constructor %make-case-frob-stream (target out sout)))
(target (required-argument) :type stream))
(defun make-case-frob-stream (target kind)
"Returns a stream that sends all output to the stream TARGET, but modifies
the case of letters, depending on KIND, which should be one of:
:upcase - convert to upper case.
:downcase - convert to lower case.
:capitalize - convert the first letter of words to upper case and the
rest of the word to lower case.
:capitalize-first - convert the first letter of the first word to upper
case and everything else to lower case."
(declare (type stream target)
(type (member :upcase :downcase :capitalize :capitalize-first)
kind)
(values stream))
(if (case-frob-stream-p target)
;; If we are going to be writing to a stream that already does case
;; frobbing, why bother frobbing the case just so it can frob it
;; again?
target
(multiple-value-bind
(out sout)
(ecase kind
(:upcase
(values #'case-frob-upcase-out
#'case-frob-upcase-sout))
(:downcase
(values #'case-frob-downcase-out
#'case-frob-downcase-sout))
(:capitalize
(values #'case-frob-capitalize-out
#'case-frob-capitalize-sout))
(:capitalize-first
(values #'case-frob-capitalize-first-out
#'case-frob-capitalize-first-sout)))
(%make-case-frob-stream target out sout))))
(defun case-frob-misc (stream op &optional arg1 arg2)
(declare (type case-frob-stream stream))
(case op
(:close)
(t
(let ((target (case-frob-stream-target stream)))
(if (lisp-stream-p target)
(funcall (lisp-stream-misc target) target op arg1 arg2)
(stream-misc-dispatch target op arg1 arg2))))))
(defun case-frob-upcase-out (stream char)
(declare (type case-frob-stream stream)
(let ((target (case-frob-stream-target stream))
(char (char-upcase char)))
(if (lisp-stream-p target)
(funcall (lisp-stream-out target) target char)
(stream-write-char target char))))
(defun case-frob-upcase-sout (stream str start end)
(declare (type case-frob-stream stream)
(type simple-base-string str)
(type index start)
(type (or index null) end))
(let* ((target (case-frob-stream-target stream))
(len (length str))
(end (or end len))
(string (if (and (zerop start) (= len end))
(string-upcase str)
(nstring-upcase (subseq str start end))))
(string-len (- end start)))
(if (lisp-stream-p target)
(funcall (lisp-stream-sout target) target string 0 string-len)
(stream-write-string target string 0 string-len))))
(defun case-frob-downcase-out (stream char)
(declare (type case-frob-stream stream)
(let ((target (case-frob-stream-target stream))
(char (char-downcase char)))
(if (lisp-stream-p target)
(funcall (lisp-stream-out target) target char)
(stream-write-char target char))))
(defun case-frob-downcase-sout (stream str start end)
(declare (type case-frob-stream stream)
(type simple-base-string str)
(type index start)
(type (or index null) end))
(let* ((target (case-frob-stream-target stream))
(len (length str))
(end (or end len))
(string (if (and (zerop start) (= len end))
(string-downcase str)
(nstring-downcase (subseq str start end))))
(string-len (- end start)))
(if (lisp-stream-p target)
(funcall (lisp-stream-sout target) target string 0 string-len)
(stream-write-string target string 0 string-len))))
(defun case-frob-capitalize-out (stream char)
(declare (type case-frob-stream stream)
(let ((target (case-frob-stream-target stream)))
(cond ((alphanumericp char)
(let ((char (char-upcase char)))
(if (lisp-stream-p target)
(funcall (lisp-stream-out target) target char)
(stream-write-char target char)))
(setf (case-frob-stream-out stream) #'case-frob-capitalize-aux-out)
(setf (case-frob-stream-sout stream)
#'case-frob-capitalize-aux-sout))
(t
(if (lisp-stream-p target)
(funcall (lisp-stream-out target) target char)
(stream-write-char target char))))))
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
(defun case-frob-capitalize-sout (stream str start end)
(declare (type case-frob-stream stream)
(type simple-base-string str)
(type index start)
(type (or index null) end))
(let* ((target (case-frob-stream-target stream))
(str (subseq str start end))
(len (length str))
(inside-word nil))
(dotimes (i len)
(let ((char (schar str i)))
(cond ((not (alphanumericp char))
(setf inside-word nil))
(inside-word
(setf (schar str i) (char-downcase char)))
(t
(setf inside-word t)
(setf (schar str i) (char-upcase char))))))
(when inside-word
(setf (case-frob-stream-out stream)
#'case-frob-capitalize-aux-out)
(setf (case-frob-stream-sout stream)
#'case-frob-capitalize-aux-sout))
(if (lisp-stream-p target)
(funcall (lisp-stream-sout target) target str 0 len)
(stream-write-string target str 0 len))))
(defun case-frob-capitalize-aux-out (stream char)
(declare (type case-frob-stream stream)
(let ((target (case-frob-stream-target stream)))
(cond ((alphanumericp char)
(let ((char (char-downcase char)))
(if (lisp-stream-p target)
(funcall (lisp-stream-out target) target char)
(stream-write-char target char))))
(if (lisp-stream-p target)
(funcall (lisp-stream-out target) target char)
(stream-write-char target char))
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
(setf (case-frob-stream-out stream)
#'case-frob-capitalize-out)
(setf (case-frob-stream-sout stream)
#'case-frob-capitalize-sout)))))
(defun case-frob-capitalize-aux-sout (stream str start end)
(declare (type case-frob-stream stream)
(type simple-base-string str)
(type index start)
(type (or index null) end))
(let* ((target (case-frob-stream-target stream))
(str (subseq str start end))
(len (length str))
(inside-word t))
(dotimes (i len)
(let ((char (schar str i)))
(cond ((not (alphanumericp char))
(setf inside-word nil))
(inside-word
(setf (schar str i) (char-downcase char)))
(t
(setf inside-word t)
(setf (schar str i) (char-upcase char))))))
(unless inside-word
(setf (case-frob-stream-out stream)
#'case-frob-capitalize-out)
(setf (case-frob-stream-sout stream)
#'case-frob-capitalize-sout))
(if (lisp-stream-p target)
(funcall (lisp-stream-sout target) target str 0 len)
(stream-write-string target str 0 len))))
(defun case-frob-capitalize-first-out (stream char)
(declare (type case-frob-stream stream)
(let ((target (case-frob-stream-target stream)))
(cond ((alphanumericp char)
(let ((char (char-upcase char)))
(if (lisp-stream-p target)
(funcall (lisp-stream-out target) target char)
(stream-write-char target char)))
(setf (case-frob-stream-out stream)
#'case-frob-downcase-out)
(setf (case-frob-stream-sout stream)
#'case-frob-downcase-sout))
(t
(if (lisp-stream-p target)
(funcall (lisp-stream-out target) target char)
(stream-write-char target char))))))
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
(defun case-frob-capitalize-first-sout (stream str start end)
(declare (type case-frob-stream stream)
(type simple-base-string str)
(type index start)
(type (or index null) end))
(let* ((target (case-frob-stream-target stream))
(str (subseq str start end))
(len (length str)))
(dotimes (i len)
(let ((char (schar str i)))
(when (alphanumericp char)
(setf (schar str i) (char-upcase char))
(do ((i (1+ i) (1+ i)))
((= i len))
(setf (schar str i) (char-downcase (schar str i))))
(setf (case-frob-stream-out stream)
#'case-frob-downcase-out)
(setf (case-frob-stream-sout stream)
#'case-frob-downcase-sout)
(return))))
(if (lisp-stream-p target)
(funcall (lisp-stream-sout target) target str 0 len)
(stream-write-string target str 0 len))))
;;;; Public interface from "EXTENSIONS" package.
(defstruct (stream-command (:print-function print-stream-command)
(:constructor make-stream-command
(name &optional args)))
(name nil :type symbol)
(args nil :type list))
(defun print-stream-command (obj str n)
(declare (ignore n))
(format str "#<Stream-Cmd ~S>" (stream-command-name obj)))
;;; GET-STREAM-COMMAND -- Public.
;;;
;;; We can't simply call the stream's misc method because nil is an
;;; ambiguous return value: does it mean text arrived, or does it mean the
;;; stream's misc method had no :get-command implementation. We can't return
;;; nil until there is text input. We don't need to loop because any stream
;;; implementing :get-command would wait until it had some input. If the
;;; LISTEN fails, then we have some random stream we must wait on.
;;;
(defun get-stream-command (stream)
"This takes a stream and waits for text or a command to appear on it. If
text appears before a command, this returns nil, and otherwise it returns
a command."
(let ((cmdp (funcall (lisp-stream-misc stream) stream :get-command)))
(cond (cmdp)
((listen stream)
nil)
(t
;; This waits for input and returns nil when it arrives.
(unread-char (read-char stream) stream)))))
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
;;; READ-SEQUENCE --
;;; Note: the multi-byte operation SYSTEM:READ-N-BYTES operates on
;;; subtypes of SIMPLE-ARRAY. Hence the distinction between simple
;;; and non simple input functions.
(defun read-sequence (seq stream &key (start 0) (end nil))
"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.
Argument(s):
SEQ: a proper SEQUENCE
STREAM: an input STREAM
START: a bounding index designator of type '(INTEGER 0 *)' (default 0)
END: a bounding index designator which be NIL or an INTEGER of
type '(INTEGER 0 *)' (default NIL)
Value(s):
POSITION: an INTEGER greater than or equal to zero, and less than or
equal to the length of the SEQ. POSITION is the index of
the first element of SEQ that was not updated, which might be
less than END because the end of file was reached."
(declare (type (or list vector) seq)) ; could be (type sequence seq)
(declare (type stream stream))
(declare (type (integer 0 *) start)) ; a list does not have a limit
(declare (type (or null (integer 0 *)) end))
(declare (values (integer 0 *)))
(let ((end (or end (length seq))))
(declare (type (integer 0 *) start end))
;; Just catch some errors earlier than it would be necessary.
(cond ((not (open-stream-p stream))
(error 'stream-error
:stream stream
:format-control "The stream is not open."))
((not (input-stream-p stream))
(error 'stream-error
:stream stream
:format-control "The stream is not open for input."))
((and seq (>= start end) 0))
(t
;; So much for object-oriented programming!
(etypecase seq
(list
(read-into-list seq stream start end))
(simple-string
(read-into-simple-string seq stream start end))
(string
(read-into-string seq stream start end))
(simple-array ; We also know that it is a 'vector'.
(read-into-simple-array seq stream start end))
(vector
(read-into-vector seq stream start end)))
))))
;;; READ-INTO-LIST, READ-INTO-LIST-1
;;; Auxiliary functions for READ-SEQUENCE. Their semantics is pretty
;;; obvious. Since lists do not have an attached element type, and
;;; since we cannot do a low-level multi-byte read operation on them,
;;; I simply dispatch on the element type of the stream and then rely
;;; on READ-BYTE and READ-CHAR to to the input.
;;;
;;; NOTE: the use of 'endp' will generate a (desired)
;;; 'type-error' if the sequence is not a "proper list".
(defun read-into-list (l stream start end)
(let ((read-function (if (subtypep (stream-element-type stream) 'character)
#'read-char
#'read-byte)))
(read-into-list-1 (nthcdr start l) start end stream read-function)))
#+:recursive
(defun read-into-list-1 (l start end stream read-function)
(declare (type list l))
(declare (type stream stream))
(declare (type (integer 0 *) start end))
(if (or (endp l) (= start end))
start
(let ((el (funcall read-function stream nil '%%RWSEQ-EOF%%)))
(cond ((eq el '%%RWSEQ-EOF%%) start)
(t (setf (first l) el)
(read-into-list-1 (rest l)
(1+ start)
end
stream
read-function))))
))
#-:iterative
(defun read-into-list-1 (l start end stream read-function)
(declare (type list l))
(declare (type stream stream))
(declare (type (integer 0 *) start end))
;; The declaration for I may be too restrictive in the case of
;; lists. But then again, it is still a huge number.
(do ((lis l (rest lis))
(i start (1+ i))
)
((or (endp lis) (>= i end)) i)
(declare (type list lis))
(declare (type index i))
(let ((el (funcall read-function stream nil '%%RWSEQ-EOF%%)))
(when (eq el '%%RWSEQ-EOF%%)
(return i))
(setf (first lis) el))
))
;;; READ-INTO-SIMPLE-STRING --
(defun read-into-simple-string (s stream start end)
(declare (type simple-string s))
(declare (type stream stream))
(declare (type index start end))
(unless (subtypep (stream-element-type stream) 'character)
(error 'type-error
:datum (read-char stream nil #\Null)
:expected-type (stream-element-type stream)
:format-control "Trying to read characters from a binary stream."))
;; Let's go as low level as it seems reasonable.
(let* ((numbytes (- end start))
(bytes-read (system:read-n-bytes stream s start numbytes nil))
)
(if (< bytes-read numbytes)
(+ start bytes-read)
end)))
(defun read-into-string (s stream start end)
(declare (type string s))
(declare (type stream stream))
(declare (type index start end))
(unless (subtypep (stream-element-type stream) 'character)
(error 'type-error
:datum (read-char stream nil #\Null)
:expected-type (stream-element-type stream)
:format-control "Trying to read characters from a binary stream."))
(do ((i start (1+ i))
(s-len (length s))
)
((or (>= i s-len) (>= i end)) i)
(declare (type index i s-len))
(let ((el (read-char stream nil '%%RWSEQ-EOF%%)))
(declare (type (or character (member %%RWSEQ-EOF%%)) el))
(when (eq el '%%RWSEQ-EOF%%)
(return i))
(setf (char s i) (the character el)))
))
;;; READ-INTO-SIMPLE-ARRAY --
;;; We definitively know that we are really reading into a vector.
;;; *read-into-simple-array-recognized-types* --
;;;
;;; Note the new feature :extended-binary-streams.
;;; Up to 18a, CMUCL has a wired in limitation to treat only 8-bits
;;; word binary streams. 'fd-read-n-bytes' is associated to a binary
;;; stream only if the fd-stream has binary type size of 1 (i.e. 1
;;; 8-bits byte). This is reflected also in the size of the input
;;; buffers.
(defparameter *read-into-simple-array-recognized-types*
'((unsigned-byte 8)
(unsigned-byte 16)
(unsigned-byte 32)
(signed-byte 8)
(signed-byte 16)
(signed-byte 32)
))
(defun read-into-simple-array (s stream start end)
;; The complex declaration is needed to make Python behave.
;; The first declaration does not work because of type promotion
;; which effectively excises the etypecase below.
;; The second declaration does not quite work because it does not
;; quite constrain the array element type.
;; (declare (type (simple-array (or unsigned-byte signed-byte) (*)) s))
;; (declare (type (simple-array * (*)) s))
(declare (type (or (simple-array (unsigned-byte 8) (*))
(simple-array (signed-byte 8) (*))
(simple-array (unsigned-byte 16) (*))
(simple-array (signed-byte 16) (*))
(simple-array (unsigned-byte 32) (*))
(simple-array (signed-byte 32) (*))
(simple-array (unsigned-byte *) (*))
(simple-array (signed-byte *) (*))
)
s))
(declare (type stream stream))
(declare (type index start end))
(let ((stream-et (stream-element-type stream)))
(cond ((subtypep (stream-element-type stream) 'character)
(error 'type-error
:datum (read-byte stream nil 0)
:expected-type (stream-element-type stream) ; Bogus?!?
:format-control
"Trying to read binary data from a text stream."))
;; Let's go as low level as it seems reasonable.
((not (member stream-et
*read-into-simple-array-recognized-types*
:test #'equal))
;; (format t ">>> Reading vector from binary stream of type ~S~%"
;; stream-et)
;; We resort to the READ-BYTE based operation.
(read-into-vector s stream start end))
((/= vm:byte-bits 8)
;; We must resort to the READ-BYTE based operation
;; also in this case.
(read-into-vector s stream start end))
;; Otherwise we can do something more interesting.
(t
(flet ((read-n-x8-bytes (stream data offset-start offset-end byte-size)
(let* ((x8-mult (truncate byte-size 8))
(numbytes (* (- offset-end offset-start) x8-mult))
(bytes-read (system:read-n-bytes stream
data
offset-start
numbytes
nil))
)
;; A check should probably be made here in order to
;; be sure that we actually read the right amount
;; of bytes. (I.e. (truncate bytes-read x8-mult)
;; should return a 0 second value.
(if (< bytes-read numbytes)
(+ offset-start (truncate bytes-read x8-mult))
offset-end)))
)
;; According to the definition of OPEN and READ-N-BYTES,
;; these are the only cases when we can use the multi-byte read
;; operation on a binary stream.
(with-array-data ((data s) (offset-start start) (offset-end end))
(etypecase data
((simple-array (unsigned-byte 8) (*))
(read-n-x8-bytes stream data offset-start offset-end 8))
((simple-array (unsigned-byte 16) (*))
(read-n-x8-bytes stream data offset-start offset-end 16))
((simple-array (unsigned-byte 32) (*))
(read-n-x8-bytes stream data offset-start offset-end 32))
((simple-array (signed-byte 8) (*))
(read-n-x8-bytes stream data offset-start offset-end 8))
((simple-array (signed-byte 16) (*))
(read-n-x8-bytes stream data offset-start offset-end 16))
((simple-array (signed-byte 32) (*))
(read-n-x8-bytes stream data offset-start offset-end 32))
;; Otherwise we resort to the READ-BYTE based operation.
((simple-array (unsigned-byte *) (*))
(read-into-vector s stream start end))
((simple-array (signed-byte *) (*))
(read-into-vector s stream start end))
)) ; with-array-data
) ; flet
))
))
;;; READ-INTO-VECTOR --
(defun read-into-vector (v stream start end)
(declare (type index start end))
(declare (type stream stream))
(declare (type vector v))
(let* ((stream-et (stream-element-type stream))
(read-function (if (subtypep stream-et 'character)
#'read-char
#'read-byte))
)
(do ((i start (1+ i))
(a-len (length v))
)
((or (>= i a-len) (>= i end)) i)
(declare (type index i a-len))
(let ((el (funcall read-function stream nil '%%RWSEQ-EOF%%)))
(when (eq el '%%RWSEQ-EOF%%)
(return i))
(setf (aref v i) el))
)))
(declaim (end-block)) ; READ-SEQUENCE block
(declaim (start-block write-sequence))
;;; WRITE-SEQUENCE
;;; Why the type specifier '(list <type>)' was left out of the standard
;;; will always puzzle me.
(defun write-sequence (seq stream &key (start 0) (end nil))
"Writes the elements of the of SEQ bounded by START and END to STREAM.
Argument(s):
SEQ: a proper SEQUENCE
STREAM: an output STREAM
START: a bounding index designator of type '(INTEGER 0 *)' (default 0)
END: a bounding index designator which be NIL or an INTEGER of
type '(INTEGER 0 *)' (default NIL)
Value(s):
SEQ: a proper SEQUENCE
"
(declare (type (or list vector) seq))
(declare (type stream stream))
(declare (type (integer 0 *) start)) ; a list does not have a limit