Defstruct copier function

[jscl.git] / ecmalisp.lisp

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index 1f960b6..bf4810b 100644 (file)
--- 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)))