Commits (6)
......@@ -209,7 +209,9 @@ terms and conditions:
@comment node-name, next, previous, up
@chapter IO
@include include/fun-alexandria-read-stream-content-into-string.texinfo
@include include/fun-alexandria-read-file-into-string.texinfo
@include include/fun-alexandria-read-stream-content-into-byte-vector.texinfo
@include include/fun-alexandria-read-file-into-byte-vector.texinfo
@node Macro Writing
......
......@@ -50,6 +50,17 @@ which is only sent to WITH-OPEN-FILE when it's not NIL."
`(with-open-file* (,stream-name ,file-name :direction :output ,@args)
,@body))
(defun read-stream-content-into-string (stream &key (buffer-size 4096))
"Return the \"content\" of STREAM as a fresh string."
(check-type buffer-size positive-integer)
(let ((*print-pretty* nil))
(with-output-to-string (datum)
(let ((buffer (make-array buffer-size :element-type 'character)))
(loop
:for bytes-read = (read-sequence buffer stream)
:do (write-sequence buffer datum :start 0 :end bytes-read)
:while (= bytes-read buffer-size))))))
(defun read-file-into-string (pathname &key (buffer-size 4096) external-format)
"Return the contents of the file denoted by PATHNAME as a fresh string.
......@@ -57,13 +68,7 @@ The EXTERNAL-FORMAT parameter will be passed directly to WITH-OPEN-FILE
unless it's NIL, which means the system default."
(with-input-from-file
(file-stream pathname :external-format external-format)
(let ((*print-pretty* nil))
(with-output-to-string (datum)
(let ((buffer (make-array buffer-size :element-type 'character)))
(loop
:for bytes-read = (read-sequence buffer file-stream)
:do (write-sequence buffer datum :start 0 :end bytes-read)
:while (= bytes-read buffer-size)))))))
(read-stream-content-into-string file-stream :buffer-size buffer-size)))
(defun write-string-into-file (string pathname &key (if-exists :error)
if-does-not-exist
......@@ -77,14 +82,32 @@ unless it's NIL, which means the system default."
:external-format external-format)
(write-sequence string file-stream)))
(defun read-stream-content-into-byte-vector (stream &key ((%length length))
(initial-size 4096))
"Return \"content\" of STREAM as freshly allocated (unsigned-byte 8) vector."
(check-type length (or null non-negative-integer))
(check-type initial-size positive-integer)
(do ((buffer (make-array (or length initial-size)
:element-type '(unsigned-byte 8)))
(offset 0)
(offset-wanted 0))
((or (/= offset-wanted offset)
(and length (>= offset length)))
(if (= offset (length buffer))
buffer
(subseq buffer 0 offset)))
(unless (zerop offset)
(let ((new-buffer (make-array (* 2 (length buffer))
:element-type '(unsigned-byte 8))))
(replace new-buffer buffer)
(setf buffer new-buffer)))
(setf offset-wanted (length buffer)
offset (read-sequence buffer stream :start offset))))
(defun read-file-into-byte-vector (pathname)
"Read PATHNAME into a freshly allocated (unsigned-byte 8) vector."
(with-input-from-file (stream pathname :element-type '(unsigned-byte 8))
(let ((length (file-length stream)))
(assert length)
(let ((result (make-array length :element-type '(unsigned-byte 8))))
(read-sequence result stream)
result))))
(read-stream-content-into-byte-vector stream '%length (file-length stream))))
(defun write-byte-vector-into-file (bytes pathname &key (if-exists :error)
if-does-not-exist)
......
......@@ -90,7 +90,14 @@ Examples:
(defun lerp (v a b)
"Returns the result of linear interpolation between A and B, using the
interpolation coefficient V."
(+ a (* v (- b a))))
;; The correct version is numerically stable, at the expense of an
;; extra multiply. See (lerp 0.1 4 25) with (+ a (* v (- b a))). The
;; unstable version can often be converted to a fast instruction on
;; a lot of machines, though this is machine/implementation
;; specific. As alexandria is more about correct code, than
;; efficiency, and we're only talking about a single extra multiply,
;; many would prefer the stable version
(+ (* (- 1.0 v) a) (* v b)))
(declaim (inline mean))
(defun mean (sample)
......
......@@ -226,8 +226,10 @@
;; io
#:with-input-from-file
#:with-output-to-file
#:read-stream-content-into-string
#:read-file-into-string
#:write-string-into-file
#:read-stream-content-into-byte-vector
#:read-file-into-byte-vector
#:write-byte-vector-into-file
#:copy-stream
......
......@@ -155,6 +155,12 @@ that are not lists."
`(or proper-list
(and (not list) sequence)))
(eval-when (:compile-toplevel :load-toplevel :execute)
(when (and (find-package '#:sequence)
(find-symbol (string '#:emptyp) '#:sequence))
(pushnew 'sequence-emptyp *features*)))
#-alexandria::sequence-emptyp
(defun emptyp (sequence)
"Returns true if SEQUENCE is an empty sequence. Signals an error if SEQUENCE
is not a sequence."
......@@ -162,6 +168,14 @@ is not a sequence."
(list (null sequence))
(sequence (zerop (length sequence)))))
#+alexandria::sequence-emptyp
(declaim (ftype (function (sequence) (values boolean &optional)) emptyp))
#+alexandria::sequence-emptyp
(setf (symbol-function 'emptyp) (symbol-function 'sequence:emptyp))
#+alexandria::sequence-emptyp
(define-compiler-macro emptyp (sequence)
`(sequence:emptyp ,sequence))
(defun length= (&rest sequences)
"Takes any number of sequences or integers in any order. Returns true iff
the length of all the sequences and the integers are equal. Hint: there's a
......@@ -230,7 +244,7 @@ not a sequence, or is an empty sequence."
;; type-error.
(cond ((consp sequence)
(car sequence))
((and (typep sequence '(and sequence (not list))) (plusp (length sequence)))
((and (typep sequence 'sequence) (not (emptyp sequence)))
(elt sequence 0))
(t
(error 'type-error
......@@ -244,8 +258,7 @@ not a sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE.
;; type-error.
(cond ((consp sequence)
(setf (car sequence) object))
((and (typep sequence '(and sequence (not list)))
(plusp (length sequence)))
((and (typep sequence 'sequence) (not (emptyp sequence)))
(setf (elt sequence 0) object))
(t
(error 'type-error
......@@ -280,16 +293,22 @@ sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE."
:datum sequence
:expected-type '(and proper-sequence (not (satisfies emptyp))))))))
(defun starts-with-subseq (prefix sequence &rest args &key (return-suffix nil) &allow-other-keys)
(defun starts-with-subseq (prefix sequence &rest args
&key
(return-suffix nil return-suffix-supplied-p)
&allow-other-keys)
"Test whether the first elements of SEQUENCE are the same (as per TEST) as the elements of PREFIX.
If RETURN-SUFFIX is T the functions returns, as a second value, a
If RETURN-SUFFIX is T the function returns, as a second value, a
displaced array pointing to the sequence after PREFIX."
(remove-from-plistf args :return-suffix)
(declare (dynamic-extent args))
(let ((sequence-length (length sequence))
(prefix-length (length prefix)))
(if (<= prefix-length sequence-length)
(let ((mismatch (apply #'mismatch prefix sequence args)))
(let ((mismatch (apply #'mismatch prefix sequence
(if return-suffix-supplied-p
(remove-from-plist args :return-suffix)
args))))
(if mismatch
(if (< mismatch prefix-length)
(values nil nil)
......@@ -321,38 +340,33 @@ the last (length SUFFIX) elements of SEQUENCE are equal to SUFFIX."
(defun starts-with (object sequence &key (test #'eql) (key #'identity))
"Returns true if SEQUENCE is a sequence whose first element is EQL to OBJECT.
Returns NIL if the SEQUENCE is not a sequence or is an empty sequence."
(funcall test
(funcall key
(typecase sequence
(cons (car sequence))
(sequence
(if (plusp (length sequence))
(elt sequence 0)
(return-from starts-with nil)))
(t
(return-from starts-with nil))))
object))
(let ((first-elt (typecase sequence
(cons (car sequence))
(sequence
(if (emptyp sequence)
(return-from starts-with nil)
(elt sequence 0)))
(t
(return-from starts-with nil)))))
(funcall test (funcall key first-elt) object)))
(defun ends-with (object sequence &key (test #'eql) (key #'identity))
"Returns true if SEQUENCE is a sequence whose last element is EQL to OBJECT.
Returns NIL if the SEQUENCE is not a sequence or is an empty sequence. Signals
an error if SEQUENCE is an improper list."
(funcall test
(funcall key
(typecase sequence
(cons
;; signals for improper lists
(lastcar sequence))
(sequence
;; Can't use last-elt, as that signals an error
;; for empty sequences
(let ((len (length sequence)))
(if (plusp len)
(elt sequence (1- len))
(return-from ends-with nil))))
(t
(return-from ends-with nil))))
object))
(let ((last-elt (typecase sequence
(cons
(lastcar sequence)) ; signals for improper lists
(sequence
;; Can't use last-elt, as that signals an error
;; for empty sequences
(let ((len (length sequence)))
(if (plusp len)
(elt sequence (1- len))
(return-from ends-with nil))))
(t
(return-from ends-with nil)))))
(funcall test (funcall key last-elt) object)))
(defun map-combinations (function sequence &key (start 0) end length (copy t))
"Calls FUNCTION with each combination of LENGTH constructable from the
......@@ -485,13 +499,6 @@ if calling FUNCTION modifies either the derangement or SEQUENCE."
(declaim (notinline sequence-of-length-p))
(define-condition no-extremum (error)
()
(:report (lambda (condition stream)
(declare (ignore condition))
(format stream "Empty sequence in ~S." 'extremum))))
(defun extremum (sequence predicate &key key (start 0) end)
"Returns the element of SEQUENCE that would appear first if the subsequence
bounded by START and END was sorted using PREDICATE and KEY.
......
......@@ -989,6 +989,10 @@
(lerp 0.1 1 2)
1.1)
(deftest lerp.3
(lerp 0.1 4 25)
6.1)
(deftest mean.1
(mean '(1 2 3))
2)
......@@ -1511,6 +1515,59 @@
dotted-list nth)))))))))
nil)
;;;; IO
(deftest read-stream-content-into-string.1
(values (with-input-from-string (stream "foo bar")
(read-stream-content-into-string stream))
(with-input-from-string (stream "foo bar")
(read-stream-content-into-string stream :buffer-size 1))
(with-input-from-string (stream "foo bar")
(read-stream-content-into-string stream :buffer-size 6))
(with-input-from-string (stream "foo bar")
(read-stream-content-into-string stream :buffer-size 7)))
"foo bar"
"foo bar"
"foo bar"
"foo bar")
(deftest read-stream-content-into-string.2
(handler-case
(let ((stream (make-broadcast-stream)))
(read-stream-content-into-string stream :buffer-size 0))
(type-error ()
:type-error))
:type-error)
#+(or)
(defvar *octets*
(map '(simple-array (unsigned-byte 8) (7)) #'char-code "foo bar"))
#+(or)
(deftest read-stream-content-into-byte-vector.1
(values (with-input-from-byte-vector (stream *octets*)
(read-stream-content-into-byte-vector stream))
(with-input-from-byte-vector (stream *octets*)
(read-stream-content-into-byte-vector stream :initial-size 1))
(with-input-from-byte-vector (stream *octets*)
(read-stream-content-into-byte-vector stream 'alexandria::%length 6))
(with-input-from-byte-vector (stream *octets*)
(read-stream-content-into-byte-vector stream 'alexandria::%length 3)))
*octets*
*octets*
*octets*
(subseq *octets* 0 3))
(deftest read-stream-content-into-byte-vector.2
(handler-case
(let ((stream (make-broadcast-stream)))
(read-stream-content-into-byte-vector stream :initial-size 0))
(type-error ()
:type-error))
:type-error)
;;;; Macros
(deftest with-unique-names.1
(let ((*gensym-counter* 0))
(let ((syms (with-unique-names (foo bar quux)
......