Commits (6)
(defsystem alexandria-tests
:licence "Public Domain / 0-clause MIT"
:description "Tests for Alexandria, which is a collection of portable public domain utilities."
:author "Nikodemus Siivola <nikodemus@sb-studio.net>, and others."
:depends-on (:alexandria #+sbcl :sb-rt #-sbcl :rt)
:components ((:file "tests")))
(defmethod operation-done-p
((o test-op) (c (eql (find-system :alexandria-tests))))
nil)
(defmethod perform ((o test-op) (c (eql (find-system :alexandria-tests))))
(flet ((run-tests (&rest args)
(apply (intern (string '#:run-tests) '#:alexandria-tests) args)))
(run-tests :compiled nil)
(run-tests :compiled t)))
\ No newline at end of file
(run-tests :compiled t)))
......@@ -2,6 +2,7 @@
:version "0.0.0"
:licence "Public Domain / 0-clause MIT"
:description "Alexandria is a collection of portable public domain utilities."
:author "Nikodemus Siivola <nikodemus@sb-studio.net>, and others."
:long-description
"Alexandria is a project and a library.
......@@ -64,4 +65,4 @@ the following constraints:
(defmethod perform ((o test-op) (c (eql (find-system :alexandria))))
(operate 'load-op :alexandria-tests)
(operate 'test-op :alexandria-tests))
\ No newline at end of file
(operate 'test-op :alexandria-tests))
......@@ -68,7 +68,7 @@ returns the values of DEFAULT if no keys match."
,(expand possibilities 0 random-number)))))))
(defmacro xor (&rest datums)
"Evaluates its arguments one at a time, from left to right. If more then one
"Evaluates its arguments one at a time, from left to right. If more than one
argument evaluates to a true value no further DATUMS are evaluated, and NIL is
returned as both primary and secondary value. If exactly one argument
evaluates to true, its value is returned as the primary value after all the
......
......@@ -33,7 +33,7 @@ FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT,
which is only sent to WITH-OPEN-FILE when it's not NIL."
(declare (ignore direction))
(when direction-p
(error "Can't specifiy :DIRECTION for WITH-INPUT-FROM-FILE."))
(error "Can't specify :DIRECTION for WITH-INPUT-FROM-FILE."))
`(with-open-file* (,stream-name ,file-name :direction :input ,@args)
,@body))
......@@ -46,7 +46,7 @@ FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT,
which is only sent to WITH-OPEN-FILE when it's not NIL."
(declare (ignore direction))
(when direction-p
(error "Can't specifiy :DIRECTION for WITH-OUTPUT-TO-FILE."))
(error "Can't specify :DIRECTION for WITH-OUTPUT-TO-FILE."))
`(with-open-file* (,stream-name ,file-name :direction :output ,@args)
,@body))
......
......@@ -184,8 +184,10 @@ Signals a PROGRAM-ERROR is the lambda-list is malformed."
(check-variable name "optional parameter")
(cond ((cdr tail)
(check-spec tail "optional-supplied-p parameter"))
((and normalize-optional tail)
(setf elt (append elt '(nil))))
(normalize-optional
(setf elt (append elt '(nil)))))))
(setf elt (append elt '(nil nil)))))))
(t
(check-variable elt "optional parameter")
(when normalize-optional
......@@ -209,10 +211,12 @@ Signals a PROGRAM-ERROR is the lambda-list is malformed."
(check-variable var-or-kv "keyword parameter")
(when normalize-keyword
(setf var-or-kv (list (make-keyword var-or-kv) var-or-kv)))))
(if (cdr tail)
(check-spec tail "keyword-supplied-p parameter")
(when normalize-keyword
(setf tail (append tail '(nil)))))
(cond ((cdr tail)
(check-spec tail "keyword-supplied-p parameter"))
((and normalize-keyword tail)
(setf tail (append tail '(nil))))
(normalize-keyword
(setf tail '(nil nil))))
(setf elt (cons var-or-kv tail))))
(t
(check-variable elt "keyword parameter")
......
......@@ -300,28 +300,40 @@ sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE."
"Test whether the first elements of SEQUENCE are the same (as per TEST) as the elements of PREFIX.
If RETURN-SUFFIX is T the function returns, as a second value, a
displaced array pointing to the sequence after PREFIX."
sub-sequence or displaced array pointing to the sequence after PREFIX."
(declare (dynamic-extent args))
(let ((sequence-length (length sequence))
(prefix-length (length prefix)))
(if (<= prefix-length sequence-length)
(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)
(values t (when return-suffix
(make-array (- sequence-length mismatch)
:element-type (array-element-type sequence)
:displaced-to sequence
:displaced-index-offset prefix-length
:adjustable nil))))
(values t (when return-suffix
(make-array 0 :element-type (array-element-type sequence)
:adjustable nil)))))
(values nil nil))))
(when (< sequence-length prefix-length)
(return-from starts-with-subseq (values nil nil)))
(flet ((make-suffix (start)
(when return-suffix
(cond
((not (arrayp sequence))
(if start
(subseq sequence start)
(subseq sequence 0 0)))
((not start)
(make-array 0
:element-type (array-element-type sequence)
:adjustable nil))
(t
(make-array (- sequence-length start)
:element-type (array-element-type sequence)
:displaced-to sequence
:displaced-index-offset start
:adjustable nil))))))
(let ((mismatch (apply #'mismatch prefix sequence
(if return-suffix-supplied-p
(remove-from-plist args :return-suffix)
args))))
(cond
((not mismatch)
(values t (make-suffix nil)))
((= mismatch prefix-length)
(values t (make-suffix mismatch)))
(t
(values nil nil)))))))
(defun ends-with-subseq (suffix sequence &key (test #'eql))
"Test whether SEQUENCE ends with SUFFIX. In other words: return true if
......
......@@ -1960,6 +1960,21 @@
n)
13)
(deftest starts-with-subseq.string
(starts-with-subseq "f" "foo" :return-suffix t)
t
"oo")
(deftest starts-with-subseq.vector
(starts-with-subseq #(1) #(1 2 3) :return-suffix t)
t
#(2 3))
(deftest starts-with-subseq.list
(starts-with-subseq '(1) '(1 2 3) :return-suffix t)
t
(2 3))
(deftest starts-with-subseq.start1
(starts-with-subseq "foo" "oop" :start1 1)
t
......@@ -1995,10 +2010,19 @@
(deftest parse-ordinary-lambda-list.1
(multiple-value-bind (req opt rest keys allowp aux keyp)
(parse-ordinary-lambda-list '(a b c &optional d &key))
(parse-ordinary-lambda-list '(a b c
&optional o1 (o2 42) (o3 42 o3-supplied?)
&key (k1) ((:key k2)) (k3 42 k3-supplied?))
:normalize t)
(and (equal '(a b c) req)
(equal '((d nil nil)) opt)
(equal '() keys)
(equal '((o1 nil nil)
(o2 42 nil)
(o3 42 o3-supplied?))
opt)
(equal '(((:k1 k1) nil nil)
((:key k2) nil nil)
((:k3 k3) 42 k3-supplied?))
keys)
(not allowp)
(not aux)
(eq t keyp)))
......