X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=ecmalisp.lisp;h=8775cc65648543cf6cebf88a84446a80fbd08c0a;hb=729dd6267215a41ff2b0ca5aaffc3dc98ad5a9e3;hp=fbbdbb1f028a7a20a609d0d85e0682c63f7bcc39;hpb=775baf9e8712e5711303e49367c72d39fb1f7f79;p=jscl.git

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index fbbdbb1..8775cc6 100644
--- a/ecmalisp.lisp
+++ b/ecmalisp.lisp
@@ -383,6 +383,43 @@
            ,@body)
          (cdr ,head))))
 
+  ;; A very simple defstruct built on lists. It supports just slot with
+  ;; an optional default initform, and it will create a constructor,
+  ;; predicate and accessors for you.
+  (defmacro defstruct (name &rest slots)
+    (unless (symbolp name)
+      (error "It is not a full defstruct implementation."))
+    (let* ((name-string (symbol-name name))
+           (slot-descriptions
+            (mapcar (lambda (sd)
+                      (cond
+                        ((symbolp sd)
+                         (list sd))
+                        ((and (listp sd) (car sd) (cddr sd))
+                         sd)
+                        (t
+                         (error "Bad slot accessor."))))
+                    slots))
+           (predicate (intern (concat name-string "P"))))
+      `(progn
+         ;; Constructor
+         (defun ,(intern (concat "MAKE-" name-string)) (&key ,@slot-descriptions)
+           (list ',name ,@(mapcar #'car slot-descriptions)))
+         ;; Predicate
+         (defun ,predicate (x)
+           (and (consp x) (eq (car x) ',name)))
+         ;; 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)))
+                  (incf index)))))
+         ',name)))
+
   (defun map1 (func list)
     (with-collect
         (while list