From 9a747b3554515135d5acadfcb5c2b1b8240d8f84 Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Thu, 21 Dec 2017 18:25:49 +0100 Subject: [PATCH] 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(-) create mode 100644 test/lisp/emacs-lisp/cl-preloaded-tests.el diff --git a/etc/NEWS b/etc/NEWS index 80ddf10488c..b28f284116a 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 caad62c84f8..173173305b4 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 43eb4261162..4aed1f26624 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 92d29996f91..364de031334 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 edb1530cad5..6e9fb44b4b0 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 00000000000..008a6e629f5 --- /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 + +;; 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 . + +;;; 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 -- 2.39.2