* lisp/vc/vc-mtn.el:

[bpt/emacs.git] / lisp / emacs-lisp / cl-macs.el

diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index fb19115..35cda8c 100644 (file)
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -1,6 +1,6 @@
 ;;; cl-macs.el --- Common Lisp macros
 
-;; Copyright (C) 1993, 2001-2011  Free Software Foundation, Inc.
+;; Copyright (C) 1993, 2001-2012  Free Software Foundation, Inc.
 
 ;; Author: Dave Gillespie <daveg@synaptics.com>
 ;; Version: 2.02
@@ -1483,18 +1483,24 @@ lexical closures as in Common Lisp.
           (cons 'progn body)
           (nconc (mapcar (function (lambda (x)
                                      (list (symbol-name (car x))
-                                           (list 'symbol-value (caddr x))
+                                            (list 'symbol-value (caddr x))
                                            t))) vars)
                  (list '(defun . cl-defun-expander))
                  cl-macro-environment))))
     (if (not (get (car (last cl-closure-vars)) 'used))
-       (list 'let (mapcar (function (lambda (x)
-                                      (list (caddr x) (cadr x)))) vars)
-             (sublis (mapcar (function (lambda (x)
-                                         (cons (caddr x)
-                                               (list 'quote (caddr x)))))
-                             vars)
-                     ebody))
+        ;; Turn (let ((foo (gensym))) (set foo <val>) ...(symbol-value foo)...)
+        ;; into (let ((foo <val>)) ...(symbol-value 'foo)...).
+        ;; This is good because it's more efficient but it only works with
+        ;; dynamic scoping, since with lexical scoping we'd need
+        ;; (let ((foo <val>)) ...foo...).
+       `(progn
+           ,@(mapcar (lambda (x) `(defvar ,(caddr x))) vars)
+           (let ,(mapcar (lambda (x) (list (caddr x) (cadr x))) vars)
+           ,(sublis (mapcar (lambda (x)
+                              (cons (caddr x)
+                                    (list 'quote (caddr x))))
+                            vars)
+                    ebody)))
       (list 'let (mapcar (function (lambda (x)
                                     (list (caddr x)
                                           (list 'make-symbol
@@ -2416,9 +2422,8 @@ value, that slot cannot be set via `setf'.
                        (append
                         (and pred-check
                              (list (list 'or pred-check
-                                         (list 'error
-                                               (format "%s accessing a non-%s"
-                                                       accessor name)))))
+                                         `(error "%s accessing a non-%s"
+                                                 ',accessor ',name))))
                         (list (if (eq type 'vector) (list 'aref 'cl-x pos)
                                 (if (= pos 0) '(car cl-x)
                                   (list 'nth pos 'cl-x)))))) forms)
@@ -2426,9 +2431,8 @@ value, that slot cannot be set via `setf'.
              (push (list 'define-setf-method accessor '(cl-x)
                             (if (cadr (memq :read-only (cddr desc)))
                                  (list 'progn '(ignore cl-x)
-                                       (list 'error
-                                             (format "%s is a read-only slot"
-                                                     'accessor)))
+                                       `(error "%s is a read-only slot"
+                                              ',accessor))
                               ;; If cl is loaded only for compilation,
                               ;; the call to cl-struct-setf-expander would
                               ;; cause a warning because it may not be