Re: trunk r117969: Font-lock `cl-flet*', too.

[Leo Liu]

On 2014-09-28 21:30 -0400, Stefan Monnier wrote:
> Notice the `setq's?  These make a big difference in lexical-binding code
> (since they mean that we can't close over the var's value but have to
> close over the var's memory location, which gets reified as a cons
> cell).

I see them but didn't know they were inefficient. Would something along
these lines be acceptable? Thanks, Leo

=== modified file 'lisp/emacs-lisp/cl-macs.el'
--- lisp/emacs-lisp/cl-macs.el  2014-07-21 01:41:59 +0000
+++ lisp/emacs-lisp/cl-macs.el  2014-09-29 06:37:43 +0000
@@ -1811,6 +1811,20 @@
           (setq cl--labels-convert-cache (cons f res))
           res))))))
 
+(defun cl--labels-depend-p (body &optional deps)
+  "Return non-nil if BODY refers to any function in DEPS. "
+  (catch 'exit
+    (let ((newenv (cons (cons 'function
+                             (lambda (f)
+                               (and (memq f deps) (throw 'exit t))
+                               f))
+                       (append (mapcar (lambda (dep)
+                                         (cons dep (lambda (&rest _) (throw 
'exit t))))
+                                       deps)
+                               macroexpand-all-environment))))
+      (macroexpand-all (macroexp-progn body) newenv))
+    nil))
+
 ;;;###autoload
 (defmacro cl-flet (bindings &rest body)
   "Make local function definitions.
@@ -1855,19 +1869,28 @@
 
 \(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
   (declare (indent 1) (debug cl-flet))
-  (let ((binds ()) (newenv macroexpand-all-environment))
+  (let ((binds ())
+       (setqs ())
+       (newenv macroexpand-all-environment)
+       (deps (mapcar #'car bindings)))
     (dolist (binding bindings)
       (let ((var (make-symbol (format "--cl-%s--" (car binding)))))
-       (push (list var `(cl-function (lambda . ,(cdr binding)))) binds)
+       (if (cl--labels-depend-p (cddr binding) deps)
+           (progn
+             (push var binds)
+             (push `(setq ,var (cl-function (lambda . ,(cdr binding)))) setqs))
+         (push (list var `(cl-function (lambda . ,(cdr binding)))) binds))
        (push (cons (car binding)
-                    `(lambda (&rest cl-labels-args)
-                       (cl-list* 'funcall ',var
-                                 cl-labels-args)))
-              newenv)))
-    (macroexpand-all `(letrec ,(nreverse binds) ,@body)
-                     ;; Don't override lexical-let's macro-expander.
-                     (if (assq 'function newenv) newenv
-                       (cons (cons 'function #'cl--labels-convert) newenv)))))
+                   `(lambda (&rest cl-labels-args)
+                      (cl-list* 'funcall ',var cl-labels-args)))
+             newenv))
+      (pop deps))
+    (macroexpand-all `(let* ,(nreverse binds)
+                       ,@(nreverse setqs)
+                       ,@body)
+                    ;; Don't override lexical-let's macro-expander.
+                    (if (assq 'function newenv) newenv
+                      (cons (cons 'function #'cl--labels-convert) newenv)))))
 
 ;; The following ought to have a better definition for use with newer
 ;; byte compilers.