procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Make "parentless" structs inherit from their builtin type

Browse source 
* lisp/emacs-lisp/cl-preloaded.el (cl--struct-register-child):
Register child only in struct parents.
(cl-struct-define): Put the "type" as parent of parentless :type structs.
Copy slots only from struct parent classes.
(cl-structure-object): Set (manually) its parent to `record`
and remove assertion that it has no parents.
This commit is contained in:
Stefan Monnier 2024-03-07 16:58:15 -05:00
parent 76e9c761a4
commit 7c127fc965
1 changed files with 22 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

31
lisp/emacs-lisp/cl-preloaded.el
View file

@ -112,7 +112,7 @@
(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 (recordp parent)
(while (cl--struct-class-p 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 have one parent.
@ -127,9 +127,14 @@
(with-suppressed-warnings ((obsolete cl-old-struct-compat-mode))
(message "cl-old-struct-compat-mode is obsolete!")
(cl-old-struct-compat-mode 1)))
(if (eq type 'record)
;; Defstruct using record objects.
(setq type nil))
(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)
@ -137,7 +142,9 @@
(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)))
(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))
@ -160,7 +167,9 @@
name docstring
(unless (symbolp parent-class) (list parent-class))
type named vslots index-table children-sym tag print)))
(unless (symbolp parent-class)
(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))
@ -417,6 +426,13 @@ For this build of Emacs it's %dbit."
(cl--define-built-in-type subr-primitive (subr)
"Type of functions hand written in C.")
(unless (cl--class-parents (cl--find-class 'cl-structure-object))
;; When `cl-structure-object' is created, built-in classes didn't exist
;; yet, so we couldn't put `record' as the parent.
;; Fix it now to close the recursion.
(setf (cl--class-parents (cl--find-class 'cl-structure-object))
(list (cl--find-class 'record))))
(defconst cl--direct-supertypes-of-type
;; Please run `sycdoc-update-type-hierarchy' in
;; `admin/syncdoc-type-hierarchy.el' each time this is modified to
@ -447,9 +463,6 @@ supertypes from the most specific to least specific.")
(defconst cl--all-builtin-types
(delete-dups (copy-sequence (apply #'append cl--typeof-types))))
(eval-and-compile
(cl-assert (null (cl--class-parents (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.