[Emacs-diffs] master 9a747b3: Prevent name clashes between CL structures and builtin types

[Philipp Stephani]

branch: master
commit 9a747b3554515135d5acadfcb5c2b1b8240d8f84
Author: Philipp Stephani <address@hidden>
Commit: Philipp Stephani <address@hidden>

    Prevent name clashes between CL structures and builtin types
    
    * lisp/emacs-lisp/cl-preloaded.el (cl-struct-define): Don't allow
    structures with the same names as builtin types.
    (cl--typeof-types, cl--all-builtin-types): Move from cl-generic.el and
    rename.
    (cl--struct-name-p): New helper function.
    
    * lisp/emacs-lisp/cl-macs.el (cl-defstruct): Don't allow structures
    with the same names as builtin types.
    
    * lisp/emacs-lisp/cl-generic.el (cl--generic-typeof-generalizer)
    (cl-generic-generalizers): Adapt to name change.
    
    * test/lisp/emacs-lisp/cl-macs-tests.el (cl-defstruct/builtin-type):
    * test/lisp/emacs-lisp/cl-preloaded-tests.el
    (cl-struct-define/builtin-type): New unit tests.
    
    * etc/NEWS: Document changed behavior.
---
 etc/NEWS                                   |  4 ++++
 lisp/emacs-lisp/cl-generic.el              | 32 +++--------------------------
 lisp/emacs-lisp/cl-macs.el                 |  3 +++
 lisp/emacs-lisp/cl-preloaded.el            | 32 +++++++++++++++++++++++++++++
 test/lisp/emacs-lisp/cl-macs-tests.el      | 10 ++++++++-
 test/lisp/emacs-lisp/cl-preloaded-tests.el | 33 ++++++++++++++++++++++++++++++
 6 files changed, 84 insertions(+), 30 deletions(-)

diff --git a/etc/NEWS b/etc/NEWS
index 80ddf10..b28f284 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -220,6 +220,10 @@ calling 'eldoc-message' directly.
 generating warnings for a decade.  To interpret old-style backquotes
 as new-style, bind the new variable 'force-new-style-backquotes' to t.
 
