Commit 86f69d0a authored by Nikodemus Siivola's avatar Nikodemus Siivola
Browse files

PROPER-LIST-LENGTH and related changes

- New function: PROPER-LIST-LENGTH.

- Share code between PROPER-LIST-LENGTH, LASTCAR, and SETF LASTCAR
  via a macrolet.

- Use ENDP wrapped in SAFETY 3, to ensure proper detection of dotted
  lists.

- Use PROPER-LIST-LENGTH instead of LIST-LENGTH in ROTATE, RANDOM-ELT,
  and SHUFFLE, and test that they signal an error for improper lists.
  (Thanks to Tobias Rittweiler)
parent 3f0815c8
(in-package :alexandria)
(declaim (inline safe-endp))
(defun safe-endp (x)
(declare (optimize safety))
(endp x))
(defun alist-plist (alist)
"Returns a property list containing the same keys and values as the
association list ALIST in the same order."
......@@ -14,7 +19,7 @@ association list ALIST in the same order."
property list PLIST in the same order."
(let (alist)
(do ((tail plist (cddr tail)))
((endp tail) (nreverse alist))
((safe-endp tail) (nreverse alist))
(push (cons (car tail) (cadr tail)) alist))))
(defun malformed-plist (plist)
......@@ -121,37 +126,52 @@ not recommended for performance intensive use. Main usefullness as a type
designator of the expected type in a TYPE-ERROR."
`(and list (satisfies proper-list-p)))
(defun lastcar (list)
"Returns 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 (cadr last)))
(when (endp (cdr fast))
(return (car fast)))
(when (eq fast slow)
(error 'type-error
: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
(defun circular-list-error (list)
(error 'type-error
:datum list
:expected-type '(and list (not circular-list))))
(macrolet ((def (name lambda-list doc step declare ret1 ret2)
(assert (member 'list lambda-list))
`(defun ,name ,lambda-list
,doc
(do ((last list fast)
(fast list (cddr fast))
(slow (cons (car list) (cdr list)) (cdr slow))
,@(when step (list step)))
(nil)
(declare (dynamic-extent slow) ,@(when declare (list declare)))
(when (safe-endp fast)
(return ,ret1))
(when (safe-endp (cdr fast))
(return ,ret2))
(when (eq fast slow)
(circular-list-error list))))))
(def proper-list-length (list)
"Returns length of LIST, signalling an error if it is not a proper list."
(n 1 (+ n 2))
;; KLUDGE: Most implementations don't actually support lists with bignum
;; elements -- and this is WAY faster on most implementations then declaring
;; N to be an UNSIGNED-BYTE.
(fixnum n)
(1- n)
n)
(def lastcar (list)
"Returns the last element of LIST. Signals a type-error if LIST is not a
proper list."
nil
nil
(cadr last)
(car fast))
(def (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))))))
nil
nil
(setf (cadr last) object)
(setf (car fast) object)))
(defun make-circular-list (length &key initial-element)
"Creates a circular list of LENGTH with the given INITIAL-ELEMENT."
......
......@@ -63,6 +63,7 @@
#:nunionf
#:plist-alist
#:proper-list
#:proper-list-length
#:proper-list-p
#:remove-from-plist
#:remove-from-plistf
......
......@@ -8,7 +8,7 @@
(defun rotate-tail-to-head (sequence n)
(declare (type (integer 1) n))
(if (listp sequence)
(let ((m (mod n (list-length sequence))))
(let ((m (mod n (proper-list-length sequence))))
(if (null (cdr sequence))
sequence
(let* ((tail (last sequence (+ m 1)))
......@@ -25,7 +25,7 @@
(defun rotate-head-to-tail (sequence n)
(declare (type (integer 1) n))
(if (listp sequence)
(let ((m (mod (1- n) (list-length sequence))))
(let ((m (mod (1- n) (proper-list-length sequence))))
(if (null (cdr sequence))
sequence
(let* ((headtail (nthcdr m sequence))
......@@ -61,7 +61,7 @@ error if SEQUENCE is not a proper sequence."
(declare (fixnum start) (type (or fixnum null) end))
(typecase sequence
(list
(let* ((end (or end (list-length sequence)))
(let* ((end (or end (proper-list-length sequence)))
(n (- end start)))
(do ((tail (nthcdr start sequence) (cdr tail)))
((zerop n))
......@@ -82,7 +82,7 @@ error if SEQUENCE is not a proper sequence."
error if the SEQUENCE is not a proper sequence."
(declare (sequence sequence) (fixnum start) (type (or fixnum null) end))
(let ((i (+ start (random (- (or end (if (listp sequence)
(list-length sequence)
(proper-list-length sequence)
(length sequence)))
start)))))
(elt sequence i)))
......
......@@ -572,6 +572,40 @@
(typep l5 'proper-list)))
(t t nil t nil))
(deftest proper-list-length.1
(values
(proper-list-length nil)
(proper-list-length (list 1))
(proper-list-length (list 2 2))
(proper-list-length (list 3 3 3))
(proper-list-length (list 4 4 4 4))
(proper-list-length (list 5 5 5 5 5))
(proper-list-length (list 6 6 6 6 6 6))
(proper-list-length (list 7 7 7 7 7 7 7))
(proper-list-length (list 8 8 8 8 8 8 8 8))
(proper-list-length (list 9 9 9 9 9 9 9 9 9)))
0 1 2 3 4 5 6 7 8 9)
(deftest proper-list-length.2
(flet ((plength (x)
(handler-case
(proper-list-length x)
(type-error ()
:ok))))
(values
(plength (list* 1))
(plength (list* 2 2))
(plength (list* 3 3 3))
(plength (list* 4 4 4 4))
(plength (list* 5 5 5 5 5))
(plength (list* 6 6 6 6 6 6))
(plength (list* 7 7 7 7 7 7 7))
(plength (list* 8 8 8 8 8 8 8 8))
(plength (list* 9 9 9 9 9 9 9 9 9))))
:ok :ok :ok
:ok :ok :ok
:ok :ok :ok)
(deftest lastcar.1
(let ((l1 (list 1))
(l2 (list 1 2)))
......@@ -1236,6 +1270,45 @@
:type-error))
:type-error)
(deftest sequences.passing-improper-lists
(macrolet ((signals-error-p (form)
`(handler-case
(progn ,form nil)
(type-error (e)
t)))
(cut (fn &rest args)
(with-gensyms (arg)
(print`(lambda (,arg)
(apply ,fn (list ,@(substitute arg '_ args))))))))
(let ((circular-list (make-circular-list 5 :initial-element :foo))
(dotted-list (list* 'a 'b 'c 'd)))
(loop for nth from 0
for fn in (list
(cut #'lastcar _)
(cut #'rotate _ 3)
(cut #'rotate _ -3)
(cut #'shuffle _)
(cut #'random-elt _)
(cut #'last-elt _)
(cut #'ends-with :foo _))
nconcing
(let ((on-circular-p (signals-error-p (funcall fn circular-list)))
(on-dotted-p (signals-error-p (funcall fn dotted-list))))
(when (or (not on-circular-p) (not on-dotted-p))
(append
(unless on-circular-p
(let ((*print-circle* t))
(list
(format nil
"No appropriate error signalled when passing ~S to ~Ath entry."
circular-list nth))))
(unless on-dotted-p
(list
(format nil
"No appropriate error signalled when passing ~S to ~Ath entry."
dotted-list nth)))))))))
nil)
(deftest with-unique-names.1
(let ((*gensym-counter* 0))
(let ((syms (with-unique-names (foo bar quux)
......
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