Merge branch 'master' of git.sv.gnu.org:/srv/git/emacs

9 files changed, 230 insertions, 139 deletions

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 8eb189873d2..eb6ef6b19d2 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -63,6 +63,24 @@
         Fix dired quoting bug with "Hit`N`Hide".  Fixes Bug#19498.
         * files.el (shell-quote-wildcard-pattern): Also quote "`".
 
+2015-01-28  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+        Tighten up the tagcode used for eieio and cl-struct objects.
+        * loadup.el: Load cl-preloaded.
+        * emacs-lisp/eieio-core.el (eieio-defclass-internal): Set the function
+        slot of the tag symbol to :quick-object-witness-check.
+        (eieio-object-p): Use :quick-object-witness-check.
+        (eieio--generic-tagcode): Use cl--generic-struct-tag.
+        * emacs-lisp/cl-preloaded.el: New file.
+        * emacs-lisp/cl-macs.el (cl--bind-inits): Remove, unused.
+        (cl--transform-lambda, cl-destructuring-bind): Remove cl--bind-inits.
+        (cl--make-usage-args): Strip away &aux args.
+        (cl-case, cl-typecase, cl--parse-loop-clause): Use macroexp-let2.
+        (cl-the, cl-check-type): Use macroexp-let2 and cl-typep.
+        (cl-defstruct): Use `declare' and cl-struct-define.
+        * emacs-lisp/cl-generic.el (cl--generic-struct-tag): New function.
+        (cl--generic-struct-tagcode): Use it to tighten the tagcode.
+
 2015-01-27  Katsumi Yamaoka  <yamaoka@jpl.org>
 
         * emacs-lisp/cl.el (cl--function-convert):
@@ -150,6 +168,8 @@
 2015-01-26  Lars Ingebrigtsen  <larsi@gnus.org>
 
         * net/shr.el (shr-make-table-1): Fix colspan typo.
+        (shr-make-table-1): Add comments.
+        (shr-make-table-1): Make colspan display more sensibly.
 
         * net/eww.el (eww-add-bookmark): Fix prompt and clean up the code
         slightly.
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 1bb70963a57..3e34ab6e4d2 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -724,6 +724,14 @@ Can only be used from within the lexical body of a primary or around method."
 
 (add-function :before-until cl-generic-tagcode-function
               #'cl--generic-struct-tagcode)
+
+(defun cl--generic-struct-tag (name)
+  `(and (vectorp ,name)
+        (> (length ,name) 0)
+        (let ((tag (aref ,name 0)))
+          (if (eq (symbol-function tag) :quick-object-witness-check)
+              tag))))
+
 (defun cl--generic-struct-tagcode (type name)
   (and (symbolp type)
        (get type 'cl-struct-type)
@@ -733,12 +741,19 @@ Can only be used from within the lexical body of a primary or around method."
        (or (equal '(cl-tag-slot) (car (get type 'cl-struct-slots)))
            (error "Can't dispatch on cl-struct %S: no tag in slot 0"
                   type))
-       ;; We could/should check the vector has length >0,
-       ;; but really, mixing vectors and structs is a bad idea,
-       ;; so let's not waste time trying to handle the case
-       ;; of an empty vector.
-       ;; BEWARE: this returns a bogus tag for non-struct vectors.
-       `(50 . (and (vectorp ,name) (aref ,name 0)))))
+       ;; It's tempting to use (and (vectorp ,name) (aref ,name 0))
+       ;; but that would suffer from some problems:
+       ;; - the vector may have size 0.
+       ;; - when called on an actual vector (rather than an object), we'd
+       ;;   end up returning an arbitrary value, possibly colliding with
+       ;;   other tagcode's values.
+       ;; - it can also result in returning all kinds of irrelevant
+       ;;   values which would end up filling up the method-cache with
+       ;;   lots of irrelevant/redundant entries.
+       ;; FIXME: We could speed this up by introducing a dedicated
+       ;; vector type at the C level, so we could do something like
+       ;; (and (vector-objectp ,name) (aref ,name 0))
+       `(50 . ,(cl--generic-struct-tag name))))
 
 (add-function :before-until cl-generic-tag-types-function
               #'cl--generic-struct-tag-types)
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 38f15b89b0e..eaec2c5263c 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -221,7 +221,7 @@ The name is made by appending a number to PREFIX, default \"G\"."
   '(&optional &rest &key &allow-other-keys &aux &whole &body &environment))
 
 (defvar cl--bind-block) (defvar cl--bind-defs) (defvar cl--bind-enquote)
-(defvar cl--bind-inits) (defvar cl--bind-lets) (defvar cl--bind-forms)
+(defvar cl--bind-lets) (defvar cl--bind-forms)
 
 (defun cl--transform-lambda (form bind-block)
   "Transform a function form FORM of name BIND-BLOCK.
@@ -229,9 +229,11 @@ BIND-BLOCK is the name of the symbol to which the function will be bound,
 and which will be used for the name of the `cl-block' surrounding the
 function's body.
 FORM is of the form (ARGS . BODY)."
+  ;; FIXME: (lambda (a &aux b) 1) expands to (lambda (a &rest --cl-rest--) ...)
+  ;; where the --cl-rest-- is clearly undesired.
   (let* ((args (car form)) (body (cdr form)) (orig-args args)
          (cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote nil)
-         (cl--bind-inits nil) (cl--bind-lets nil) (cl--bind-forms nil)
+         (cl--bind-lets nil) (cl--bind-forms nil)
          (header nil) (simple-args nil))
     (while (or (stringp (car body))
                (memq (car-safe (car body)) '(interactive declare cl-declare)))
@@ -244,10 +246,10 @@ FORM is of the form (ARGS . BODY)."
     (if (setq cl--bind-enquote (memq '&cl-quote args))
         (setq args (delq '&cl-quote args)))
     (if (memq '&whole args) (error "&whole not currently implemented"))
-    (let* ((p (memq '&environment args)) (v (cadr p))
-           (env-exp 'macroexpand-all-environment))
+    (let* ((p (memq '&environment args))
+           (v (cadr p)))
       (if p (setq args (nconc (delq (car p) (delq v args))
-                              (list '&aux (list v env-exp))))))
+                              `(&aux (,v macroexpand-all-environment))))))
     (while (and args (symbolp (car args))
                 (not (memq (car args) '(nil &rest &body &key &aux)))
                 (not (and (eq (car args) '&optional)
@@ -261,8 +263,7 @@ FORM is of the form (ARGS . BODY)."
       (cl--do-arglist args nil (- (length simple-args)
                                   (if (memq '&optional simple-args) 1 0)))
       (setq cl--bind-lets (nreverse cl--bind-lets))
-      (cl-list* (and cl--bind-inits `(cl-eval-when (compile load eval)
-                                ,@(nreverse cl--bind-inits)))
+      (cl-list* nil
              (nconc (nreverse simple-args)
                     (list '&rest (car (pop cl--bind-lets))))
              (nconc (let ((hdr (nreverse header)))
@@ -390,6 +391,11 @@ its argument list allows full Common Lisp conventions."
    (t x)))
 
 (defun cl--make-usage-args (arglist)
+  (let ((aux (ignore-errors (cl-position '&aux arglist))))
+    (when aux
+      ;; `&aux' args aren't arguments, so let's just drop them from the
+      ;; usage info.
+      (setq arglist (cl-subseq arglist 0 aux))))
   (if (cdr-safe (last arglist))         ;Not a proper list.
       (let* ((last (last arglist))
              (tail (cdr last)))
@@ -426,7 +432,7 @@ its argument list allows full Common Lisp conventions."
                    ))))
               arglist))))
 
-(defun cl--do-arglist (args expr &optional num)   ; uses bind-*
+(defun cl--do-arglist (args expr &optional num)   ; uses cl--bind-*
   (if (nlistp args)
       (if (or (memq args cl--lambda-list-keywords) (not (symbolp args)))
           (error "Invalid argument name: %s" args)
@@ -441,9 +447,9 @@ its argument list allows full Common Lisp conventions."
           (keys nil)
           (laterarg nil) (exactarg nil) minarg)
       (or num (setq num 0))
-      (if (listp (cadr restarg))
-          (setq restarg (make-symbol "--cl-rest--"))
-        (setq restarg (cadr restarg)))
+      (setq restarg (if (listp (cadr restarg))
+                        (make-symbol "--cl-rest--")
+                      (cadr restarg)))
       (push (list restarg expr) cl--bind-lets)
       (if (eq (car args) '&whole)
           (push (list (cl--pop2 args) restarg) cl--bind-lets))
@@ -570,12 +576,11 @@ its argument list allows full Common Lisp conventions."
   "Bind the variables in ARGS to the result of EXPR and execute BODY."
   (declare (indent 2)
            (debug (&define cl-macro-list def-form cl-declarations def-body)))
-  (let* ((cl--bind-lets nil) (cl--bind-forms nil) (cl--bind-inits nil)
+  (let* ((cl--bind-lets nil) (cl--bind-forms nil)
          (cl--bind-defs nil) (cl--bind-block 'cl-none) (cl--bind-enquote nil))
     (cl--do-arglist (or args '(&aux)) expr)
-    (append '(progn) cl--bind-inits
-            (list `(let* ,(nreverse cl--bind-lets)
-                     ,@(nreverse cl--bind-forms) ,@body)))))
+    (macroexp-let* (nreverse cl--bind-lets)
+                   (macroexp-progn (append (nreverse cl--bind-forms) body)))))
 
 
 ;;; The `cl-eval-when' form.
@@ -655,30 +660,26 @@ allowed only in the final clause, and matches if no other keys match.
 Key values are compared by `eql'.
 \n(fn EXPR (KEYLIST BODY...)...)"
   (declare (indent 1) (debug (form &rest (sexp body))))
-  (let* ((temp (if (cl--simple-expr-p expr 3) expr (make-symbol "--cl-var--")))
-         (head-list nil)
-         (body (cons
-                'cond
-                (mapcar
-                 (function
-                  (lambda (c)
-                    (cons (cond ((memq (car c) '(t otherwise)) t)
-                                ((eq (car c) 'cl--ecase-error-flag)
-                                 `(error "cl-ecase failed: %s, %s"
-                                         ,temp ',(reverse head-list)))
-                                ((listp (car c))
-                                 (setq head-list (append (car c) head-list))
-                                 `(cl-member ,temp ',(car c)))
-                                (t
-                                 (if (memq (car c) head-list)
-                                     (error "Duplicate key in case: %s"
-                                            (car c)))
-                                 (push (car c) head-list)
-                                 `(eql ,temp ',(car c))))
-                          (or (cdr c) '(nil)))))
-                 clauses))))
-    (if (eq temp expr) body
-      `(let ((,temp ,expr)) ,body))))
+  (macroexp-let2 macroexp-copyable-p temp expr
+    (let* ((head-list nil))
+      `(cond
+        ,@(mapcar
+           (lambda (c)
+             (cons (cond ((memq (car c) '(t otherwise)) t)
+                         ((eq (car c) 'cl--ecase-error-flag)
+                          `(error "cl-ecase failed: %s, %s"
+                                  ,temp ',(reverse head-list)))
+                         ((listp (car c))
+                          (setq head-list (append (car c) head-list))
+                          `(cl-member ,temp ',(car c)))
+                         (t
+                          (if (memq (car c) head-list)
+                              (error "Duplicate key in case: %s"
+                                     (car c)))
+                          (push (car c) head-list)
+                          `(eql ,temp ',(car c))))
+                   (or (cdr c) '(nil))))
+           clauses)))))
 
 ;;;###autoload
 (defmacro cl-ecase (expr &rest clauses)
@@ -698,24 +699,22 @@ final clause, and matches if no other keys match.
 \n(fn EXPR (TYPE BODY...)...)"
   (declare (indent 1)
            (debug (form &rest ([&or cl-type-spec "otherwise"] body))))
-  (let* ((temp (if (cl--simple-expr-p expr 3) expr (make-symbol "--cl-var--")))
-         (type-list nil)
-         (body (cons
-                'cond
-                (mapcar
-                 (function
-                  (lambda (c)
-                    (cons (cond ((eq (car c) 'otherwise) t)
-                                ((eq (car c) 'cl--ecase-error-flag)
-                                 `(error "cl-etypecase failed: %s, %s"
-                                         ,temp ',(reverse type-list)))
-                                (t
-                                 (push (car c) type-list)
-                                 (cl--make-type-test temp (car c))))
-                          (or (cdr c) '(nil)))))
-                 clauses))))
-    (if (eq temp expr) body
-      `(let ((,temp ,expr)) ,body))))
+  (macroexp-let2 macroexp-copyable-p temp expr
+    (let* ((type-list nil))
+      (cons
+       'cond
+       (mapcar
+        (function
+         (lambda (c)
+           (cons (cond ((eq (car c) 'otherwise) t)
+                       ((eq (car c) 'cl--ecase-error-flag)
+                        `(error "cl-etypecase failed: %s, %s"
+                                ,temp ',(reverse type-list)))
+                       (t
+                        (push (car c) type-list)
+                        `(cl-typep ,temp ',(car c))))
+                 (or (cdr c) '(nil)))))
+        clauses)))))
 
 ;;;###autoload
 (defmacro cl-etypecase (expr &rest clauses)
@@ -1439,16 +1438,14 @@ For more details, see Info node `(cl)Loop Facility'.
         (push `(progn (if ,what (cl-incf ,var)) t) cl--loop-body)))
 
      ((memq word '(minimize minimizing maximize maximizing))
-      (let* ((what (pop cl--loop-args))
-             (temp (if (cl--simple-expr-p what) what
-                     (make-symbol "--cl-var--")))
-             (var (cl--loop-handle-accum nil))
-             (func (intern (substring (symbol-name word) 0 3)))
-             (set `(setq ,var (if ,var (,func ,var ,temp) ,temp))))
-        (push `(progn ,(if (eq temp what) set
-                         `(let ((,temp ,what)) ,set))
-                      t)
-              cl--loop-body)))
+      (push `(progn ,(macroexp-let2 macroexp-copyable-p temp
+                                    (pop cl--loop-args)
+                       (let* ((var (cl--loop-handle-accum nil))
+                              (func (intern (substring (symbol-name word)
+                                                       0 3))))
+                         `(setq ,var (if ,var (,func ,var ,temp) ,temp))))
+                    t)
+            cl--loop-body))
 
      ((eq word 'with)
       (let ((bindings nil))
@@ -2104,14 +2101,11 @@ values.  For compatibility, (cl-values A B C) is a synonym for (list A B C).
                (< cl--optimize-speed 3)
                (= cl--optimize-safety 3)))
       form
-    (let* ((temp (if (cl--simple-expr-p form 3)
-                     form (make-symbol "--cl-var--")))
-           (body `(progn (unless ,(cl--make-type-test temp type)
-                           (signal 'wrong-type-argument
-                                   (list ',type ,temp ',form)))
-                         ,temp)))
-      (if (eq temp form) body
-        `(let ((,temp ,form)) ,body)))))
+    (macroexp-let2 macroexp-copyable-p temp form
+      `(progn (unless (cl-typep ,temp ',type)
+                (signal 'wrong-type-argument
+                        (list ',type ,temp ',form)))
+              ,temp))))
 
 (defvar cl--proclaim-history t)    ; for future compilers
 (defvar cl--declare-stack t)       ; for future compilers
@@ -2425,15 +2419,11 @@ non-nil value, that slot cannot be set via `setf'.
          (tag (intern (format "cl-struct-%s" name)))
          (tag-symbol (intern (format "cl-struct-%s-tags" name)))
          (include-descs nil)
-         (side-eff nil)
          (type nil)
          (named nil)
          (forms nil)
+         (docstring (if (stringp (car descs)) (pop descs)))
          pred-form pred-check)
-    (if (stringp (car descs))
-        (push `(put ',name 'structure-documentation
-                    ,(pop descs))
-              forms))
     (setq descs (cons '(cl-tag-slot)
                       (mapcar (function (lambda (x) (if (consp x) x (list x))))
                               descs)))
@@ -2458,6 +2448,7 @@ non-nil value, that slot cannot be set via `setf'.
               ((eq opt :predicate)
                (if args (setq predicate (car args))))
               ((eq opt :include)
+               (when include (error "Can't :include more than once"))
                (setq include (car args)
                      include-descs (mapcar (function
                                             (lambda (x)
@@ -2511,20 +2502,19 @@ non-nil value, that slot cannot be set via `setf'.
             (if named (setq tag name)))
         (setq type 'vector named 'true)))
     (or named (setq descs (delq (assq 'cl-tag-slot descs) descs)))
-    (push `(defvar ,tag-symbol) forms)
     (when (and (null predicate) named)
       (setq predicate (intern (format "cl--struct-%s-p" name))))
     (setq pred-form (and named
                          (let ((pos (- (length descs)
                                        (length (memq (assq 'cl-tag-slot descs)
                                                      descs)))))
-                           (if (eq type 'vector)
-                               `(and (vectorp cl-x)
-                                     (>= (length cl-x) ,(length descs))
-                                     (memq (aref cl-x ,pos) ,tag-symbol))
-                             (if (= pos 0)
-                                 `(memq (car-safe cl-x) ,tag-symbol)
-                               `(and (consp cl-x)
+                           (cond
+                            ((eq type 'vector)
+                             `(and (vectorp cl-x)
+                                   (>= (length cl-x) ,(length descs))
+                                   (memq (aref cl-x ,pos) ,tag-symbol)))
+                            ((= pos 0) `(memq (car-safe cl-x) ,tag-symbol))
+                            (t `(and (consp cl-x)
                                      (memq (nth ,pos cl-x) ,tag-symbol))))))
           pred-check (and pred-form (> safety 0)
                           (if (and (eq (cl-caadr pred-form) 'vectorp)
@@ -2546,6 +2536,7 @@ non-nil value, that slot cannot be set via `setf'.
               (push slot slots)
               (push (nth 1 desc) defaults)
               (push `(cl-defsubst ,accessor (cl-x)
+                       (declare (side-effect-free t))
                        ,@(and pred-check
                               (list `(or ,pred-check
                                          (error "%s accessing a non-%s"
@@ -2554,7 +2545,6 @@ non-nil value, that slot cannot be set via `setf'.
                           (if (= pos 0) '(car cl-x)
                             `(nth ,pos cl-x))))
                     forms)
-              (push (cons accessor t) side-eff)
               (if (cadr (memq :read-only (cddr desc)))
                   (push `(gv-define-expander ,accessor
                            (lambda (_cl-do _cl-x)
@@ -2587,15 +2577,14 @@ non-nil value, that slot cannot be set via `setf'.
           defaults (nreverse defaults))
     (when pred-form
       (push `(cl-defsubst ,predicate (cl-x)
+               (declare (side-effect-free error-free))
                ,(if (eq (car pred-form) 'and)
                     (append pred-form '(t))
                   `(and ,pred-form t)))
             forms)
-      (push `(put ',name 'cl-deftype-satisfies ',predicate) forms)
-      (push (cons predicate 'error-free) side-eff))
+      (push `(put ',name 'cl-deftype-satisfies ',predicate) forms))
     (and copier
-         (progn (push `(defun ,copier (x) (copy-sequence x)) forms)
-                (push (cons copier t) side-eff)))
+         (push `(defalias ',copier #'copy-sequence) forms))
     (if constructor
         (push (list constructor
                        (cons '&key (delq nil (copy-sequence slots))))
@@ -2607,11 +2596,11 @@ non-nil value, that slot cannot be set via `setf'.
              (make (cl-mapcar (function (lambda (s d) (if (memq s anames) s d)))
                             slots defaults)))
         (push `(cl-defsubst ,name
-                 (&cl-defs '(nil ,@descs) ,@args)
+                   (&cl-defs '(nil ,@descs) ,@args)
+                 ,@(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs)))
+                       '((declare (side-effect-free t))))
                  (,type ,@make))
-              forms)
-        (if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs)))
-            (push (cons name t) side-eff))))
+              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
     ;; by anything anyway!
@@ -2624,17 +2613,14 @@ non-nil value, that slot cannot be set via `setf'.
     ;;                  (and ,pred-form ,print-func))
     ;;                cl-custom-print-functions))
     ;;          forms))
-    (push `(setq ,tag-symbol (list ',tag)) forms)
-    (push `(cl-eval-when (compile load eval)
-             (put ',name 'cl-struct-slots ',descs)
-             (put ',name 'cl-struct-type ',(list type (eq named t)))
-             (put ',name 'cl-struct-include ',include)
-             (put ',name 'cl-struct-print ,print-auto)
-             ,@(mapcar (lambda (x)
-                         `(function-put ',(car x) 'side-effect-free ',(cdr x)))
-                       side-eff))
-          forms)
-    `(progn ,@(nreverse (cons `',name forms)))))
+    `(progn
+       (defvar ,tag-symbol)
+       ,@(nreverse forms)
+       (eval-and-compile
+         (cl-struct-define ',name ,docstring ',include
+                           ',type ,(eq named t) ',descs ',tag-symbol ',tag
+                           ',print-auto))
+       ',name)))
 
 (defun cl-struct-sequence-type (struct-type)
   "Return the sequence used to build STRUCT-TYPE.
@@ -2741,14 +2727,11 @@ STRING is an optional description of the desired type."
   (declare (debug (place cl-type-spec &optional stringp)))
   (and (or (not (cl--compiling-file))
            (< cl--optimize-speed 3) (= cl--optimize-safety 3))
-       (let* ((temp (if (cl--simple-expr-p form 3)
-                        form (make-symbol "--cl-var--")))
-              (body `(or ,(cl--make-type-test temp type)
-                         (signal 'wrong-type-argument
-                                 (list ,(or string `',type)
-                                       ,temp ',form)))))
-         (if (eq temp form) `(progn ,body nil)
-           `(let ((,temp ,form)) ,body nil)))))
+       (macroexp-let2 macroexp-copyable-p temp form
+         `(progn (or (cl-typep ,temp ',type)
+                     (signal 'wrong-type-argument
+                             (list ,(or string `',type) ,temp ',form)))
+                 nil))))
 
 ;;;###autoload
 (defmacro cl-assert (form &optional show-args string &rest args)
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
new file mode 100644
index 00000000000..c9867b412a1
--- /dev/null
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -0,0 +1,48 @@
+;;; cl-preloaded.el --- Preloaded part of the CL library  -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2015  Free Software Foundation, Inc
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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.
+
+;; GNU Emacs 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 GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; The expectation is that structs defined with cl-defstruct do not
+;; need cl-lib at run-time, but we'd like to hide the details of the
+;; cl-struct metadata behind the cl-struct-define function, so we put
+;; it in this pre-loaded file.
+
+;;; Code:
+
+(defun cl-struct-define (name docstring parent type named slots children-sym
+                              tag print-auto)
+  (if (boundp children-sym)
+      (add-to-list children-sym tag)
+    (set children-sym (list tag)))
+  ;; If the cl-generic support, we need to be able to check
+  ;; if a vector is a cl-struct object, without knowing its particular type.
+  ;; So we use the (otherwise) unused function slots of the tag symbol
+  ;; to put a special witness value, to make the check easy and reliable.
+  (unless named (fset tag :quick-object-witness-check))
+  (put name 'cl-struct-slots slots)
+  (put name 'cl-struct-type (list type named))
+  (if parent (put name 'cl-struct-include parent))
+  (if print-auto (put name 'cl-struct-print print-auto))
+  (if docstring (put name 'structure-documentation docstring)))
+
+(provide 'cl-preloaded)
+;;; cl-preloaded.el ends here
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
index 7492f0522ab..d8d39020d0f 100644
--- a/lisp/emacs-lisp/eieio-core.el
+++ b/lisp/emacs-lisp/eieio-core.el
@@ -224,9 +224,9 @@ Return nil if that option doesn't exist."
 (defsubst eieio-object-p (obj)
   "Return non-nil if OBJ is an EIEIO object."
   (and (vectorp obj)
-       (condition-case nil
-           (eq (aref (eieio--object-class-object obj) 0) 'defclass)
-         (error nil))))
+       (> (length obj) 0)
+       (eq (symbol-function (eieio--class-tag obj))
+           :quick-object-witness-check)))
 
 (defalias 'object-p 'eieio-object-p)
 
@@ -539,6 +539,7 @@ See `defclass' for more information."
           ;; objects readable.
           (tag (intern (format "eieio-class-tag--%s" cname))))
       (set tag newc)
+      (fset tag :quick-object-witness-check)
       (setf (eieio--object-class-tag cache) tag)
       (let ((eieio-skip-typecheck t))
         ;; All type-checking has been done to our satisfaction
@@ -1223,9 +1224,10 @@ method invocation orders of the involved classes."
   ;;    specializer in a defmethod form.
   ;; So we can ignore types that are not known to denote classes.
   (and (class-p type)
-       ;; Prefer (aref ,name 0) over (eieio--class-tag ,name) so that
-       ;; the tagcode is identical to the tagcode used for cl-struct.
-       `(50 . (and (vectorp ,name) (aref ,name 0)))))
+       ;; Use the exact same code as for cl-struct, so that methods
+       ;; that dispatch on both kinds of objects get to share this
+       ;; part of the dispatch code.
+       `(50 . ,(cl--generic-struct-tag name))))
 
 (add-function :before-until cl-generic-tag-types-function
               #'eieio--generic-tag-types)
diff --git a/lisp/loadup.el b/lisp/loadup.el
index 96641c8a268..003b0db4abd 100644
--- a/lisp/loadup.el
+++ b/lisp/loadup.el
@@ -145,7 +145,8 @@
   (file-error (load "ldefs-boot.el")))
 
 (load "emacs-lisp/nadvice")
-(load "minibuffer")
+(load "emacs-lisp/cl-preloaded")
+(load "minibuffer")            ;After loaddefs, for define-minor-mode.
 (load "abbrev")         ;lisp-mode.el and simple.el use define-abbrev-table.
 (load "simple")
 
diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index a0c9eba4144..59c277b01c2 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -1628,6 +1628,8 @@ The preference is a float determined from `shr-prefer-media-type'."
   (let ((trs nil)
         (shr-inhibit-decoration (not fill))
         (rowspans (make-vector (length widths) 0))
+        (colspan-remaining 0)
+        colspan-width colspan-count
         width colspan)
     (dolist (row (dom-non-text-children dom))
       (when (eq (dom-tag row) 'tr)
@@ -1659,24 +1661,39 @@ The preference is a float determined from `shr-prefer-media-type'."
                     (if column
                         (aref widths width-column)
                       10))
-              (when (and fill
-                         (setq colspan (dom-attr column 'colspan)))
+              (when (setq colspan (dom-attr column 'colspan))
                 (setq colspan (min (string-to-number colspan)
                                    ;; The colspan may be wrong, so
                                    ;; truncate it to the length of the
                                    ;; remaining columns.
                                    (- (length widths) i)))
                 (dotimes (j (1- colspan))
-                  (if (> (+ i 1 j) (1- (length widths)))
-                      (setq width (aref widths (1- (length widths))))
-                    (setq width (+ width
-                                   shr-table-separator-length
-                                   (aref widths (+ i 1 j))))))
-                (setq width-column (+ width-column (1- colspan))))
+                  (setq width
+                        (if (> (+ i 1 j) (1- (length widths)))
+                            ;; If we have a colspan spec that's longer
+                            ;; than the table is wide, just use the last
+                            ;; width as the width.
+                            (aref widths (1- (length widths)))
+                          ;; Sum up the widths of the columns we're
+                          ;; spanning.
+                          (+ width
+                             shr-table-separator-length
+                             (aref widths (+ i 1 j))))))
+                (setq width-column (+ width-column (1- colspan))
+                      colspan-count colspan
+                      colspan-remaining colspan))
               (when (or column
                         (not fill))
-                (push (shr-render-td column width fill)
-                      tds))
+                (let ((data (shr-render-td column width fill)))
+                  (if (and (not fill)
+                           (> colspan-remaining 0))
+                      (progn
+                        (when (= colspan-count colspan-remaining)
+                          (setq colspan-width data))
+                        (let ((this-width (/ colspan-width colspan-count)))
+                          (push this-width tds)
+                          (setq colspan-remaining (1- colspan-remaining))))
+                    (push data tds))))
               (setq i (1+ i)
                     width-column (1+ width-column))))
           (push (nreverse tds) trs))))
diff --git a/src/ChangeLog b/src/ChangeLog
index 8efc90727e1..1df4f6ae0ba 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -57,6 +57,10 @@
         * emacs.c (syms_of_emacs) <system-configuration>: Doc fix.
         (Bug#19502)
 
+2015-01-28  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+        * lisp.mk (lisp): Add cl-preloaded.
+
 2015-01-27  Paul Eggert  <eggert@cs.ucla.edu>
 
         Use bool for boolean in xfaces.c
diff --git a/src/lisp.mk b/src/lisp.mk
index a9deb2b53d9..ee2a07c0fd7 100644
--- a/src/lisp.mk
+++ b/src/lisp.mk
@@ -71,6 +71,7 @@ lisp = \
         $(lispsource)/faces.elc \
         $(lispsource)/button.elc \
         $(lispsource)/startup.elc \
+        $(lispsource)/emacs-lisp/cl-preloaded.elc \
         $(lispsource)/emacs-lisp/nadvice.elc \
         $(lispsource)/minibuffer.elc \
         $(lispsource)/abbrev.elc \