diff options
Diffstat (limited to 'lisp/emacs-lisp/cl-preloaded.el')
| -rw-r--r-- | lisp/emacs-lisp/cl-preloaded.el | 241 |
1 files changed, 161 insertions, 80 deletions
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index ea08d35ecec..882b4b5939b 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -50,90 +50,16 @@ (apply #'error string (append sargs args)) (signal 'cl-assertion-failed `(,form ,@sargs))))) -(defconst cl--direct-supertypes-of-type - ;; Please run `sycdoc-update-type-hierarchy' in - ;; `admin/syncdoc-type-hierarchy.el' each time this is modified to - ;; reflect the change in the documentation. - (let ((table (make-hash-table :test #'eq))) - ;; FIXME: Our type DAG has various quirks: - ;; - `subr' says it's a `compiled-function' but that's not true - ;; for those subrs that are special forms! - ;; - Some `keyword's are also `symbol-with-pos' but that's not reflected - ;; in the DAG. - ;; - An OClosure can be an interpreted function or a `byte-code-function', - ;; so the DAG of OClosure types is "orthogonal" to the distinction - ;; between interpreted and compiled functions. - (dolist (x '((sequence t) - (atom t) - (list sequence) - (array sequence atom) - (float number) - (integer number integer-or-marker) - (marker integer-or-marker) - (integer-or-marker number-or-marker) - (number number-or-marker) - (bignum integer) - (fixnum integer) - (keyword symbol) - (boolean symbol) - (symbol-with-pos symbol) - (vector array) - (bool-vector array) - (char-table array) - (string array) - ;; FIXME: This results in `atom' coming before `list' :-( - (null boolean list) - (cons list) - (function atom) - (byte-code-function compiled-function) - (subr compiled-function) - (module-function function) - (compiled-function function) - (subr-native-elisp subr) - (subr-primitive subr))) - (puthash (car x) (cdr x) table)) - ;; And here's the flat part of the hierarchy. - (dolist (atom '( tree-sitter-compiled-query tree-sitter-node - tree-sitter-parser user-ptr - font-object font-entity font-spec - condvar mutex thread terminal hash-table frame - ;; function ;; FIXME: can be a list as well. - buffer window process window-configuration - overlay number-or-marker - symbol obarray native-comp-unit)) - (cl-assert (null (gethash atom table))) - (puthash atom '(atom) table)) - table) - "Hash table TYPE -> SUPERTYPES.") - -(defconst cl--typeof-types - (letrec ((alist nil) - (allparents - (lambda (type) - ;; FIXME: copy&pasted from `cl--class-allparents'. - (let ((parents (gethash type cl--direct-supertypes-of-type))) - (unless parents - (message "Warning: Type without parent: %S!" type)) - (cons type - (merge-ordered-lists - ;; FIXME: Can't remember why `t' is excluded. - (mapcar allparents (remq t parents)))))))) - (maphash (lambda (type _) - (push (funcall allparents type) alist)) - cl--direct-supertypes-of-type) - alist) - "Alist of supertypes. -Each element has the form (TYPE . SUPERTYPES) where TYPE is one of -the symbols returned by `type-of', and SUPERTYPES is the list of its -supertypes from the most specific to least specific.") - -(defconst cl--all-builtin-types - (delete-dups (copy-sequence (apply #'append cl--typeof-types)))) +(defun cl--builtin-type-p (name) + (if (not (fboundp 'built-in-class-p)) ;; Early bootstrap + nil + (let ((class (and (symbolp name) (get name 'cl--class)))) + (and class (built-in-class-p class))))) (defun cl--struct-name-p (name) "Return t if NAME is a valid structure name for `cl-defstruct'." (and name (symbolp name) (not (keywordp name)) - (not (memq name cl--all-builtin-types)))) + (not (cl--builtin-type-p name)))) ;; 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 @@ -366,6 +292,161 @@ supertypes from the most specific to least specific.") (merge-ordered-lists (mapcar #'cl--class-allparents (cl--class-parents class))))) +(cl-defstruct (built-in-class + (:include cl--class) + (:constructor nil) + (:constructor built-in-class--make (name docstring parents)) + (:copier nil)) + ) + +(defmacro cl--define-built-in-type (name parents &optional docstring &rest _slots) + ;; `slots' is currently unused, but we could make it take + ;; a list of "slot like properties" together with the corresponding + ;; accessor, and then we could maybe even make `slot-value' work + ;; on some built-in types :-) + (declare (indent 2) (doc-string 3)) + (unless (listp parents) (setq parents (list parents))) + (unless (or parents (eq name t)) + (error "Missing parents for %S: %S" name parents)) + `(progn + (put ',name 'cl--class + (built-in-class--make ',name ,docstring + (mapcar (lambda (type) + (let ((class (get type 'cl--class))) + (unless class + (error "Unknown type: %S" type)) + class)) + ',parents))))) + +;; FIXME: Our type DAG has various quirks: +;; - `subr' says it's a `compiled-function' but that's not true +;; for those subrs that are special forms! +;; - Some `keyword's are also `symbol-with-pos' but that's not reflected +;; in the DAG. +;; - An OClosure can be an interpreted function or a `byte-code-function', +;; so the DAG of OClosure types is "orthogonal" to the distinction +;; between interpreted and compiled functions. + +(cl--define-built-in-type t nil "The type of everything.") +(cl--define-built-in-type atom t "The type of anything but cons cells.") + +(cl--define-built-in-type tree-sitter-compiled-query atom) +(cl--define-built-in-type tree-sitter-node atom) +(cl--define-built-in-type tree-sitter-parser atom) +(cl--define-built-in-type user-ptr atom) +(cl--define-built-in-type font-object atom) +(cl--define-built-in-type font-entity atom) +(cl--define-built-in-type font-spec atom) +(cl--define-built-in-type condvar atom) +(cl--define-built-in-type mutex atom) +(cl--define-built-in-type thread atom) +(cl--define-built-in-type terminal atom) +(cl--define-built-in-type hash-table atom) +(cl--define-built-in-type frame atom) +(cl--define-built-in-type buffer atom) +(cl--define-built-in-type window atom) +(cl--define-built-in-type process atom) +(cl--define-built-in-type window-configuration atom) +(cl--define-built-in-type overlay atom) +(cl--define-built-in-type number-or-marker atom + "Abstract super type of both `number's and `marker's.") +(cl--define-built-in-type symbol atom + "Type of symbols." + ;; Example of slots we could document. It would be desirable to + ;; have some way to extract this from the C code, or somehow keep it + ;; in sync (probably not for `cons' and `symbol' but for things like + ;; `font-entity'). + (name symbol-name) + (value symbol-value) + (function symbol-function) + (plist symbol-plist)) + +(cl--define-built-in-type obarray atom) +(cl--define-built-in-type native-comp-unit atom) + +(cl--define-built-in-type sequence t "Abstract super type of sequences.") +(cl--define-built-in-type list sequence) +(cl--define-built-in-type array (sequence atom) "Abstract super type of arrays.") +(cl--define-built-in-type number (number-or-marker) + "Abstract super type of numbers.") +(cl--define-built-in-type float (number)) +(cl--define-built-in-type integer-or-marker (number-or-marker) + "Abstract super type of both `integer's and `marker's.") +(cl--define-built-in-type integer (number integer-or-marker)) +(cl--define-built-in-type marker (integer-or-marker)) +(cl--define-built-in-type bignum (integer) + "Type of those integers too large to fit in a `fixnum'.") +(cl--define-built-in-type fixnum (integer) + (format "Type of small (fixed-size) integers. +The size depends on the Emacs version and compilation options. +For this build of Emacs it's %dbit." + (1+ (logb (1+ most-positive-fixnum))))) +(cl--define-built-in-type keyword (symbol) + "Type of those symbols whose first char is `:'.") +(cl--define-built-in-type boolean (symbol) + "Type of the canonical boolean values, i.e. either nil or t.") +(cl--define-built-in-type symbol-with-pos (symbol) + "Type of symbols augmented with source-position information.") +(cl--define-built-in-type vector (array)) +(cl--define-built-in-type record (atom) + "Abstract type of objects with slots.") +(cl--define-built-in-type bool-vector (array) "Type of bitvectors.") +(cl--define-built-in-type char-table (array) + "Type of special arrays that are indexed by characters.") +(cl--define-built-in-type string (array)) +(cl--define-built-in-type null (boolean list) ;FIXME: `atom' comes before `list'? + "Type of the nil value.") +(cl--define-built-in-type cons (list) + "Type of cons cells." + ;; Example of slots we could document. + (car car) (cdr cdr)) +(cl--define-built-in-type function (atom) + "Abstract super type of function values.") +(cl--define-built-in-type compiled-function (function) + "Abstract type of functions that have been compiled.") +(cl--define-built-in-type byte-code-function (compiled-function) + "Type of functions that have been byte-compiled.") +(cl--define-built-in-type subr (compiled-function) + "Abstract type of functions compiled to machine code.") +(cl--define-built-in-type module-function (function) + "Type of functions provided via the module API.") +(cl--define-built-in-type interpreted-function (function) + "Type of functions that have not been compiled.") +(cl--define-built-in-type subr-native-elisp (subr) + "Type of function that have been compiled by the native compiler.") +(cl--define-built-in-type subr-primitive (subr) + "Type of functions hand written in C.") + +(defconst cl--direct-supertypes-of-type + ;; Please run `sycdoc-update-type-hierarchy' in + ;; `admin/syncdoc-type-hierarchy.el' each time this is modified to + ;; reflect the change in the documentation. + (let ((table (make-hash-table :test #'eq))) + (mapatoms + (lambda (type) + (let ((class (get type 'cl--class))) + (when (built-in-class-p class) + (puthash type (mapcar #'cl--class-name (cl--class-parents class)) + table))))) + table) + "Hash table TYPE -> SUPERTYPES.") + +(defconst cl--typeof-types + (letrec ((alist nil)) + (maphash (lambda (type _) + (let ((class (get type 'cl--class))) + ;; FIXME: Can't remember why `t' is excluded. + (push (remq t (cl--class-allparents class)) alist))) + cl--direct-supertypes-of-type) + alist) + "Alist of supertypes. +Each element has the form (TYPE . SUPERTYPES) where TYPE is one of +the symbols returned by `type-of', and SUPERTYPES is the list of its +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))))) |