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 (/debug "loading defstruct.lisp!")
  17
  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))
  25          (slot-descriptions
  26           (mapcar (lambda (sd)
  27                     (cond
  28                       ((symbolp sd)
  29                        (list sd))
  30                       ((and (listp sd) (car sd) (cddr sd))
  31                        sd)
  32                       (t
  33                        (error "Bad slot description `~S'." sd))))
  34                   slots))
  35          (predicate (intern (concat name-string "-P"))))
  36     `(progn
  37        ;; Constructor
  38        (defun ,(intern (concat "MAKE-" name-string)) (&key ,@slot-descriptions)
  39          (list ',name ,@(mapcar #'car slot-descriptions)))
  40        ;; Predicate
  41        (defun ,predicate (x)
  42          (and (consp x) (eq (car x) ',name)))
  43        ;; Copier
  44        (defun ,(intern (concat "COPY-" name-string)) (x)
  45          (copy-list x))
  46        ;; Slot accessors
  47        ,@(with-collect
  48           (let ((index 1))
  49             (dolist (slot slot-descriptions)
  50               (let* ((name (car slot))
  51                      (accessor-name (intern (concat name-string "-" (string name)))))
  52                 (collect
  53                     `(defun ,accessor-name (x)
  54                        (unless (,predicate x)
  55                          (error "The object `~S' is not of type `~S'" x ,name-string))
  56                        (nth ,index x)))
  57                 ;; TODO: Implement this with a higher level
  58                 ;; abstraction like defsetf or (defun (setf ..))
  59                 (collect
  60                     `(define-setf-expander ,accessor-name (x)
  61                        (let ((object (gensym))
  62                              (new-value (gensym)))
  63                          (values (list object)
  64                                  (list x)
  65                                  (list new-value)
  66                                  `(progn
  67                                     (rplaca (nthcdr ,',index ,object) ,new-value)
  68                                     ,new-value)
  69                                  `(,',accessor-name ,object)))))
  70                 (incf index)))))
  71        ',name)))