Add TEST-NOT keyword argument to TREE-EQUAL
[jscl.git] / src / defstruct.lisp
1 ;;; defstruct.lisp --- 
2
3 ;; JSCL is free software: you can redistribute it and/or
4 ;; modify it under the terms of the GNU General Public License as
5 ;; published by the Free Software Foundation, either version 3 of the
6 ;; License, or (at your option) any later version.
7 ;;
8 ;; JSCL is distributed in the hope that it will be useful, but
9 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
10 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
11 ;; General Public License for more details.
12 ;;
13 ;; You should have received a copy of the GNU General Public License
14 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
15
16 ;; A very simple defstruct built on lists. It supports just slot with
17 ;; an optional default initform, and it will create a constructor,
18 ;; predicate and accessors for you.
19 (defmacro def!struct (name &rest slots)
20   (unless (symbolp name)
21     (error "It is not a full defstruct implementation."))
22   (let* ((name-string (symbol-name name))
23          (slot-descriptions
24           (mapcar (lambda (sd)
25                     (cond
26                       ((symbolp sd)
27                        (list sd))
28                       ((and (listp sd) (car sd) (cddr sd))
29                        sd)
30                       (t
31                        (error "Bad slot description `~S'." sd))))
32                   slots))
33          (predicate (intern (concat name-string "-P"))))
34     `(progn
35        ;; Constructor
36        (defun ,(intern (concat "MAKE-" name-string)) (&key ,@slot-descriptions)
37          (list ',name ,@(mapcar #'car slot-descriptions)))
38        ;; Predicate
39        (defun ,predicate (x)
40          (and (consp x) (eq (car x) ',name)))
41        ;; Copier
42        (defun ,(intern (concat "COPY-" name-string)) (x)
43          (copy-list x))
44        ;; Slot accessors
45        ,@(with-collect
46           (let ((index 1))
47             (dolist (slot slot-descriptions)
48               (let* ((name (car slot))
49                      (accessor-name (intern (concat name-string "-" (string name)))))
50                 (collect
51                     `(defun ,accessor-name (x)
52                        (unless (,predicate x)
53                          (error "The object `~S' is not of type `~S'" x ,name-string))
54                        (nth ,index x)))
55                 ;; TODO: Implement this with a higher level
56                 ;; abstraction like defsetf or (defun (setf ..))
57                 (collect
58                     `(define-setf-expander ,accessor-name (x)
59                        (let ((object (gensym))
60                              (new-value (gensym)))
61                          (values (list object)
62                                  (list x)
63                                  (list new-value)
64                                  `(progn
65                                     (rplaca (nthcdr ,',index ,object) ,new-value) 
66                                     ,new-value)
67                                  `(,',accessor-name ,object)))))
68                 (incf index)))))
69        ',name)))