Commit 18dafc30 authored by Nikodemus Siivola's avatar Nikodemus Siivola

SETF-functions for lastcar, first-elt, and last-elt. :KEY and :TEST for starts-with and ends-with

parent a77441a8
......@@ -6,11 +6,11 @@
(:static-file "tests.lisp")
(:file "package")
(:file "hash-tables" :depends-on ("package"))
(:file "sequences" :depends-on ("package"))
(:file "macros" :depends-on ("package"))
(:file "symbols" :depends-on ("package"))
(:file "arrays" :depends-on ("package"))
(:file "types" :depends-on ("package"))
(:file "functions" :depends-on ("package" "symbols"))
(:file "lists" :depends-on ("package" "functions"))
(:file "sequences" :depends-on ("package" "lists"))
(:file "numbers" :depends-on ("package" "sequences"))))
......@@ -130,6 +130,7 @@ terms and conditions:
@include include/fun-alexandria-circular-tree-p.texinfo
@include include/fun-alexandria-proper-list-p.texinfo
@include include/fun-alexandria-lastcar.texinfo
@include include/fun-alexandria-setf-lastcar.texinfo
@include include/fun-alexandria-make-circular-list.texinfo
@include include/fun-alexandria-ensure-list.texinfo
@include include/fun-alexandria-sans.texinfo
......@@ -155,7 +156,9 @@ terms and conditions:
@include include/fun-alexandria-sequence-of-length-p.texinfo
@include include/fun-alexandria-copy-sequence.texinfo
@include include/fun-alexandria-first-elt.texinfo
@include include/fun-alexandria-setf-first-elt.texinfo
@include include/fun-alexandria-last-elt.texinfo
@include include/fun-alexandria-setf-last-elt.texinfo
@include include/fun-alexandria-starts-with.texinfo
@include include/fun-alexandria-ends-with.texinfo
......
......@@ -73,6 +73,22 @@ proper list."
:datum list
:expected-type '(and list (not circular-list))))))
(defun (setf lastcar) (object list)
"Sets the last element of LIST. Signals a type-error if LIST is not a proper
list."
(do ((last list fast)
(fast list (cddr fast))
(slow (cons (car list) (cdr list)) (cdr slow)))
(nil)
(when (endp fast)
(return (setf (cadr last) object)))
(when (endp (cdr fast))
(return (setf (car fast) object)))
(when (eq fast slow)
(error 'type-error
:datum list
:expected-type '(and list (not circular-list))))))
(defun make-circular-list (length &key initial-element)
"Creates a circular list of LENGTH with the given INITIAL-ELEMENT."
(let ((cycle (make-list length :initial-element initial-element)))
......
......@@ -119,56 +119,90 @@ SEQUENCE."
(defun first-elt (sequence)
"Returns the first element of SEQUENCE. Signals a type-error if SEQUENCE is
not a sequence, or is an empty sequence."
;; Can't just directly use ELT, as it is not guaranteed to signal the
;; type-error.
(cond ((consp sequence)
(car sequence))
((and (vectorp sequence) (plusp (length sequence)))
(aref sequence 0))
((and (typep sequence '(and sequence (not list))) (plusp (length sequence)))
(elt sequence 0))
(t
(error 'type-error
:datum sequence
:expected-type '(and sequence (not (satisfies emptyp)))))))
(defun (setf first-elt) (object sequence)
"Sets the first element of SEQUENCE. Signals a type-error if SEQUENCE is
not a sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE."
;; Can't just directly use ELT, as it is not guaranteed to signal the
;; type-error.
(cond ((consp sequence)
(setf (car sequence) object))
((and (typep sequence '(and sequence (not list))) (plusp (length sequence)))
(setf (elt sequence 0) object))
(t
(error 'type-error
:datum sequence
:expected-type '(and proper-sequence (not (satisfies emptyp)))))))
(defun last-elt (sequence)
"Returns the last element of SEQUENCE. Signals a type-error if SEQUENCE is
not a proper sequence, or is an empty sequence."
(declare (inline lastcar))
;; Can't just directly use ELT, as it is not guaranteed to signal the
;; type-error.
(let ((len 0))
(cond ((consp sequence)
(lastcar sequence))
((and (vectorp sequence) (plusp (setf len (length sequence))))
(aref sequence (1- len)))
(t
(error 'type-error
:datum sequence
:expected-type '(and proper-sequence (not (satisfies emptyp))))))))
((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence))))
(elt sequence (1- len)))
(t
(error 'type-error
:datum sequence
:expected-type '(and proper-sequence (not (satisfies emptyp))))))))
(defun starts-with (object sequence)
(defun (setf last-elt) (object sequence)
"Sets the last element of SEQUENCE. Signals a type-error if SEQUENCE is not a proper
sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE."
(let ((len 0))
(cond ((consp sequence)
(setf (lastcar sequence) object))
((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence))))
(setf (elt sequence (1- len)) object))
(t
(error 'type-error
:datum sequence
:expected-type '(and proper-sequence (not (satisfies emptyp))))))))
(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."
(eql (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))
(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))
(defun ends-with (object sequence)
(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."
(eql (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))
(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))
......@@ -316,6 +316,15 @@
t))
t)
(deftest setf-lastcar.1
(let ((l (list 1 2 3 4)))
(values (lastcar l)
(progn
(setf (lastcar l) 42)
(lastcar l))))
4
42)
(deftest make-circular-list.1
(let ((l (make-circular-list 3 :initial-element :x)))
(setf (car l) :y)
......@@ -721,6 +730,18 @@
:type-error
:type-error))
(deftest setf-first-elt.1
(let ((l (list 1 2 3))
(s (copy-seq "foobar"))
(v (vector :a :b :c)))
(setf (first-elt l) -1
(first-elt s) #\x
(first-elt v) 'zot)
(values l s v))
(-1 2 3)
"xoobar"
#(zot :b :c))
(deftest last-elt.1
(mapcar #'last-elt
(list (list 1 2 3)
......@@ -749,6 +770,18 @@
:type-error
:type-error))
(deftest setf-last-elt.1
(let ((l (list 1 2 3))
(s (copy-seq "foobar"))
(b (copy-seq #*010101001)))
(setf (last-elt l) '???
(last-elt s) #\?
(last-elt b) 0)
(values l s b))
(1 2 ???)
"fooba?"
#*010101000)
(deftest starts-with.1
(list (starts-with 1 '(1 2 3))
(starts-with 1 #(1 2 3))
......@@ -759,6 +792,18 @@
(starts-with nil nil))
(t t t nil nil nil nil))
(deftest starts-with.2
(values (starts-with 1 '(-1 2 3) :key '-)
(starts-with "foo" '("foo" "bar") :test 'equal)
(starts-with "f" '(#\f) :key 'string :test 'equal)
(starts-with -1 '(0 1 2) :key #'1+)
(starts-with "zot" '("ZOT") :test 'equal))
t
t
t
nil
nil)
(deftest ends-with.1
(list (ends-with 3 '(1 2 3))
(ends-with 3 #(1 2 3))
......@@ -769,6 +814,16 @@
(ends-with nil nil))
(t t t nil nil nil nil))
(deftest ends-with.2
(values (ends-with 2 '(0 13 1) :key '1+)
(ends-with "foo" (vector "bar" "foo") :test 'equal)
(ends-with "X" (vector 1 2 #\X) :key 'string :test 'equal)
(ends-with "foo" "foo" :test 'equal))
t
t
t
nil)
(deftest ends-with.error.1
(handler-case
(ends-with 3 (circular-list 3 3 3 1 3 3))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment