diff options
author | Stefan Monnier <monnier@iro.umontreal.ca> | 2015-03-18 10:31:07 -0400 |
---|---|---|
committer | Stefan Monnier <monnier@iro.umontreal.ca> | 2015-03-18 10:31:07 -0400 |
commit | 872481d9e26d7569145c897fd319b1104e028878 (patch) | |
tree | cdccdeb6934b6f36b078e41e9e10ba4e6af1af08 /lisp/emacs-lisp/cl-preloaded.el | |
parent | fd93edbb1cabfdf0c732dbb0c6892a515b406a65 (diff) | |
download | emacs-872481d9e26d7569145c897fd319b1104e028878.tar.gz |
Add classes as run-time descriptors of cl-structs.
* lisp/emacs-lisp/cl-preloaded.el (cl--struct-get-class): New function.
(cl--make-slot-desc): New constructor.
(cl--plist-remove, cl--struct-register-child): New functions.
(cl-struct-define): Rewrite.
(cl-structure-class, cl-structure-object, cl-slot-descriptor)
(cl--class): New structs.
(cl--struct-default-parent): Initialize it here.
* lisp/emacs-lisp/cl-macs.el (cl--find-class): New macro.
(cl-defsubst, cl--defsubst-expand, cl--sublis): Move before first use.
(cl--struct-default-parent): New var.
(cl-defstruct): Adjust to new representation of classes; add
default parent. In accessors, signal `wrong-type-argument' rather than
a generic error.
(cl-struct-sequence-type, cl-struct-slot-info)
(cl-struct-slot-offset): Rewrite.
* lisp/emacs-lisp/cl-generic.el (cl--generic-struct-specializers)
(cl-generic-generalizers): Rewrite.
* src/alloc.c (purecopy): Handle hash-tables.
* lisp/emacs-lisp/debug.el (debug--implement-debug-on-entry):
Bind inhibit-debug-on-entry here...
(debug): Instead of here.
* lisp/emacs-lisp/macroexp.el (macroexp--debug-eager): New var.
(internal-macroexpand-for-load): Use it.
* lwlib/xlwmenu.c (pop_up_menu): Remove debugging code.
Diffstat (limited to 'lisp/emacs-lisp/cl-preloaded.el')
-rw-r--r-- | lisp/emacs-lisp/cl-preloaded.el | 231 |
1 files changed, 205 insertions, 26 deletions
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 401d34b449e..a18e0e57b05 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -21,36 +21,22 @@ ;;; 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. @@ -63,6 +49,199 @@ (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)))) + (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)) + ;; 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)) + +(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) + (parents nil :type (or cl--class (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. |