bug-gnu-emacs
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

bug#12119: 24.1.50; symbol-macrolet regresssion


From: Stefan Monnier
Subject: bug#12119: 24.1.50; symbol-macrolet regresssion
Date: Mon, 06 Aug 2012 15:54:47 -0400
User-agent: Gnus/5.13 (Gnus v5.13) Emacs/24.1.50 (gnu/linux)

> Well, it depends on the definition of "correct".  The old version seems
> to do what the documentation says, i.e., let binding the variable is
> treated like letf.  What you call "correct" may be closer to what ANSI
> CL does, but such a change should be documented.

I've installed a patch which should re-produce the old letf behavior.


        Stefan


=== modified file 'lisp/ChangeLog'
--- lisp/ChangeLog      2012-08-06 07:31:31 +0000
+++ lisp/ChangeLog      2012-08-06 19:51:40 +0000
@@ -1,3 +1,8 @@
+2012-08-06  Stefan Monnier  <address@hidden>
+
+       * emacs-lisp/cl-macs.el (cl--sm-macroexpand): Fix handling of
+       re-binding a symbol that has a symbol-macro (bug#12119).
+
 2012-08-06  Mohsen BANAN  <address@hidden>
 
        * language/persian.el: New file.  (Bug#11812)

=== modified file 'lisp/emacs-lisp/cl-macs.el'
--- lisp/emacs-lisp/cl-macs.el  2012-07-26 01:27:33 +0000
+++ lisp/emacs-lisp/cl-macs.el  2012-08-06 19:49:54 +0000
@@ -1668,31 +1668,86 @@
       cl--old-macroexpand
     (symbol-function 'macroexpand)))
 
-(defun cl--sm-macroexpand (cl-macro &optional cl-env)
+(defun cl--sm-macroexpand (exp &optional env)
   "Special macro expander used inside `cl-symbol-macrolet'.
 This function replaces `macroexpand' during macro expansion
 of `cl-symbol-macrolet', and does the same thing as `macroexpand'
 except that it additionally expands symbol macros."
-  (let ((macroexpand-all-environment cl-env))
+  (let ((macroexpand-all-environment env))
     (while
         (progn
-          (setq cl-macro (funcall cl--old-macroexpand cl-macro cl-env))
-          (cond
-           ((symbolp cl-macro)
+          (setq exp (funcall cl--old-macroexpand exp env))
+          (pcase exp
+            ((pred symbolp)
             ;; Perform symbol-macro expansion.
-            (when (cdr (assq (symbol-name cl-macro) cl-env))
-              (setq cl-macro (cadr (assq (symbol-name cl-macro) cl-env)))))
-           ((eq 'setq (car-safe cl-macro))
+             (when (cdr (assq (symbol-name exp) env))
+               (setq exp (cadr (assq (symbol-name exp) env)))))
+            (`(setq . ,_)
             ;; Convert setq to setf if required by symbol-macro expansion.
-            (let* ((args (mapcar (lambda (f) (cl--sm-macroexpand f cl-env))
-                                 (cdr cl-macro)))
+             (let* ((args (mapcar (lambda (f) (cl--sm-macroexpand f env))
+                                  (cdr exp)))
                    (p args))
               (while (and p (symbolp (car p))) (setq p (cddr p)))
-              (if p (setq cl-macro (cons 'setf args))
-                (setq cl-macro (cons 'setq args))
+               (if p (setq exp (cons 'setf args))
+                 (setq exp (cons 'setq args))
                 ;; Don't loop further.
-                nil))))))
-    cl-macro))
+                 nil)))
+            (`(,(or `let `let*) . ,(or `(,bindings . ,body) dontcare))
+             ;; CL's symbol-macrolet treats re-bindings as candidates for
+             ;; expansion (turning the let into a letf if needed), contrary to
+             ;; Common-Lisp where such re-bindings hide the symbol-macro.
+             (let ((letf nil) (found nil) (nbs ()))
+               (dolist (binding bindings)
+                 (let* ((var (if (symbolp binding) binding (car binding)))
+                        (sm (assq (symbol-name var) env)))
+                   (push (if (not (cdr sm))
+                             binding
+                           (let ((nexp (cadr sm)))
+                             (setq found t)
+                             (unless (symbolp nexp) (setq letf t))
+                             (cons nexp (cdr-safe binding))))
+                         nbs)))
+               (when found
+                 (setq exp `(,(if letf
+                                  (if (eq (car exp) 'let) 'cl-letf 'cl-letf*)
+                                (car exp))
+                             ,(nreverse nbs)
+                             ,@body)))))
+            ;; FIXME: The behavior of CL made sense in a dynamically scoped
+            ;; language, but for lexical scoping, Common-Lisp's behavior might
+            ;; make more sense (and indeed, CL behaves like Common-Lisp w.r.t
+            ;; lexical-let), so maybe we should adjust the behavior based on
+            ;; the use of lexical-binding.
+            ;; (`(,(or `let `let*) . ,(or `(,bindings . ,body) dontcare))
+            ;;  (let ((nbs ()) (found nil))
+            ;;    (dolist (binding bindings)
+            ;;      (let* ((var (if (symbolp binding) binding (car binding)))
+            ;;             (name (symbol-name var))
+            ;;             (val (and found (consp binding) (eq 'let* (car exp))
+            ;;                       (list (macroexpand-all (cadr binding)
+            ;;                                              env)))))
+            ;;        (push (if (assq name env)
+            ;;                  ;; This binding should hide its symbol-macro,
+            ;;                  ;; but given the way macroexpand-all works, we
+            ;;                  ;; can't prevent application of `env' to the
+            ;;                  ;; sub-expressions, so we need to α-rename this
+            ;;                  ;; variable instead.
+            ;;                  (let ((nvar (make-symbol
+            ;;                               (copy-sequence name))))
+            ;;                    (setq found t)
+            ;;                    (push (list name nvar) env)
+            ;;                    (cons nvar (or val (cdr-safe binding))))
+            ;;                (if val (cons var val) binding))
+            ;;              nbs)))
+            ;;    (when found
+            ;;      (setq exp `(,(car exp)
+            ;;                  ,(nreverse nbs)
+            ;;                  ,@(macroexp-unprogn
+            ;;                     (macroexpand-all (macroexp-progn body)
+            ;;                                      env)))))
+            ;;    nil))
+            )))
+    exp))
 
 ;;;###autoload
 (defmacro cl-symbol-macrolet (bindings &rest body)






reply via email to

[Prev in Thread] Current Thread [Next in Thread]