Fix SYMBOL-PLIST and (SETF SYMBOL-PLIST)

[jscl.git] / src / list.lisp

diff --git a/src/list.lisp b/src/list.lisp
index 3726f7c..274d2f3 100644 (file)
--- a/src/list.lisp
+++ b/src/list.lisp
@@ -39,6 +39,12 @@
 
 (defun cdr (x) (cdr x))
 
 
 (defun cdr (x) (cdr x))
 

+(defun rplaca (cons x)
+  (rplaca cons x))
+
+(defun rplacd (cons x)
+  (rplacd cons x))
+

 (defun first   (x) (car    x))
 (defun second  (x) (cadr   x))
 (defun third   (x) (caddr  x))
 (defun first   (x) (car    x))
 (defun second  (x) (cadr   x))
 (defun third   (x) (caddr  x))

@@ -61,6 +67,13 @@
                ((null (cddr x)) (rplacd x (cadr x))))
            (cons arg others))))
 
                ((null (cddr x)) (rplacd x (cadr x))))
            (cons arg others))))
 

+(defun list-length (list)
+  (let ((l 0))
+    (while (not (null list))
+      (incf l)
+      (setq list (cdr list)))
+    l))
+

 (defun nthcdr (n list)
   (while (and (plusp n) list)
     (setq n (1- n))
 (defun nthcdr (n list)
   (while (and (plusp n) list)
     (setq n (1- n))

@@ -111,6 +124,24 @@
 (defun cdddar (x) (cdr (cddar x)))
 (defun cddddr (x) (cdr (cdddr x)))
 
 (defun cdddar (x) (cdr (cddar x)))
 (defun cddddr (x) (cdr (cdddr x)))
 

+(defun append-two (list1 list2)
+  (if (null list1)
+      list2
+      (cons (car list1)
+            (append (cdr list1) list2))))
+
+(defun append (&rest lists)
+  (!reduce #'append-two lists nil))
+
+(defun revappend (list1 list2)
+  (while list1
+    (push (car list1) list2)
+    (setq list1 (cdr list1)))
+  list2)
+
+(defun reverse (list)
+  (revappend list '()))
+

 (defun sublis (alist tree &key key (test #'eql testp) (test-not #'eql test-not-p))
   (when (and testp test-not-p)
     (error "Both test and test-not are set"))
 (defun sublis (alist tree &key key (test #'eql testp) (test-not #'eql test-not-p))
   (when (and testp test-not-p)
     (error "Both test and test-not are set"))

@@ -166,17 +197,13 @@
     (when (eql tail object)
       (return-from tailp t))))
 
     (when (eql tail object)
       (return-from tailp t))))
 

-(defmacro pop (place)
-  (multiple-value-bind (dummies vals newval setter getter)
-    (get-setf-expansion place)
-    (let ((head (gensym)))
-      `(let* (,@(mapcar #'list dummies vals) 
-              (,head ,getter)
-              (,(car newval) (cdr ,head))
-              ,@(cdr newval)) 
-         ,setter
-         (car ,head)))))
-
+(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
 
 (defun map1 (func list)
   (with-collect

@@ -215,9 +242,10 @@
              (collect (apply func elems))))))))
 
 (defun mapc (func &rest lists)
              (collect (apply func elems))))))))
 
 (defun mapc (func &rest lists)

-  (do* ((elems (map1 #'car lists) (map1 #'car lists-rest))
-        (lists-rest (map1 #'cdr lists) (map1 #'cdr lists-rest)))
-       ((dolist (x elems) (when (null x) (return t)))
+  (do* ((tails lists (map1 #'cdr tails))
+        (elems (map1 #'car tails)
+               (map1 #'car tails)))
+       ((dolist (x tails) (when (null x) (return t)))

         (car lists))
     (apply func elems)))
 
         (car lists))
     (apply func elems)))
 

@@ -226,11 +254,32 @@
     (setq x (cdr x)))
   x)
 
     (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)
   (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)

@@ -340,3 +389,51 @@
       (when (member (funcall key x) list2 :test test :key key)
         (push x new-list)))
     new-list))
       (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)))))))