[Emacs-diffs] master 61b4c22: * lisp/emacs-lisp/cl*.el: Use define-inline and move some code

[Stefan Monnier]

branch: master
commit 61b4c22c6eba96718327a0d208a8492d8bad76e0
Author: Stefan Monnier <address@hidden>
Commit: Stefan Monnier <address@hidden>

    * 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 257b11b..24cf80a 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,5 +1,19 @@
 2015-02-14  Stefan Monnier  <address@hidden>
 
+       * 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 0f53418..4b12495 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 eaec2c5..2861d66 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 c9867b4..03045de 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