From 6bf61df8ab359f1371ab2e3e278bc8642d65a985 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 16 Feb 2015 01:37:57 -0500 Subject: [PATCH] * lisp/emacs-lisp/cl-macs.el (cl-defstruct): Keep type=nil by default. * lisp/emacs-lisp/cl-preloaded.el (cl-struct-define): Add sanity checks about relationship between `type', `named', and `slots'. * lisp/emacs-lisp/cl-generic.el (cl--generic-struct-tagcode): Adjust to new value of `cl-struct-type' property. --- lisp/ChangeLog | 12 ++++++++++-- lisp/emacs-lisp/bytecomp.el | 14 +++++++------- lisp/emacs-lisp/cl-generic.el | 4 ++-- lisp/emacs-lisp/cl-macs.el | 8 ++++---- lisp/emacs-lisp/cl-preloaded.el | 4 ++++ 5 files changed, 27 insertions(+), 15 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index ca180ff6327..bb8c97badf7 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,11 @@ +2015-02-16 Stefan Monnier + + * emacs-lisp/cl-macs.el (cl-defstruct): Keep type=nil by default. + * emacs-lisp/cl-preloaded.el (cl-struct-define): Add sanity checks + about relationship between `type', `named', and `slots'. + * emacs-lisp/cl-generic.el (cl--generic-struct-tagcode): Adjust to new + value of `cl-struct-type' property. + 2015-02-15 Jérémy Compostella * net/tramp-sh.el (tramp-remote-process-environment): Disable paging @@ -5,8 +13,8 @@ 2015-02-14 Artur Malabarba - * emacs-lisp/package.el (package-read-all-archive-contents): Don't - build the compatibility table. + * emacs-lisp/package.el (package-read-all-archive-contents): + Don't build the compatibility table. (package-refresh-contents, package-initialize): Do build the compatibility table. (package--build-compatibility-table): New function. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 548aaa9626b..e929c02eefb 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1353,13 +1353,13 @@ extra args." (let ((keyword-args (cdr (cdr (cdr (cdr form))))) (name (cadr form))) (or (not (eq (car-safe name) 'quote)) - (and (eq (car form) 'custom-declare-group) - (equal name ''emacs)) - (plist-get keyword-args :group) - (not (and (consp name) (eq (car name) 'quote))) - (byte-compile-warn - "%s for `%s' fails to specify containing group" - (cdr (assq (car form) + (and (eq (car form) 'custom-declare-group) + (equal name ''emacs)) + (plist-get keyword-args :group) + (not (and (consp name) (eq (car name) 'quote))) + (byte-compile-warn + "%s for `%s' fails to specify containing group" + (cdr (assq (car form) '((custom-declare-group . defgroup) (custom-declare-face . defface) (custom-declare-variable . defcustom)))) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index c4232863cfc..ccd5bec5685 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -731,7 +731,7 @@ Can only be used from within the lexical body of a primary or around method." (defun cl--generic-struct-tagcode (type name) (and (symbolp type) (get type 'cl-struct-type) - (or (eq 'vector (car (get type 'cl-struct-type))) + (or (null (car (get type 'cl-struct-type))) (error "Can't dispatch on cl-struct %S: type is %S" type (car (get type 'cl-struct-type)))) (or (equal '(cl-tag-slot) (car (get type 'cl-struct-slots))) @@ -761,7 +761,7 @@ Can only be used from within the lexical body of a primary or around method." (let ((types (list (intern (substring (symbol-name tag) 10))))) (while (get (car types) 'cl-struct-include) (push (get (car types) 'cl-struct-include) types)) - (push 'cl-struct types) ;The "parent type" of all cl-structs. + (push 'cl-structure-object types) ;The "parent type" of all cl-structs. (nreverse types)))) ;;; Dispatch on "system types". diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 2861d669697..caaf7687dc8 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2494,7 +2494,7 @@ non-nil value, that slot cannot be set via `setf'. (or (memq type '(vector list)) (error "Invalid :type specifier: %s" type)) (if named (setq tag name))) - (setq type 'vector named 'true))) + (setq named 'true))) (or named (setq descs (delq (assq 'cl-tag-slot descs) descs))) (when (and (null predicate) named) (setq predicate (intern (format "cl--struct-%s-p" name)))) @@ -2503,7 +2503,7 @@ non-nil value, that slot cannot be set via `setf'. (length (memq (assq 'cl-tag-slot descs) descs))))) (cond - ((eq type 'vector) + ((memq type '(nil vector)) `(and (vectorp cl-x) (>= (length cl-x) ,(length descs)) (memq (aref cl-x ,pos) ,tag-symbol))) @@ -2535,7 +2535,7 @@ non-nil value, that slot cannot be set via `setf'. (list `(or ,pred-check (error "%s accessing a non-%s" ',accessor ',name)))) - ,(if (eq type 'vector) `(aref cl-x ,pos) + ,(if (memq type '(nil vector)) `(aref cl-x ,pos) (if (= pos 0) '(car cl-x) `(nth ,pos cl-x)))) forms) @@ -2593,7 +2593,7 @@ non-nil value, that slot cannot be set via `setf'. (&cl-defs '(nil ,@descs) ,@args) ,@(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs))) '((declare (side-effect-free t)))) - (,type ,@make)) + (,(or type #'vector) ,@make)) forms))) (if print-auto (nconc print-func (list '(princ ")" cl-s) t))) ;; Don't bother adding to cl-custom-print-functions since it's not used diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 03045de509a..401d34b449e 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -28,8 +28,12 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) + (defun cl-struct-define (name docstring parent type named slots children-sym tag print-auto) + (cl-assert (or type (equal '(cl-tag-slot) (car slots)))) + (cl-assert (or type (not named))) (if (boundp children-sym) (add-to-list children-sym tag) (set children-sym (list tag))) -- 2.39.2