+** Defining a Common Lisp structure using 'cl-defstruct' or
+'cl-struct-define' whose name clashes with a builtin type (e.g.,
+'integer' or 'hash-table') now signals an error.
+
 
 * Lisp Changes in Emacs 27.1
 
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index caad62c..1731733 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -1160,45 +1160,19 @@ These match if the argument is `eql' to VAL."
 
 ;;; Dispatch on "system types".
 
-(defconst cl--generic-typeof-types
-  ;; Hand made from the source code of `type-of'.
-  '((integer number number-or-marker atom)
-    (symbol atom) (string array sequence atom)
-    (cons list sequence)
-    ;; Markers aren't `numberp', yet they are accepted wherever integers are
-    ;; accepted, pretty much.
-    (marker number-or-marker atom)
-    (overlay atom) (float number atom) (window-configuration atom)
-    (process atom) (window atom) (subr atom) (compiled-function function atom)
-    (buffer atom) (char-table array sequence atom)
-    (bool-vector array sequence atom)
-    (frame atom) (hash-table atom) (terminal atom)
-    (thread atom) (mutex atom) (condvar atom)
-    (font-spec atom) (font-entity atom) (font-object atom)
-    (vector array sequence atom)
-    ;; Plus, really hand made:
-    (null symbol list sequence atom))
-  "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))))
-
 (cl-generic-define-generalizer cl--generic-typeof-generalizer
   ;; FIXME: We could also change `type-of' to return `null' for nil.
   10 (lambda (name &rest _) `(if ,name (type-of ,name) 'null))
   (lambda (tag &rest _)
-    (and (symbolp tag) (assq tag cl--generic-typeof-types))))
+    (and (symbolp tag) (assq tag cl--typeof-types))))
 
 (cl-defmethod cl-generic-generalizers :extra "typeof" (type)
   "Support for dispatch on builtin types.
-See the full list and their hierarchy in `cl--generic-typeof-types'."
+See the full list and their hierarchy in `cl--typeof-types'."
   ;; FIXME: Add support for other types accepted by `cl-typep' such
   ;; as `character', `face', `function', ...
   (or
-   (and (memq type cl--generic-all-builtin-types)
+   (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.
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 43eb426..4aed1f2 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -2687,6 +2687,9 @@ non-nil value, that slot cannot be set via `setf'.
         (forms nil)
          (docstring (if (stringp (car descs)) (pop descs)))
         pred-form pred-check)
+    ;; Can't use `cl-check-type' yet.
+    (unless (cl--struct-name-p name)
+      (signal 'wrong-type-argument (list 'cl-struct-name-p name 'name)))
     (setq descs (cons '(cl-tag-slot)
                      (mapcar (function (lambda (x) (if (consp x) x (list x))))
                              descs)))
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index 92d2999..364de03 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -50,6 +50,37 @@
         (apply #'error string (append sargs args))
       (signal 'cl-assertion-failed `(,form ,@sargs)))))
 
+(defconst cl--typeof-types
+  ;; Hand made from the source code of `type-of'.
+  '((integer number number-or-marker atom)
+    (symbol atom) (string array sequence atom)
+    (cons list sequence)
+    ;; Markers aren't `numberp', yet they are accepted wherever integers are
+    ;; accepted, pretty much.
+    (marker number-or-marker atom)
+    (overlay atom) (float number atom) (window-configuration atom)
+    (process atom) (window atom) (subr atom) (compiled-function function atom)
+    (buffer atom) (char-table array sequence atom)
+    (bool-vector array sequence atom)
+    (frame atom) (hash-table atom) (terminal atom)
+    (thread atom) (mutex atom) (condvar atom)
+    (font-spec atom) (font-entity atom) (font-object atom)
+    (vector array sequence atom)
+    ;; Plus, really hand made:
+    (null symbol list sequence atom))
+  "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--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))))
+
 ;; 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
@@ -110,6 +141,7 @@
 ;;;###autoload
 (defun cl-struct-define (name docstring parent type named slots children-sym
                               tag print)
+  (cl-check-type name cl--struct-name)
   (unless type
     ;; Legacy defstruct, using tagged vectors.  Enable backward compatibility.
     (cl-old-struct-compat-mode 1))
diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el 
b/test/lisp/emacs-lisp/cl-macs-tests.el
index edb1530..6e9fb44 100644
--- a/test/lisp/emacs-lisp/cl-macs-tests.el
+++ b/test/lisp/emacs-lisp/cl-macs-tests.el
@@ -497,7 +497,6 @@ collection clause."
                           vconcat (vector (1+ x)))
                  [2 3 4 5 6])))
 
-
 (ert-deftest cl-macs-loop-for-as-equals-and ()
   "Test for https://debbugs.gnu.org/29799 ."
   (let ((arr (make-vector 3 0)))
@@ -505,4 +504,13 @@ collection clause."
                    (cl-loop for k below 3 for x = k and z = (elt arr k)
                             collect (list k x))))))
 
+
+(ert-deftest cl-defstruct/builtin-type ()
+  (should-error
+   (macroexpand '(cl-defstruct hash-table))
+   :type 'wrong-type-argument)
+  (should-error
+   (macroexpand '(cl-defstruct (hash-table (:predicate hash-table-p))))
+   :type 'wrong-type-argument))
+
 ;;; cl-macs-tests.el ends here
diff --git a/test/lisp/emacs-lisp/cl-preloaded-tests.el 
b/test/lisp/emacs-lisp/cl-preloaded-tests.el
new file mode 100644
index 0000000..008a6e6
--- /dev/null
+++ b/test/lisp/emacs-lisp/cl-preloaded-tests.el
@@ -0,0 +1,33 @@
+;;; cl-preloaded-tests.el --- unit tests for cl-preloaded.el  -*- 
lexical-binding: t; -*-
+
+;; Copyright (C) 2017 Free Software Foundation, Inc.
+;; Author: Philipp Stephani <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Unit tests for lisp/emacs-lisp/cl-preloaded.el.
+
+;;; Code:
+
+(ert-deftest cl-struct-define/builtin-type ()
+  (should-error
+   (cl-struct-define 'hash-table nil nil 'record nil nil
+                     'cl-preloaded-tests-tag 'cl-preloaded-tests nil)
+   :type 'wrong-type-argument))
+
+;;; cl-preloaded-tests.el ends here