From 2668ac1aaecfe62c80a4fbdfc27a38e384594d26 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 27 Jan 2015 22:41:31 -0500 Subject: [PATCH] Tighten up the tagcode used for eieio and cl-struct objects * lisp/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. * lisp/emacs-lisp/cl-preloaded.el: New file. * lisp/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. * lisp/emacs-lisp/cl-generic.el (cl--generic-struct-tag): New function. (cl--generic-struct-tagcode): Use it to tighten the tagcode. * lisp/loadup.el: Load cl-preloaded. * src/lisp.mk (lisp): Add cl-preloaded. --- lisp/ChangeLog | 18 +++ lisp/emacs-lisp/cl-generic.el | 27 +++- lisp/emacs-lisp/cl-macs.el | 215 +++++++++++++++----------------- lisp/emacs-lisp/cl-preloaded.el | 48 +++++++ lisp/emacs-lisp/eieio-core.el | 14 ++- lisp/loadup.el | 3 +- src/ChangeLog | 4 + src/lisp.mk | 1 + 8 files changed, 201 insertions(+), 129 deletions(-) create mode 100644 lisp/emacs-lisp/cl-preloaded.el diff --git a/lisp/ChangeLog b/lisp/ChangeLog index b95424543f8..0e22c76abe0 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,21 @@ +2015-01-28 Stefan Monnier + + 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 * emacs-lisp/cl.el (cl--function-convert): 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 + +;; 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 . + +;;; 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/src/ChangeLog b/src/ChangeLog index 8e5166e22be..e8e216e0e92 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,7 @@ +2015-01-28 Stefan Monnier + + * lisp.mk (lisp): Add cl-preloaded. + 2015-01-27 Paul Eggert 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 \ -- 2.39.2