Commit 61b4c22c authored by Stefan Monnier's avatar Stefan Monnier
Browse files

* lisp/emacs-lisp/cl*.el: Use define-inline and move some code

* lisp/emacs-lisp/cl-lib.el: Move autoloaded code to cl-preload.

* lisp/emacs-lisp/cl-preloaded.el (cl-struct-define): Register as children
of the parent.
(cl--assertion-failed): New function.
(cl-assertion-failed): Move in from cl-lib.el.

* lisp/emacs-lisp/cl-macs.el (cl-defstruct): Don't generate code to register
as children of its parents.
(cl--make-type-test, cl--compiler-macro-typep): Remove functions.
(cl-typep): Reimplement using define-inline.
(cl-assert): Use cl--assertion-failed.
(cl-struct-slot-value): Use define-inline.
parent 0d54f2f5
2015-02-14 Stefan Monnier <monnier@iro.umontreal.ca>
 
* emacs-lisp/cl-preloaded.el (cl-struct-define): Register as children
of the parent.
(cl--assertion-failed): New function.
(cl-assertion-failed): Move in from cl-lib.el.
* emacs-lisp/cl-macs.el (cl-defstruct): Don't generate code to register
as children of its parents.
(cl--make-type-test, cl--compiler-macro-typep): Remove functions.
(cl-typep): Reimplement using define-inline.
(cl-assert): Use cl--assertion-failed.
(cl-struct-slot-value): Use define-inline.
* emacs-lisp/cl-lib.el: Move autoloaded code to cl-preload.
* textmodes/flyspell.el (flyspell-word): Defvar (bug#19844).
(flyspell-generic-check-word-p): Mark as obsolete.
 
......
......@@ -731,22 +731,6 @@ If ALIST is non-nil, the new pairs are prepended to it."
;;; Miscellaneous.
;;;###autoload
(progn
;; The `assert' macro from the cl package signals
;; `cl-assertion-failed' at runtime so always define it.
(define-error 'cl-assertion-failed (purecopy "Assertion failed"))
;; Make sure functions defined with cl-defsubst can be inlined even in
;; packages which do not require CL. We don't put an autoload cookie
;; directly on that function, since those cookies only go to cl-loaddefs.
(autoload 'cl--defsubst-expand "cl-macs")
;; Autoload, so autoload.el and font-lock can use it even when CL
;; is not loaded.
(put 'cl-defun 'doc-string-elt 3)
(put 'cl-defmacro 'doc-string-elt 3)
(put 'cl-defsubst 'doc-string-elt 3)
(put 'cl-defstruct 'doc-string-elt 2))
(provide 'cl-lib)
(or (load "cl-loaddefs" 'noerror 'quiet)
;; When bootstrapping, cl-loaddefs hasn't been built yet!
......
......@@ -2488,13 +2488,7 @@ non-nil value, that slot cannot be set via `setf'.
(setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs))
type (car inc-type)
named (assq 'cl-tag-slot descs))
(if (cadr inc-type) (setq tag name named t))
(let ((incl include))
(while incl
(push `(cl-pushnew ',tag
,(intern (format "cl-struct-%s-tags" incl)))
forms)
(setq incl (get incl 'cl-struct-include)))))
(if (cadr inc-type) (setq tag name named t)))
(if type
(progn
(or (memq type '(vector list))
......@@ -2661,64 +2655,70 @@ Of course, we really can't know that for sure, so it's just a heuristic."
(or (cdr (assq sym byte-compile-function-environment))
(cdr (assq sym byte-compile-macro-environment))))))
(defun cl--make-type-test (val type)
(pcase type
((and `(,name . ,args) (guard (get name 'cl-deftype-handler)))
(cl--make-type-test val (apply (get name 'cl-deftype-handler)
args)))
(`(,(and name (or 'integer 'float 'real 'number))
. ,(or `(,min ,max) pcase--dontcare))
`(and ,(cl--make-type-test val name)
,(if (memq min '(* nil)) t
(if (consp min) `(> ,val ,(car min))
`(>= ,val ,min)))
,(if (memq max '(* nil)) t
(if (consp max)
`(< ,val ,(car max))
`(<= ,val ,max)))))
(`(,(and name (or 'and 'or 'not)) . ,args)
(cons name (mapcar (lambda (x) (cl--make-type-test val x)) args)))
(`(member . ,args)
`(and (cl-member ,val ',args) t))
(`(satisfies ,pred) `(funcall #',pred ,val))
((and (pred symbolp) (guard (get type 'cl-deftype-handler)))
(cl--make-type-test val (funcall (get type 'cl-deftype-handler))))
((and (pred symbolp) (guard (get type 'cl-deftype-satisfies)))
`(funcall #',(get type 'cl-deftype-satisfies) ,val))
((or 'nil 't) type)
('null `(null ,val))
('atom `(atom ,val))
('float `(floatp ,val))
('real `(numberp ,val))
('fixnum `(integerp ,val))
;; FIXME: Implement `base-char' and `extended-char'.
('character `(characterp ,val))
((pred symbolp)
(let* ((name (symbol-name type))
(namep (intern (concat name "p"))))
(cond
((cl--macroexp-fboundp namep) (list namep val))
((cl--macroexp-fboundp
(setq namep (intern (concat name "-p"))))
(list namep val))
((cl--macroexp-fboundp type) (list type val))
(t (error "Unknown type %S" type)))))
(_ (error "Bad type spec: %s" type))))
(defvar cl--object)
(put 'null 'cl-deftype-satisfies #'null)
(put 'atom 'cl-deftype-satisfies #'atom)
(put 'real 'cl-deftype-satisfies #'numberp)
(put 'fixnum 'cl-deftype-satisfies #'integerp)
(put 'base-char 'cl-deftype-satisfies #'characterp)
(put 'character 'cl-deftype-satisfies #'integerp)
;;;###autoload
(defun cl-typep (object type) ; See compiler macro below.
"Check that OBJECT is of type TYPE.
TYPE is a Common Lisp-style type specifier."
(declare (compiler-macro cl--compiler-macro-typep))
(let ((cl--object object)) ;; Yuck!!
(eval (cl--make-type-test 'cl--object type))))
(defun cl--compiler-macro-typep (form val type)
(if (macroexp-const-p type)
(macroexp-let2 macroexp-copyable-p temp val
(cl--make-type-test temp (cl--const-expr-val type)))
form))
(define-inline cl-typep (val type)
(inline-letevals (val)
(pcase (inline-const-val type)
((and `(,name . ,args) (guard (get name 'cl-deftype-handler)))
(inline-quote
(cl-typep ,val ',(apply (get name 'cl-deftype-handler) args))))
(`(,(and name (or 'integer 'float 'real 'number))
. ,(or `(,min ,max) pcase--dontcare))
(inline-quote
(and (cl-typep ,val ',name)
,(if (memq min '(* nil)) t
(if (consp min)
(inline-quote (> ,val ',(car min)))
(inline-quote (>= ,val ',min))))
,(if (memq max '(* nil)) t
(if (consp max)
(inline-quote (< ,val ',(car max)))
(inline-quote (<= ,val ',max)))))))
(`(not ,type) (inline-quote (not (cl-typep ,val ',type))))
(`(,(and name (or 'and 'or)) . ,types)
(cond
((null types) (inline-quote ',(eq name 'and)))
((null (cdr types))
(inline-quote (cl-typep ,val ',(car types))))
(t
(let ((head (car types))
(rest `(,name . ,(cdr types))))
(cond
((eq name 'and)
(inline-quote (and (cl-typep ,val ',head)
(cl-typep ,val ',rest))))
(t
(inline-quote (or (cl-typep ,val ',head)
(cl-typep ,val ',rest)))))))))
(`(member . ,args)
(inline-quote (and (memql ,val ',args) t)))
(`(satisfies ,pred) (inline-quote (funcall #',pred ,val)))
((and (pred symbolp) type (guard (get type 'cl-deftype-handler)))
(inline-quote
(cl-typep ,val ',(funcall (get type 'cl-deftype-handler)))))
((and (pred symbolp) type (guard (get type 'cl-deftype-satisfies)))
(inline-quote (funcall #',(get type 'cl-deftype-satisfies) ,val)))
((and (or 'nil 't) type) (inline-quote ',type))
((and (pred symbolp) type)
(let* ((name (symbol-name type))
(namep (intern (concat name "p"))))
(cond
((cl--macroexp-fboundp namep) (inline-quote (funcall #',namep ,val)))
((cl--macroexp-fboundp
(setq namep (intern (concat name "-p"))))
(inline-quote (funcall #',namep ,val)))
((cl--macroexp-fboundp type) (inline-quote (funcall #',type ,val)))
(t (error "Unknown type %S" type)))))
(type (error "Bad type spec: %s" type)))))
;;;###autoload
(defmacro cl-check-type (form type &optional string)
......@@ -2751,10 +2751,9 @@ omitted, a default message listing FORM itself is used."
(cdr form))))))
`(progn
(or ,form
,(if string
`(error ,string ,@sargs ,@args)
`(signal 'cl-assertion-failed
(list ',form ,@sargs))))
(cl--assertion-failed
',form ,@(if (or string sargs args)
`(,string (list ,@sargs) (list ,@args)))))
nil))))
;;; Compiler macros.
......@@ -2962,23 +2961,26 @@ The type name can then be used in `cl-typecase', `cl-check-type', etc."
(put ',name 'cl-deftype-handler
(cl-function (lambda (&cl-defs '('*) ,@arglist) ,@body)))))
(cl-deftype extended-char () `(and character (not base-char)))
;;; Additional functions that we can now define because we've defined
;;; `cl-defsubst' and `cl-typep'.
(cl-defsubst cl-struct-slot-value (struct-type slot-name inst)
;; The use of `cl-defsubst' here gives us both a compiler-macro
;; and a gv-expander "for free".
(define-inline cl-struct-slot-value (struct-type slot-name inst)
"Return the value of slot SLOT-NAME in INST of STRUCT-TYPE.
STRUCT and SLOT-NAME are symbols. INST is a structure instance."
(declare (side-effect-free t))
(unless (cl-typep inst struct-type)
(signal 'wrong-type-argument (list struct-type inst)))
;; We could use `elt', but since the byte compiler will resolve the
;; branch below at compile time, it's more efficient to use the
;; type-specific accessor.
(if (eq (cl-struct-sequence-type struct-type) 'vector)
(aref inst (cl-struct-slot-offset struct-type slot-name))
(nth (cl-struct-slot-offset struct-type slot-name) inst)))
(inline-letevals (struct-type slot-name inst)
(inline-quote
(progn
(unless (cl-typep ,inst ,struct-type)
(signal 'wrong-type-argument (list ,struct-type ,inst)))
;; We could use `elt', but since the byte compiler will resolve the
;; branch below at compile time, it's more efficient to use the
;; type-specific accessor.
(if (eq (cl-struct-sequence-type ,struct-type) 'vector)
(aref ,inst (cl-struct-slot-offset ,struct-type ,slot-name))
(nth (cl-struct-slot-offset ,struct-type ,slot-name) ,inst))))))
(run-hooks 'cl-macs-load-hook)
......
......@@ -33,6 +33,10 @@
(if (boundp children-sym)
(add-to-list children-sym tag)
(set children-sym (list tag)))
(let* ((parent-class parent))
(while parent-class
(add-to-list (intern (format "cl-struct-%s-tags" parent-class)) tag)
(setq parent-class (get parent-class 'cl-struct-include))))
;; 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
......@@ -44,5 +48,27 @@
(if print-auto (put name 'cl-struct-print print-auto))
(if docstring (put name 'structure-documentation docstring)))
;; The `assert' macro from the cl package signals
;; `cl-assertion-failed' at runtime so always define it.
(define-error 'cl-assertion-failed (purecopy "Assertion failed"))
(defun cl--assertion-failed (form &optional string sargs args)
(if debug-on-error
(debug `(cl-assertion-failed ,form ,string ,@sargs))
(if string
(apply #'error string (append sargs args))
(signal 'cl-assertion-failed `(,form ,@sargs)))))
;; Make sure functions defined with cl-defsubst can be inlined even in
;; packages which do not require CL. We don't put an autoload cookie
;; directly on that function, since those cookies only go to cl-loaddefs.
(autoload 'cl--defsubst-expand "cl-macs")
;; Autoload, so autoload.el and font-lock can use it even when CL
;; is not loaded.
(put 'cl-defun 'doc-string-elt 3)
(put 'cl-defmacro 'doc-string-elt 3)
(put 'cl-defsubst 'doc-string-elt 3)
(put 'cl-defstruct 'doc-string-elt 2)
(provide 'cl-preloaded)
;;; cl-preloaded.el ends here
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment