From: Stefan Monnier <monnier@iro.umontreal.ca>
To: Andrea Corallo <acorallo@gnu.org>
Cc: emacs-devel@gnu.org, Eli Zaretskii <eliz@gnu.org>
Subject: Re: master 1d9d07fb00e 3/3: (cl--typeof-types): Rework to fix some regressions
Date: Wed, 06 Mar 2024 16:49:45 -0500 [thread overview]
Message-ID: <jwvle6vm3te.fsf-monnier+emacs@gnu.org> (raw)
In-Reply-To: <yp1jzmfuqlq.fsf@fencepost.gnu.org> (Andrea Corallo's message of "Wed, 06 Mar 2024 14:06:57 -0500")
[-- Attachment #1: Type: text/plain, Size: 601 bytes --]
> Yes I believe this affects the compiler as well. I'd like to fix it, I
> just have to find some time to read some cl- code to understand how to
> distinguish them, the patch should be easy.
For context, here's a WiP patch that doesn't do the above, but is
somewhat related.
For what you describe, I think the better change is to change the
`parents` slot of cl-struct classes so it points either to `cl-structure-object` or
`array` or `list`.
IOW, instead of having hacks to add the right parent when `parents` is
nil, `parents` should "never" be nil (except for the `t` type).
Stefan
[-- Attachment #2: define-type.patch --]
[-- Type: text/x-diff, Size: 20330 bytes --]
commit fc271dd765f7201b5f87348f34f24b9a51982b4d
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Date: Wed Mar 6 16:32:35 2024 -0500
define-built-in-type
diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el
index cf09006a7ff..38ab20c16a2 100644
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -716,7 +716,8 @@ cl-prettyexpand
;; FIXME: We could go crazy and add another entry so describe-symbol can be
;; used with the slot names of CL structs (and/or EIEIO objects).
(add-to-list 'describe-symbol-backends
- `(nil ,#'cl-find-class ,(lambda (s _b _f) (cl-describe-type s))))
+ `(nil ,#'cl-find-class ,#'cl-describe-type s)
+ t)
(defconst cl--typedef-regexp
(concat "(" (regexp-opt '("defclass" "defstruct" "cl-defstruct"
@@ -746,7 +747,7 @@ cl-find-class
(cl--find-class type))
;;;###autoload
-(defun cl-describe-type (type)
+(defun cl-describe-type (type &optional _buf _frame)
"Display the documentation for type TYPE (a symbol)."
(interactive
(let ((str (completing-read "Describe type: " obarray #'cl-find-class t)))
@@ -768,6 +769,15 @@ cl-describe-type
;; Return the text we displayed.
(buffer-string)))))
+(defun cl--class-children (class)
+ (let ((children '()))
+ (mapatoms
+ (lambda (sym)
+ (let ((sym-class (cl--find-class sym)))
+ (and sym-class (memq class (cl--class-parents sym-class))
+ (push sym children)))))
+ children))
+
(defun cl--describe-class (type &optional class)
(unless class (setq class (cl--find-class type)))
(let ((location (find-lisp-object-file-name type 'define-type))
@@ -798,10 +808,8 @@ cl--describe-class
(insert (substitute-command-keys (if pl "', " "'"))))
(insert ".\n")))
- ;; Children, if available. ¡For EIEIO!
- (let ((ch (condition-case nil
- (cl-struct-slot-value metatype 'children class)
- (cl-struct-unknown-slot nil)))
+ ;; Children.
+ (let ((ch (cl--class-children class))
cur)
(when ch
(insert " Children ")
@@ -905,22 +913,25 @@ cl--describe-class-slots
(cslots (condition-case nil
(cl-struct-slot-value metatype 'class-slots class)
(cl-struct-unknown-slot nil))))
- (insert (propertize "Instance Allocated Slots:\n\n"
- 'face 'bold))
- (let* ((has-doc nil)
- (slots-strings
- (mapcar
- (lambda (slot)
- (list (cl-prin1-to-string (cl--slot-descriptor-name slot))
- (cl-prin1-to-string (cl--slot-descriptor-type slot))
- (cl-prin1-to-string (cl--slot-descriptor-initform slot))
- (let ((doc (alist-get :documentation
- (cl--slot-descriptor-props slot))))
- (if (not doc) ""
- (setq has-doc t)
- (substitute-command-keys doc)))))
- slots)))
- (cl--print-table `("Name" "Type" "Default") slots-strings has-doc))
+ (if (and (null slots) (eq metatype 'built-in-class))
+ (insert "This a built-in type, with no exposed slots.\n")
+
+ (insert (propertize "Instance Allocated Slots:\n\n"
+ 'face 'bold))
+ (let* ((has-doc nil)
+ (slots-strings
+ (mapcar
+ (lambda (slot)
+ (list (cl-prin1-to-string (cl--slot-descriptor-name slot))
+ (cl-prin1-to-string (cl--slot-descriptor-type slot))
+ (cl-prin1-to-string (cl--slot-descriptor-initform slot))
+ (let ((doc (alist-get :documentation
+ (cl--slot-descriptor-props slot))))
+ (if (not doc) ""
+ (setq has-doc t)
+ (substitute-command-keys doc)))))
+ slots)))
+ (cl--print-table `("Name" "Type" "Default") slots-strings has-doc)))
(insert "\n")
(when (> (length cslots) 0)
(insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold))
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 0b15f7737f2..b761b00aaa4 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -1510,27 +1510,6 @@ cl-generic-generalizers
;;; Dispatch on "system types".
-(defconst cl--generic-typeof-types
- ;; Hand made from the source code of `type-of'.
- (append cl--typeof-types
- ;; Plus, really hand made:
- '((null boolean symbol list sequence atom)
- (boolean symbol list sequence atom)
- (keyword symbol atom)
- (base-char character natnum fixnum integer number atom)
- (character natnum fixnum integer number atom)
- (fixnum integer number atom)
- (cl--generic-function-subr subr function atom)
- (cl--generic-function-symbol function symbol atom)
- (cl--generic-function-cons function cons list sequence)))
- "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--generic-all-builtin-types
- (delete-dups (copy-sequence (apply #'append cl--generic-typeof-types))))
-
(defun cl--generic-typeof (x)
"Like `type-of' but returns a more refined type."
;; FIXME: Add support for other types accepted by `cl-typep' such
@@ -1559,9 +1538,12 @@ cl--generic-typeof
(ty ty)))
(cl-generic-define-generalizer cl--generic-typeof-generalizer
- 10 (lambda (name &rest _) `(cl--generic-typeof ,name))
+ 10 (lambda (name &rest _) `(type-of ,name)) ;; `(cl--generic-typeof ,name)
(lambda (tag &rest _)
- (and (symbolp tag) (assq tag cl--generic-typeof-types))))
+ (and (symbolp tag)
+ (let ((class (get tag 'cl--class)))
+ ;; Exclude t because it has its own generalizer.
+ (when class (remq t (cl--class-allparents class)))))))
(cl-defmethod cl-generic-generalizers :extra "typeof" (type)
"Support for dispatch on builtin types.
@@ -1570,13 +1552,10 @@ cl-generic-generalizers
;; FIXME: We could define two cl--generic-typeof-generalizers, one using
;; `cl--generic-typeof' and one using just `type-of' which we could
;; use when `type' doesn't need the refinement of cl--generic-typeof.
- (and (memq type cl--all-builtin-types)
- (progn
- ;; FIXME: While this wrinkle in the semantics can be occasionally
- ;; problematic, this warning is more often annoying than helpful.
- ;;(if (memq type '(vector array sequence))
- ;; (message "`%S' also matches CL structs and EIEIO classes"
- ;; type))
+ (let ((class (and (symbolp type)
+ ;; Exclude t because it has its own generalizer.
+ (not (eq type t)) (get type 'cl--class))))
+ (and class (built-in-class-p class)
(list cl--generic-typeof-generalizer)))
(cl-call-next-method)))
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index a93ba327b09..93737de7a90 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -52,91 +52,16 @@ cl--assertion-failed
(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)
- (interpreted-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
@@ -369,6 +294,157 @@ cl--class-allparents
(merge-ordered-lists (mapcar #'cl--class-allparents
(cl--class-parents class)))))
+(cl-defstruct (built-in-class
+ (:include cl--class)
+ (:constructor nil)
+ (:constructor built-in-type--class
+ (name docstring parents &optional slots index-table))
+ (:copier nil))
+ )
+
+(defmacro 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-type--class ',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.
+
+(define-built-in-type t nil "The type of everything.")
+(define-built-in-type atom t "The type of anything but cons cells.")
+
+(define-built-in-type tree-sitter-compiled-query atom)
+(define-built-in-type tree-sitter-node atom)
+(define-built-in-type tree-sitter-parser atom)
+(define-built-in-type user-ptr atom)
+(define-built-in-type font-object atom)
+(define-built-in-type font-entity atom)
+(define-built-in-type font-spec atom)
+(define-built-in-type condvar atom)
+(define-built-in-type mutex atom)
+(define-built-in-type thread atom)
+(define-built-in-type terminal atom)
+(define-built-in-type hash-table atom)
+(define-built-in-type frame atom)
+(define-built-in-type buffer atom)
+(define-built-in-type window atom)
+(define-built-in-type process atom)
+(define-built-in-type window-configuration atom)
+(define-built-in-type overlay atom)
+(define-built-in-type number-or-marker atom
+ "Abstract super type of both `number's and `marker's.")
+(define-built-in-type symbol atom
+ "Type of symbols."
+ (name symbol-name)
+ (value symbol-value)
+ (function symbol-function)
+ (plist symbol-plist))
+
+(define-built-in-type obarray atom)
+(define-built-in-type native-comp-unit atom)
+
+(define-built-in-type sequence t "Abstract super type of sequences.")
+(define-built-in-type list sequence)
+(define-built-in-type array (sequence atom) "Abstract super type of arrays.")
+(define-built-in-type number (number-or-marker)
+ "Abstract super type of numbers.")
+(define-built-in-type float (number))
+(define-built-in-type integer-or-marker (number-or-marker)
+ "Abstract super type of both `integer's and `marker's.")
+(define-built-in-type integer (number integer-or-marker))
+(define-built-in-type marker (integer-or-marker))
+(define-built-in-type bignum (integer)
+ "Type of those integers too large to fit in a `fixnum'.")
+(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)))))
+(define-built-in-type keyword (symbol)
+ "Type of those symbols whose first char is `:'.")
+(define-built-in-type boolean (symbol)
+ "Type of the canonical boolean values, i.e. either nil or t.")
+(define-built-in-type symbol-with-pos (symbol)
+ "Type of symbols augmented with source-position information.")
+(define-built-in-type vector (array))
+(define-built-in-type record (atom)
+ "Abstract type of typed objects with slots.")
+(define-built-in-type bool-vector (array) "Type of bitvectors.")
+(define-built-in-type char-table (array)
+ "Type of special arrays that are indexed by characters.")
+(define-built-in-type string (array))
+(define-built-in-type null (boolean list) ;FIXME: `atom' comes before `list'?
+ "Type of the nil value.")
+(define-built-in-type cons (list)
+ "Type of cons cells."
+ (car car) (cdr cdr))
+(define-built-in-type function (atom)
+ "Abstract super type of function values.")
+(define-built-in-type compiled-function (function)
+ "Abstract type of functions that have been compiled.")
+(define-built-in-type byte-code-function (compiled-function)
+ "Type of functions that have been byte-compiled.")
+(define-built-in-type subr (compiled-function)
+ "Abstract type of functions compiled to machine code.")
+(define-built-in-type module-function (function)
+ "Type of functions provided via the module API.")
+(define-built-in-type interpreted-function (function)
+ "Type of functions that have not been compiled.")
+(define-built-in-type subr-native-elisp (subr)
+ "Type of function that have been compiled by the native compiler.")
+(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)))))
diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el
index 55d92841cd5..90a3ffbcff8 100644
--- a/lisp/emacs-lisp/comp-cstr.el
+++ b/lisp/emacs-lisp/comp-cstr.el
@@ -38,12 +38,6 @@
(require 'cl-lib)
(require 'cl-extra) ;HACK: For `cl-find-class' when `cl-loaddefs' is missing.
-(defconst comp--typeof-builtin-types (mapcar (lambda (x)
- (append x '(t)))
- cl--typeof-types)
- ;; TODO can we just add t in `cl--typeof-types'?
- "Like `cl--typeof-types' but with t as common supertype.")
-
(cl-defstruct (comp-cstr (:constructor comp--type-to-cstr
(type &aux
(null (eq type 'null))
@@ -106,8 +100,7 @@ comp--all-classes
res))
(defun comp--compute-typeof-types ()
- (append comp--typeof-builtin-types
- (mapcar #'comp--cl-class-hierarchy (comp--all-classes))))
+ (mapcar #'comp--cl-class-hierarchy (comp--all-classes)))
(defun comp--compute--pred-type-h ()
(cl-loop with h = (make-hash-table :test #'eq)
next prev parent reply other threads:[~2024-03-06 21:49 UTC|newest]
Thread overview: 20+ messages / expand[flat|nested] mbox.gz Atom feed top
[not found] <170950733941.30552.13228431602613197760@vcs2.savannah.gnu.org>
[not found] ` <20240303230900.3A353C12C5E@vcs2.savannah.gnu.org>
2024-03-04 2:11 ` master 99483e214fd 2/3: Set org-macro-templates more lazily Po Lu
2024-03-04 3:11 ` Stefan Monnier
[not found] ` <20240303230900.51D39C12C5F@vcs2.savannah.gnu.org>
2024-03-04 9:36 ` master 1d9d07fb00e 3/3: (cl--typeof-types): Rework to fix some regressions Andrea Corallo
2024-03-04 9:46 ` Andrea Corallo
2024-03-04 15:55 ` Stefan Monnier
2024-03-04 16:19 ` Andrea Corallo
2024-03-05 0:08 ` Stefan Monnier
2024-03-05 9:34 ` Andrea Corallo
2024-03-05 14:35 ` Andrea Corallo
2024-03-05 15:30 ` Stefan Monnier
2024-03-05 17:25 ` Andrea Corallo
2024-03-05 18:06 ` Stefan Monnier
2024-03-06 12:34 ` Andrea Corallo
2024-03-06 16:19 ` Andrea Corallo
2024-03-06 17:09 ` Stefan Monnier
2024-03-06 19:06 ` Andrea Corallo
2024-03-06 21:49 ` Stefan Monnier [this message]
2024-03-07 3:37 ` Stefan Monnier
2024-03-07 8:03 ` Andrea Corallo
2024-03-08 7:44 ` Stefan Monnier
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=jwvle6vm3te.fsf-monnier+emacs@gnu.org \
--to=monnier@iro.umontreal.ca \
--cc=acorallo@gnu.org \
--cc=eliz@gnu.org \
--cc=emacs-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/emacs.git
https://git.savannah.gnu.org/cgit/emacs/org-mode.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.