[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] master 2668ac1: Tighten up the tagcode used for eieio and
|
From: |
Stefan Monnier |
|
Subject: |
[Emacs-diffs] master 2668ac1: Tighten up the tagcode used for eieio and cl-struct objects |
|
Date: |
Wed, 28 Jan 2015 03:41:39 +0000 |
branch: master
commit 2668ac1aaecfe62c80a4fbdfc27a38e384594d26
Author: Stefan Monnier <address@hidden>
Commit: Stefan Monnier <address@hidden>
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(-)
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index b954245..0e22c76 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,21 @@
+2015-01-28 Stefan Monnier <address@hidden>
+
+ 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 <address@hidden>
* emacs-lisp/cl.el (cl--function-convert):
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 1bb7096..3e34ab6 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 38f15b8..eaec2c5 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 0000000..c9867b4
--- /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 <address@hidden>
+
+;; 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 7492f05..d8d3902 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 96641c8..003b0db 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 8e5166e..e8e216e 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,7 @@
+2015-01-28 Stefan Monnier <address@hidden>
+
+ * lisp.mk (lisp): Add cl-preloaded.
+
2015-01-27 Paul Eggert <address@hidden>
Use bool for boolean in xfaces.c
diff --git a/src/lisp.mk b/src/lisp.mk
index a9deb2b..ee2a07c 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 \
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] master 2668ac1: Tighten up the tagcode used for eieio and cl-struct objects,
Stefan Monnier <=