[armedbear-cvs] r11344 - trunk/j/src/org/armedbear/lisp

[Erik Huelsmann,,,]

Author: ehuelsmann
Date: Sat Oct 11 21:40:21 2008
New Revision: 11344

Log:
Fix PSETQ.7: PSETQ on a symbol-macrolet bound symbol should behave like psetf.

Modified:
   trunk/j/src/org/armedbear/lisp/macros.lisp

Modified: trunk/j/src/org/armedbear/lisp/macros.lisp
==============================================================================
--- trunk/j/src/org/armedbear/lisp/macros.lisp	(original)
+++ trunk/j/src/org/armedbear/lisp/macros.lisp	Sat Oct 11 21:40:21 2008
@@ -109,14 +109,26 @@
                         ,setter)))
           (push (list (car d) (car v)) let-list)))))
 
-(defmacro psetq (&rest args)
+(defmacro psetq (&environment env &rest args)
   (do ((l args (cddr l))
        (forms nil)
        (bindings nil))
     ((endp l) (list* 'let* (reverse bindings) (reverse (cons nil forms))))
-    (let ((sym (gensym)))
-      (push (list sym (cadr l)) bindings)
-      (push (list 'setq (car l) sym) forms))))
+    (if (and (symbolp (car l))
+             (eq (car l) (macroexpand-1 (car l) env)))
+        (let ((sym (gensym)))
+          (push (list sym (cadr l)) bindings)
+          (push (list 'setq (car l) sym) forms))
+        (multiple-value-bind
+              (dummies vals newval setter getter)
+            (get-setf-expansion (macroexpand-1 (car l) env) env)
+          (declare (ignore getter))
+          (do ((d dummies (cdr d))
+               (v vals (cdr v)))
+              ((null d))
+            (push (list (car d) (car v)) bindings))
+          (push (list (car newval) (cadr l)) bindings)
+          (push setter forms)))))
 
 (defmacro time (form)
   `(%time #'(lambda () ,form)))