X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=ecmalisp.lisp;h=bf4810b5111f6474c8bf22bd5debff9112b23a23;hb=b500e8a044b964db4baff9e387d0ddd1748eb690;hp=1f960b6457659ad32a6551f3309e78bbcb47e1cc;hpb=ad19ec082d2d9aa6877cc0bbae9ec3fe3094f489;p=jscl.git

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index 1f960b6..bf4810b 100644
--- a/ecmalisp.lisp
+++ b/ecmalisp.lisp
@@ -408,15 +408,33 @@
          ;; Predicate
          (defun ,predicate (x)
            (and (consp x) (eq (car x) ',name)))
+         ;; Copier
+         (defun ,(intern (concat "COPY-" name-string)) (x)
+           (copy-list x))
          ;; Slot accessors
          ,@(with-collect
             (let ((index 1))
               (dolist (slot slot-descriptions)
-                (let ((name (car slot)))
-                  (collect `(defun ,(intern (concat name-string "-" (string name))) (x)
-                              (unless (,predicate x)
-                                (error ,(concat "The object is not a type " name-string)))
-                              (nth ,index x)))
+                (let* ((name (car slot))
+                       (accessor-name (intern (concat name-string "-" (string name)))))
+                  (collect
+                      `(defun ,accessor-name (x)
+                           (unless (,predicate x)
+                             (error ,(concat "The object is not a type " name-string)))
+                         (nth ,index x)))
+                  ;; TODO: Implement this with a higher level
+                  ;; abstraction like defsetf or (defun (setf ..))
+                  (collect
+                      `(define-setf-expander ,accessor-name (x)
+                         (let ((object (gensym))
+                               (new-value (gensym)))
+                           (values (list object)
+                                   (list x)
+                                   (list new-value)
+                                   `(progn
+                                      (rplaca (nthcdr ,',index ,object) ,new-value) 
+                                      ,new-value)
+                                   `(,',accessor-name ,object)))))
                   (incf index)))))
          ',name)))