mirror of
git://git.sv.gnu.org/emacs.git
synced 2025-12-09 07:40:39 -08:00
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.
This commit is contained in:
Stefan Monnier
parent
7f4f16b3ae
commit
2668ac1aae
8 changed files with 201 additions and 129 deletions
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
48
lisp/emacs-lisp/cl-preloaded.el
Normal file
48
lisp/emacs-lisp/cl-preloaded.el
Normal file
|
|
@ -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
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue