;;; cl-preloaded.el --- Preloaded part of the CL library -*- lexical-binding: t; -*-
-;; Copyright (C) 2015 Free Software Foundation, Inc
+;; Copyright (C) 2015-2016 Free Software Foundation, Inc
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; Package: emacs
;; This file is part of GNU Emacs.
;;; Commentary:
-;; The expectation is that structs defined with cl-defstruct do not
-;; need cl-lib at run-time, but we'd like to hide the details of the
-;; cl-struct metadata behind the cl-struct-define function, so we put
-;; it in this pre-loaded file.
+;; The cl-defstruct macro is full of circularities, since it uses the
+;; cl-structure-class type (and its accessors) which is defined with itself,
+;; and it setups a default parent (cl-structure-object) which is also defined
+;; with cl-defstruct, and to make things more interesting, the class of
+;; cl-structure-object is of course an object of type cl-structure-class while
+;; cl-structure-class's parent is cl-structure-object.
+;; Furthermore, the code generated by cl-defstruct generally assumes that the
+;; parent will be loaded when the child is loaded. But at the same time, the
+;; expectation is that structs defined with cl-defstruct do not need cl-lib at
+;; run-time, which means that the `cl-structure-object' parent can't be in
+;; cl-lib but should be preloaded. So here's this preloaded circular setup.
;;; Code:
(eval-when-compile (require 'cl-lib))
-
-(defun cl-struct-define (name docstring parent type named slots children-sym
- tag print-auto)
- (cl-assert (or type (equal '(cl-tag-slot) (car slots))))
- (cl-assert (or type (not named)))
- (if (boundp children-sym)
- (add-to-list children-sym tag)
- (set children-sym (list tag)))
- (let* ((parent-class parent))
- (while parent-class
- (add-to-list (intern (format "cl-struct-%s-tags" parent-class)) tag)
- (setq parent-class (get parent-class 'cl-struct-include))))
- ;; If 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.
- (unless named (fset tag :quick-object-witness-check))
- (put name 'cl-struct-slots slots)
- (put name 'cl-struct-type (list type named))
- (if parent (put name 'cl-struct-include parent))
- (if print-auto (put name 'cl-struct-print print-auto))
- (if docstring (put name 'structure-documentation docstring)))
+(eval-when-compile (require 'cl-macs)) ;For cl--struct-class.
;; The `assert' macro from the cl package signals
;; `cl-assertion-failed' at runtime so always define it.
(apply #'error string (append sargs args))
(signal 'cl-assertion-failed `(,form ,@sargs)))))
+;; When we load this (compiled) file during pre-loading, the cl--struct-class
+;; code below will need to access the `cl-struct' info, since it's considered
+;; already as its parent (because `cl-struct' was defined while the file was
+;; compiled). So let's temporarily setup a fake.
+(defvar cl-struct-cl-structure-object-tags nil)
+(unless (cl--find-class 'cl-structure-object)
+ (setf (cl--find-class 'cl-structure-object) 'dummy))
+
+(fset 'cl--make-slot-desc
+ ;; To break circularity, we pre-define the slot constructor by hand.
+ ;; It's redefined a bit further down as part of the cl-defstruct of
+ ;; cl--slot-descriptor.
+ ;; BEWARE: Obviously, it's important to keep the two in sync!
+ (lambda (name &optional initform type props)
+ (vector 'cl-struct-cl-slot-descriptor
+ name initform type props)))
+
+(defun cl--struct-get-class (name)
+ (or (if (not (symbolp name)) name)
+ (cl--find-class name)
+ (if (not (get name 'cl-struct-type))
+ ;; FIXME: Add a conversion for `eieio--class' so we can
+ ;; create a cl-defstruct that inherits from an eieio class?
+ (error "%S is not a struct name" name)
+ ;; Backward compatibility with a defstruct compiled with a version
+ ;; cl-defstruct from Emacs<25. Convert to new format.
+ (let ((tag (intern (format "cl-struct-%s" name)))
+ (type-and-named (get name 'cl-struct-type))
+ (descs (get name 'cl-struct-slots)))
+ (cl-struct-define name nil (get name 'cl-struct-include)
+ (unless (and (eq (car type-and-named) 'vector)
+ (null (cadr type-and-named))
+ (assq 'cl-tag-slot descs))
+ (car type-and-named))
+ (cadr type-and-named)
+ descs
+ (intern (format "cl-struct-%s-tags" name))
+ tag
+ (get name 'cl-struct-print))
+ (cl--find-class name)))))
+
+(defun cl--plist-remove (plist member)
+ (cond
+ ((null plist) nil)
+ ((null member) plist)
+ ((eq plist member) (cddr plist))
+ (t `(,(car plist) ,(cadr plist) ,@(cl--plist-remove (cddr plist) member)))))
+
+(defun cl--struct-register-child (parent tag)
+ ;; Can't use (cl-typep parent 'cl-structure-class) at this stage
+ ;; because `cl-structure-class' is defined later.
+ (while (vectorp parent)
+ (add-to-list (cl--struct-class-children-sym parent) tag)
+ ;; Only register ourselves as a child of the leftmost parent since structs
+ ;; can only only have one parent.
+ (setq parent (car (cl--struct-class-parents parent)))))
+
+;;;###autoload
+(defun cl-struct-define (name docstring parent type named slots children-sym
+ tag print)
+ (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 (when parent (cl--struct-get-class parent)))
+ (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)
+ (let* ((props (cddr slot))
+ (typep (plist-member props :type))
+ (type (if typep (cadr typep) t)))
+ (aset v i (cl--make-slot-desc
+ (car slot) (nth 1 slot)
+ type (cl--plist-remove props typep))))
+ (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)))
+ (unless (symbolp 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 (eq named t)
+ (eval `(defconst ,tag ',class) t)
+ ;; 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)))
+
+(cl-defstruct (cl-structure-class
+ (:conc-name cl--struct-class-)
+ (:predicate cl--struct-class-p)
+ (:constructor nil)
+ (:constructor cl--struct-new-class
+ (name docstring parents type named slots index-table
+ children-sym tag print))
+ (:copier nil))
+ "The type of CL structs descriptors."
+ ;; The first few fields here are actually inherited from cl--class, but we
+ ;; have to define this one before, to break the circularity, so we manually
+ ;; list the fields here and later "backpatch" cl--class as the parent.
+ ;; BEWARE: Obviously, it's indispensable to keep these two structs in sync!
+ (name nil :type symbol) ;The type name.
+ (docstring nil :type string)
+ (parents nil :type (list-of cl--class)) ;The included struct.
+ (slots nil :type (vector cl--slot-descriptor))
+ (index-table nil :type hash-table)
+ (tag nil :type symbol) ;Placed in cl-tag-slot. Holds the struct-class object.
+ (type nil :type (memq (vector list)))
+ (named nil :type bool)
+ (print nil :type bool)
+ (children-sym nil :type symbol) ;This sym's value holds the tags of children.
+ )
+
+(cl-defstruct (cl-structure-object
+ (:predicate cl-struct-p)
+ (:constructor nil)
+ (:copier nil))
+ "The root parent of all \"normal\" CL structs")
+
+(setq cl--struct-default-parent 'cl-structure-object)
+
+(cl-defstruct (cl-slot-descriptor
+ (:conc-name cl--slot-descriptor-)
+ (:constructor nil)
+ (:constructor cl--make-slot-descriptor
+ (name &optional initform type props))
+ (:copier cl--copy-slot-descriptor-1))
+ ;; FIXME: This is actually not used yet, for circularity reasons!
+ "Descriptor of structure slot."
+ name ;Attribute name (symbol).
+ initform
+ type
+ ;; Extra properties, kept in an alist, can include:
+ ;; :documentation, :protection, :custom, :label, :group, :printer.
+ (props nil :type alist))
+
+(defun cl--copy-slot-descriptor (slot)
+ (let ((new (cl--copy-slot-descriptor-1 slot)))
+ (cl-callf copy-alist (cl--slot-descriptor-props new))
+ new))
+
+(cl-defstruct (cl--class
+ (:constructor nil)
+ (:copier nil))
+ "Type of descriptors for any kind of structure-like data."
+ ;; Intended to be shared between defstruct and defclass.
+ (name nil :type symbol) ;The type name.
+ (docstring nil :type string)
+ ;; For structs there can only be one parent, but when EIEIO classes inherit
+ ;; from cl--class, we'll need this to hold a list.
+ (parents nil :type (list-of cl--class))
+ (slots nil :type (vector cl-slot-descriptor))
+ (index-table nil :type hash-table))
+
+(cl-assert
+ (let ((sc-slots (cl--struct-class-slots (cl--find-class 'cl-structure-class)))
+ (c-slots (cl--struct-class-slots (cl--find-class 'cl--class)))
+ (eq t))
+ (dotimes (i (length c-slots))
+ (let ((sc-slot (aref sc-slots i))
+ (c-slot (aref c-slots i)))
+ (unless (eq (cl--slot-descriptor-name sc-slot)
+ (cl--slot-descriptor-name c-slot))
+ (setq eq nil))))
+ eq))
+
+;; Close the recursion between cl-structure-object and cl-structure-class.
+(setf (cl--struct-class-parents (cl--find-class 'cl-structure-class))
+ (list (cl--find-class 'cl--class)))
+(cl--struct-register-child
+ (cl--find-class 'cl--class)
+ (cl--struct-class-tag (cl--find-class 'cl-structure-class)))
+
+(cl-assert (cl--find-class 'cl-structure-class))
+(cl-assert (cl--find-class 'cl-structure-object))
+(cl-assert (cl-struct-p (cl--find-class 'cl-structure-class)))
+(cl-assert (cl-struct-p (cl--find-class 'cl-structure-object)))
+(cl-assert (cl--class-p (cl--find-class 'cl-structure-class)))
+(cl-assert (cl--class-p (cl--find-class 'cl-structure-object)))
+
;; Make sure functions defined with cl-defsubst can be inlined even in
;; packages which do not require CL. We don't put an autoload cookie
;; directly on that function, since those cookies only go to cl-loaddefs.