From 61b4c22c6eba96718327a0d208a8492d8bad76e0 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 14 Feb 2015 00:46:29 -0500 Subject: [PATCH] * 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. --- lisp/ChangeLog | 14 +++ lisp/emacs-lisp/cl-lib.el | 16 ---- lisp/emacs-lisp/cl-macs.el | 160 ++++++++++++++++---------------- lisp/emacs-lisp/cl-preloaded.el | 26 ++++++ 4 files changed, 121 insertions(+), 95 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 257b11bd51c..24cf80a4093 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,19 @@ 2015-02-14 Stefan Monnier + * 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. diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 0f534181b22..4b124951446 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -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! diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index eaec2c5263c..2861d669697 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -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) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index c9867b412a1..03045de509a 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -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 -- 2.39.2