Function: cl-struct-define

cl-struct-define is a byte-compiled function defined in cl-preloaded.el.gz.

Signature

(cl-struct-define NAME DOCSTRING PARENT TYPE NAMED SLOTS CHILDREN-SYM TAG PRINT)

Source Code

;; Defined in /usr/src/emacs/lisp/emacs-lisp/cl-preloaded.el.gz
;;;###autoload
(defun cl-struct-define (name docstring parent type named slots children-sym
                              tag print)
  (cl-check-type name (satisfies cl--struct-name-p))
  (unless type
    ;; Legacy defstruct, using tagged vectors.  Enable backward compatibility.
    (with-suppressed-warnings ((obsolete cl-old-struct-compat-mode))
      (message "cl-old-struct-compat-mode is obsolete!")
      (cl-old-struct-compat-mode 1)))
  (when (eq type 'record)
    ;; Defstruct using record objects.
    (setq type nil)
    ;; `cl-structure-class' and `cl-structure-object' are allowed to be
    ;; defined without specifying the parent, because their parent
    ;; doesn't exist yet when they're defined.
    (cl-assert (or parent (memq name '(cl-structure-class
                                       cl-structure-object)))))
  (cl-assert (or type (not named)))
  (if (boundp children-sym)
      (add-to-list children-sym tag)
    (set children-sym (list tag)))
  (and (null type) (eq (caar slots) 'cl-tag-slot)
       ;; Hide the tag slot from "standard" (i.e. non-`type'd) structs.
       (setq slots (cdr slots)))
  (let* ((parent-class (if parent (cl--struct-get-class parent)
                         (cl--find-class (if (eq type 'list) 'cons
                                           (or type 'record)))))
         (n (length slots))
         (index-table (make-hash-table :test 'eq :size n))
         (vslots (let ((v (make-vector n nil))
                       (i 0)
                       (offset (if type 0 1)))
                   (dolist (slot slots)
                     (put (car slot) 'slot-name t)
                     (let* ((props (cl--plist-to-alist (cddr slot)))
                            (typep (assq :type props))
                            (type (if (null typep) t
                                    (setq props (delq typep props))
                                    (cdr typep))))
                       (aset v i (cl--make-slot-desc
                                  (car slot) (nth 1 slot)
                                  type props)))
                     (puthash (car slot) (+ i offset) index-table)
                     (cl-incf i))
                   v))
         (class (cl--struct-new-class
                 name docstring
                 (unless (symbolp parent-class) (list parent-class))
                 type named vslots index-table children-sym tag print)))
    (cl-assert (or (not (symbolp parent-class))
                   (memq name '(cl-structure-class cl-structure-object))))
    (when (cl--struct-class-p parent-class)
      (let ((pslots (cl--struct-class-slots parent-class)))
        (or (>= n (length pslots))
            (let ((ok t))
              (dotimes (i (length pslots))
                (unless (eq (cl--slot-descriptor-name (aref pslots i))
                            (cl--slot-descriptor-name (aref vslots i)))
                  (setq ok nil)))
              ok)
            (error "Included struct %S has changed since compilation of %S"
                   parent name))))
    (add-to-list 'current-load-list `(define-type . ,name))
    (cl--struct-register-child parent-class tag)
    (unless (or (eq named t) (eq tag name))
      ;; We used to use `defconst' instead of `set' but that
      ;; has a side-effect of purecopying during the dump, so that the
      ;; class object stored in the tag ends up being a *copy* of the
      ;; one stored in the `cl--class' property!  We could have fixed
      ;; this needless duplication by using the purecopied object, but
      ;; that then breaks down a bit later when we modify the
      ;; cl-structure-class class object to close the recursion
      ;; between cl-structure-object and cl-structure-class (because
      ;; modifying purecopied objects is not allowed.  Since this is
      ;; done during dumping, we could relax this rule and allow the
      ;; modification, but it's cumbersome).
      ;; So in the end, it's easier to just avoid the duplication by
      ;; avoiding the use of the purespace here.
      (set tag class)
      ;; In the cl-generic support, we need to be able to check
      ;; if a vector is a cl-struct object, without knowing its particular type.
      ;; So we use the (otherwise) unused function slots of the tag symbol
      ;; to put a special witness value, to make the check easy and reliable.
      (fset tag :quick-object-witness-check))
    (setf (cl--find-class name) class)))