ecl/src/clos/slot.lsp

;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: CLOS -*-
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:

;;;;
;;;;  Copyright (c) 1992, Giuseppe Attardi.
;;;;  Copyright (c) 2001, Juan Jose Garcia Ripoll.
;;;;
;;;;    See file 'LICENSE' for the copyright details.

(in-package "CLOS")

(defconstant +initform-unsupplied+ '+initform-unsupplied+)

;;; ----------------------------------------------------------------------
;;; SLOT descriptors
;;;

(defun make-simple-slotd (class
                          &key name (initform +initform-unsupplied+) initfunction
                          (type 'T) (allocation :instance)
                          initargs readers writers documentation location)
  (when (and (eq allocation :class)
             (functionp initfunction))
    (setf initfunction (constantly (funcall initfunction))))
  (with-early-make-instance +slot-definition-slots+
    (slotd class
           :name name
           :initform initform
           :initfunction (if (listp initfunction) (eval initfunction) initfunction)
           :type type
           :allocation allocation
           :initargs initargs
           :readers readers
           :writers writers
           :documentation documentation
           :location location)
    slotd))

(defun freeze-class-slot-initfunction (slotd)
  (when (eq (getf slotd :allocation) :class)
    (let ((initfunc (getf slotd :initfunction)))
      (when initfunc
        (setf (getf slotd :initfunction)
              (constantly (funcall initfunc))))))
  slotd)

(defun canonical-slot-to-direct-slot (class slotd)
  ;; Class slot init functions must be called right away
  (setf slotd (freeze-class-slot-initfunction slotd))
  (if (find-class 'slot-definition nil)
      (apply #'make-instance
             (apply #'direct-slot-definition-class class
                    (freeze-class-slot-initfunction slotd))
             slotd)
      (apply #'make-simple-slotd class slotd)))

(defun direct-slot-to-canonical-slot (slotd)
  (list . #.(loop for (name . rest) in +slot-definition-slots+
               collect (getf rest :initarg)
               collect `(,(getf rest :accessor) slotd))))

;;; ----------------------------------------------------------------------
;;;
;;; (PARSE-SLOTS slot-definition-form) => slot-definition-object
;;;
;;; This routine is the one responsible for parsing the definition of
;;; a slot in DEFCLASS.
;;;

(defun make-function-initform (form)
  ;; INITFORM is a form that is to be evaluated at runtime. If it is a
  ;; constant value, we output simply a quoted form. If it is not,
  ;; we output a function that can be invoked at runtime to retrieve
  ;; the value.
  ;;
  ;; Output => (FUNCTION (LAMBDA () form))
  ;;        => (QUOTE ...)
  ;;
  (if (constantp form)
      `(constantly ,form)
      `#'(lambda () ,form)))

(defun parse-slot (slot &optional (full nil))
  (declare (si::c-local))
  (if (symbolp slot)
      (list* :name slot
             (when full (list :initform '+INITFORM-UNSUPPLIED+ :initfunction nil
                              :initargs nil :readers nil :writers nil
                              :allocation :instance :documentation nil
                              :type 'T)))
      (do* ((output (parse-slot (first slot) full))
            (options (rest slot))
            (value nil)
            (extra nil))
           ((null options)
            (nconc output extra))
        (let ((option (pop options)))
          (when (endp options)
            (si::simple-program-error
             "In the slot description ~S,~%the option ~S is missing an argument"
             slot option))
          (let ((value (pop options)))
            (when (and (member option '(:allocation :initform :type :documentation))
                       (getf options option))
              (si::simple-program-error
               "In the slot description ~S,~%the option ~S is duplicated"
               slot option))
            (case option
              (:initarg    (push value (getf output :initargs)))
              (:initform   (setf (getf output :initform) value
                                 (getf output :initfunction)
                                 (make-function-initform value)))
              (:accessor   (push value (getf output :readers))
                           (push `(setf ,value) (getf output :writers)))
              (:reader     (push value (getf output :readers)))
              (:writer     (push value (getf output :writers)))
              (:allocation (setf (getf output :allocation) value))
              (:type       (setf (getf output :type) value))
              (:documentation  (setf (getf output :documentation) value))
              (otherwise   (if (or (getf extra option)
                                   (getf options option))
                               (push value (getf extra option))
                               (setf (getf extra option) value)))))))))

(defun parse-slots (slots)
  (do ((scan slots (cdr scan))
       (collect))
      ((null scan) (nreverse collect))
    (let* ((slotd (parse-slot (first scan)))
           (name (getf slotd :name)))
      (dolist (other-slotd collect)
        (when (eq name (getf other-slotd :name))
          (si::simple-program-error
           "A definition for the slot ~S appeared twice in a DEFCLASS form"
           name)))
      (push slotd collect))))

;;; ----------------------------------------------------------------------