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.
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.
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/>.
16 (/debug "loading defstruct.lisp!")
18 ;; A very simple defstruct built on lists. It supports just slot with
19 ;; an optional default initform, and it will create a constructor,
20 ;; predicate and accessors for you.
21 (defmacro def!struct (name &rest slots)
22 (unless (symbolp name)
23 (error "It is not a full defstruct implementation."))
24 (let* ((name-string (symbol-name name))
30 ((and (listp sd) (car sd) (cddr sd))
33 (error "Bad slot description `~S'." sd))))
35 (predicate (intern (concat name-string "-P"))))
38 (defun ,(intern (concat "MAKE-" name-string)) (&key ,@slot-descriptions)
39 (list ',name ,@(mapcar #'car slot-descriptions)))
42 (and (consp x) (eq (car x) ',name)))
44 (defun ,(intern (concat "COPY-" name-string)) (x)
49 (dolist (slot slot-descriptions)
50 (let* ((name (car slot))
51 (accessor-name (intern (concat name-string "-" (string name)))))
53 `(defun ,accessor-name (x)
54 (unless (,predicate x)
55 (error "The object `~S' is not of type `~S'" x ,name-string))
57 ;; TODO: Implement this with a higher level
58 ;; abstraction like defsetf or (defun (setf ..))
60 `(define-setf-expander ,accessor-name (x)
61 (let ((object (gensym))
67 (rplaca (nthcdr ,',index ,object) ,new-value)
69 `(,',accessor-name ,object)))))