* 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.

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index ca180ff6327924e44fb6b665ba2aedf8c1157dd9..bb8c97badf7223ccdfefefea2dfe003ad4ca0c3d 100644 (file)
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,11 @@
+2015-02-16  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+       * 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  <jeremy.compostella@gmail.com>
 
        * net/tramp-sh.el (tramp-remote-process-environment): Disable paging
@@ -5,8 +13,8 @@
 
 2015-02-14  Artur Malabarba  <bruce.connor.am@gmail.com>
 
-       * 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 548aaa9626ba451a3642fb125dac53aa5ac92225..e929c02eefbf9a0bc90d7361b132fe1085c32edc 100644 (file)
--- 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 c4232863cfc85458a8f2cb719bde4588068c0ca8..ccd5bec5685065266b65d6fd83e298be08dae3fc 100644 (file)
--- 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 2861d669697dffbb7f83c59115f4f488f1fe72fb..caaf7687dc81945f5ec62e836a1af1bf8f7d3288 100644 (file)
--- 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 03045de509aa4ee371190613be125094ecb06425..401d34b449e56cb5ff81a4d80a0a37a9a97b266b 100644 (file)
--- 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)))