From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Stefan Monnier Newsgroups: gmane.emacs.devel Subject: Re: master 1d9d07fb00e 3/3: (cl--typeof-types): Rework to fix some regressions Date: Wed, 06 Mar 2024 16:49:45 -0500 Message-ID: References: <170950733941.30552.13228431602613197760@vcs2.savannah.gnu.org> <20240303230900.51D39C12C5F@vcs2.savannah.gnu.org> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="4735"; mail-complaints-to="usenet@ciao.gmane.io" User-Agent: Gnus/5.13 (Gnus v5.13) Cc: emacs-devel@gnu.org, Eli Zaretskii To: Andrea Corallo Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane-mx.org@gnu.org Wed Mar 06 22:52:30 2024 Return-path: Envelope-to: ged-emacs-devel@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1rhzBe-00013O-BD for ged-emacs-devel@m.gmane-mx.org; Wed, 06 Mar 2024 22:52:30 +0100 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1rhzB1-0000sm-3Q; Wed, 06 Mar 2024 16:51:51 -0500 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1rhzAz-0000sK-Ia for emacs-devel@gnu.org; Wed, 06 Mar 2024 16:51:49 -0500 Original-Received: from mailscanner.iro.umontreal.ca ([132.204.25.50]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1rhzAw-0005WG-MH; Wed, 06 Mar 2024 16:51:49 -0500 Original-Received: from pmg2.iro.umontreal.ca (localhost.localdomain [127.0.0.1]) by pmg2.iro.umontreal.ca (Proxmox) with ESMTP id 4E9D580DB3; Wed, 6 Mar 2024 16:51:44 -0500 (EST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=iro.umontreal.ca; s=mail; t=1709761901; bh=XMmnOKVljfOmSBFZd2uvztH4z2vdCIuZn08WkhfXVx0=; h=From:To:Cc:Subject:In-Reply-To:References:Date:From; b=IDZZHtasVexqHoDpVp16mjxBPWXtVVGqGZ/1E5STR8z3rH2Ici0geHXyxR5NPG+AZ lB0L+co1Ao61VLwn+ePmhMVC6VcbHfGK1xmiDvdBbmZw+ZqXttXs+gWPAqUFjBdav/ yQkEq+Wg+SI7P3jW0qzGhdJqzz8I7TkN/x8pj/YDTRNA8r25AENx9dNFV6R8+dhRfD P3Q6WFDikKuV6Ikn6uF6UaJpMS+y6we848NGJXbDsqQsPbNZ2iJz8Ck2IRAj4hO0X2 BAnELzZXGaJJrezRDRhhLCLpEMGVnWcKHkhFQWma8HEtgLsTtnv6CdfoTPO2+Jbzsq GilHtnXsI7zAg== Original-Received: from mail01.iro.umontreal.ca (unknown [172.31.2.1]) by pmg2.iro.umontreal.ca (Proxmox) with ESMTP id E24CA80A88; Wed, 6 Mar 2024 16:51:41 -0500 (EST) Original-Received: from lechazo (lechon.iro.umontreal.ca [132.204.27.242]) by mail01.iro.umontreal.ca (Postfix) with ESMTPSA id CBA5D1208F7; Wed, 6 Mar 2024 16:51:41 -0500 (EST) In-Reply-To: (Andrea Corallo's message of "Wed, 06 Mar 2024 14:06:57 -0500") Received-SPF: pass client-ip=132.204.25.50; envelope-from=monnier@iro.umontreal.ca; helo=mailscanner.iro.umontreal.ca X-Spam_score_int: -42 X-Spam_score: -4.3 X-Spam_bar: ---- X-Spam_report: (-4.3 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, RCVD_IN_DNSWL_MED=-2.3, SPF_HELO_NONE=0.001, SPF_PASS=-0.001, T_SCC_BODY_TEXT_LINE=-0.01 autolearn=ham autolearn_force=no X-Spam_action: no action X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane-mx.org@gnu.org Original-Sender: emacs-devel-bounces+ged-emacs-devel=m.gmane-mx.org@gnu.org Xref: news.gmane.io gmane.emacs.devel:316867 Archived-At: --=-=-= Content-Type: text/plain > 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 --=-=-= Content-Type: text/x-diff; charset=iso-8859-1 Content-Disposition: inline; filename=define-type.patch Content-Transfer-Encoding: quoted-printable commit fc271dd765f7201b5f87348f34f24b9a51982b4d Author: Stefan Monnier 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) =20 (defconst cl--typedef-regexp (concat "(" (regexp-opt '("defclass" "defstruct" "cl-defstruct" @@ -746,7 +747,7 @@ cl-find-class (cl--find-class type)) =20 ;;;###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))))) =20 +(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"))) =20 - ;; Children, if available. =A1For 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 slo= t)) - (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 s= lot)) + (let ((doc (alist-get :documentation + (cl--slot-descriptor-props sl= ot)))) + (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 =20 ;;; Dispatch on "system types". =20 -(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))) =20 (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 ,nam= e) (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))))))) =20 (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))) =20 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))))) =20 -(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 reflect= ed - ;; in the DAG. - ;; - An OClosure can be an interpreted function or a `byte-code-functi= on', - ;; 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))))) =20 (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)))) =20 ;; When we load this (compiled) file during pre-loading, the cl--struct-cl= ass ;; code below will need to access the `cl-struct' info, since it's conside= red @@ -369,6 +294,157 @@ cl--class-allparents (merge-ordered-lists (mapcar #'cl--class-allparents (cl--class-parents class))))) =20 +(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 slo= ts) + ;; `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--clas= s))) + (unless class + (error "Unknown type: %S" ty= pe)) + 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 `lis= t'? + "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= ))))) =20 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 missi= ng. =20 -(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)) =20 (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))) =20 (defun comp--compute--pred-type-h () (cl-loop with h =3D (make-hash-table :test #'eq) --=-=-=--