[armedbear-cvs] r13939 - in trunk/abcl: src/org/armedbear/lisp test/lisp/abcl

[mevenson at common-lisp.net]

Author: mevenson
Date: Tue May 22 06:39:13 2012
New Revision: 13939

Log:
Fixes ticket #199: CL-METHOD failure for &AUX arguments.

DEFGENERIC specified with &AUX arguments now signals an error.

Removed badly conceived BUGS.AUX.1 test which blew up the stack due to
recursively referencing itself in the &AUX init form.

Modified:
   trunk/abcl/src/org/armedbear/lisp/clos.lisp
   trunk/abcl/test/lisp/abcl/bugs.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp	Thu May 17 08:22:21 2012	(r13938)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp	Tue May 22 06:39:13 2012	(r13939)
@@ -1403,6 +1403,12 @@
          (push item options))))
     (setf options (nreverse options)
           methods (nreverse methods))
+    ;;; Since DEFGENERIC currently shares its argument parsing with
+    ;;; DEFMETHOD, we perform this check here.
+    (when (find '&aux lambda-list)
+      (error 'program-error
+             :format-control "&AUX is not allowed in a generic function lambda list: ~S"
+             :format-arguments (list lambda-list)))
     `(prog1
        (%defgeneric
         ',function-name
@@ -1981,8 +1987,13 @@
             (lambda-list (%generic-function-lambda-list gf))
             (exact (null (intersection lambda-list
                                        '(&rest &optional &key
-                                         &allow-other-keys &aux)))))
-       (if exact
+                                         &allow-other-keys))))
+            (no-aux (null (some 
+                           (lambda (method) 
+                             (find '&aux (std-slot-value method 'sys::lambda-list)))
+                           (sys:%generic-function-methods gf)))))
+       (if (and exact
+                no-aux)
            (cond
              ((= number-required 1)
               (cond

Modified: trunk/abcl/test/lisp/abcl/bugs.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/bugs.lisp	Thu May 17 08:22:21 2012	(r13938)
+++ trunk/abcl/test/lisp/abcl/bugs.lisp	Tue May 22 06:39:13 2012	(r13939)
@@ -115,19 +115,7 @@
 
 
 ;;; http://trac.common-lisp.net/armedbear/ticket/199
-(deftest bugs.clos.aux.1 
-    ;;; XXX possible collision with previously defined names
-    (progn
-      (defclass room ()
-        ((decorators :reader room-decorators)))
-      (defgeneric decorators (room))
-      (defmethod decorators ((room room) 
-                             &aux (d (decorators room)))
-        d)
-      (decorators (make-instance 'room)))
-  t)
-
-(deftest bugs.aux.1
+(deftest bugs.clos.aux.1
     ((lambda (a &aux (b (+ a 1))) 
        b)
      2)