[Git][cmucl/cmucl][master] Check for function names correctly

[Raymond Toy]

Raymond Toy pushed to branch master at cmucl / cmucl


Commits:
89074ab3 by Raymond Toy at 2015-06-24T06:50:04Z
Check for function names correctly

Fix #7

The change to use extended names like (flet frob) broke the detection
of local names for get-setf-expansion.  Fix it.  This reverts behavior
back to what 18a used to do.

A test for this is also added.

- - - - -


2 changed files:

- src/code/macros.lisp
- tests/issues.lisp


Changes:

=====================================
src/code/macros.lisp
=====================================
--- a/src/code/macros.lisp
+++ b/src/code/macros.lisp
@@ -667,7 +667,7 @@
 	  ((and environment
 		(let ((name (car form)))
 		  (dolist (x (c::lexenv-functions environment) nil)
-		    (when (and (eq (car x) name)
+		    (when (and (eq (nth-value 1 (valid-function-name-p (car x))) name)
 			       (not (c::defined-function-p (cdr x))))
 		      (return t)))))
 	   (expand-or-get-setf-inverse form environment))


=====================================
tests/issues.lisp
=====================================
--- a/tests/issues.lisp
+++ b/tests/issues.lisp
@@ -73,4 +73,23 @@
   (assert-prints "SQUARE compiler macro present: No.
 
 8"
-		 (test/present)))
\ No newline at end of file
+		 (test/present)))
+
+(defmacro xpop (place &environment env)
+  (multiple-value-bind (dummies vals new setter getter)
+      (get-setf-expansion place env)
+    `(let* (,@(mapcar #'list dummies vals) (,(car new) ,getter))
+      (if ,(cdr new) (error "Can't expand this."))
+      (prog1 (car ,(car new))
+    (setq ,(car new) (cdr ,(car new)))
+    ,setter))))
+
+(defsetf frob (x) (value) 
+     `(setf (car ,x) ,value))
+
+(define-test issue.7
+    (:tag :issues)
+  (assert-error 'error
+		(let ((z (list 1 2)))
+		  (flet ((frob (x) (cdr x)))
+		    (xpop (frob z))))))



View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/89074ab386b5ce7d2283261949b120e9a6713dfd
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20150624/dfa3ae69/attachment.html>