(when (eql tail object)
(return-from tailp t))))
+(defun make-list (size &key (initial-element nil))
+ "Create a list of size `size` of `initial-element`s."
+ (when (< size 0)
+ (error "Size must be non-negative"))
+ (let ((newlist))
+ (dotimes (i size newlist)
+ (push initial-element newlist))))
+
(defun map1 (func list)
(with-collect
(while list
(setq x (cdr x)))
x)
-(defun butlast (x)
- (and (consp (cdr x))
- (cons (car x) (butlast (cdr x)))))
-
-(defun member (x list &key key (test #'eql testp) (test-not #'eql test-not-p))
+(defun butlast (x &optional (n 1))
+ "Returns x, less the n last elements in the list."
+ (nbutlast (copy-list x) n))
+
+(defun nbutlast (x &optional (n 1))
+ "Destructively returns x, less the n last elements in the list."
+ (cond
+ ((not (and (integerp n) (>= n 0)))
+ ;; TODO: turn this error into a type error, per CLHS spec.
+ (error "n must be a non-negative integer"))
+ ;; trivial optimizations
+ ((zerop n) x)
+ (t
+ ;; O(n) walk of the linked list, trimming out the link where appropriate
+ (let* ((head x)
+ (trailing (nthcdr n x)))
+ ;; If there are enough conses
+ (when (consp trailing)
+ (while (consp (cdr trailing))
+ (setq head (cdr head))
+ (setq trailing (cdr trailing)))
+ ;; snip
+ (rplacd head nil)
+ x)))))
+
+(defun member (x list &key key (test #'eql testp) (test-not #'eql test-not-p))
(while list
(when (satisfies-test-p x (car list) :key key :test test :testp testp
:test-not test-not :test-not-p test-not-p)
(when (member (funcall key x) list2 :test test :key key)
(push x new-list)))
new-list))
+
+(defun get-properties (plist indicator-list)
+ (do* ((plist plist (cddr plist))
+ (cdr (cdr plist) (cdr plist))
+ (car (car plist) (car plist)))
+ ((null plist) (values nil nil nil))
+ (when (null cdr)
+ (error "malformed property list ~S" plist))
+ (let ((found (member car indicator-list :test #'eq)))
+ (when found
+ (return (values car (cadr plist) plist))))))
+
+(defun getf (plist indicator &optional default)
+ (do* ((plist plist (cddr plist))
+ (cdr (cdr plist) (cdr plist))
+ (car (car plist) (car plist)))
+ ((null plist) default)
+ (when (null cdr)
+ (error "malformed property list ~S" plist))
+ (when (eq indicator car)
+ (return (cadr plist)))))
+
+(defun %putf (plist indicator new-value)
+ (do* ((tail plist (cddr tail))
+ (cdr (cdr tail) (cdr tail))
+ (car (car tail) (car tail)))
+ ((null tail) (list* indicator new-value plist))
+ (when (null cdr)
+ (error "malformed property list ~S" tail))
+ (when (eq indicator car)
+ ;; TODO: should be cadr, needs a defsetf for that
+ (setf (car (cdr tail)) new-value)
+ (return tail))))
+
+(define-setf-expander getf (plist indicator &optional default)
+ (multiple-value-bind (dummies vals newval setter getter)
+ (get-setf-expansion plist)
+ (let ((store (gensym))
+ (indicator-sym (gensym))
+ (default-sym (and default (gensym))))
+ (values `(,indicator-sym ,@(and default `(,default-sym)) ,@dummies)
+ `(,indicator ,@(and default `(,default)) ,@vals)
+ `(,store)
+ `(let ((,(car newval) (%putf ,getter ,indicator-sym ,store))
+ ,@(cdr newval))
+ ,setter
+ ,store)
+ `(getf ,getter ,indicator-sym ,@(and default `(,default-sym)))))))