[armedbear-cvs] r13586 - trunk/abcl/src/org/armedbear/lisp

[ehuelsmann at common-lisp.net]

Author: ehuelsmann
Date: Thu Sep  8 11:37:23 2011
New Revision: 13586

Log:
Reduce complexity of STD-COMPUTE-METHOD-COMBINATION: move lambda creation
to METHOD-COMBINATION-TYPE-LAMBDA.

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

Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp	Thu Sep  8 07:49:11 2011	(r13585)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp	Thu Sep  8 11:37:23 2011	(r13586)
@@ -1108,16 +1108,24 @@
   (&key name lambda-list args-lambda-list generic-function-symbol
         method-group-specs declarations forms &allow-other-keys)
   (declare (ignore name))
-  (let ((methods (gensym)))
+  (let ((methods (gensym))
+        (args-var (gensym)))
     `(lambda (,generic-function-symbol ,methods , at lambda-list)
        , at declarations
        (with-method-groups ,method-group-specs
            ,methods
-         ,@(if (null args-lambda-list)
-               forms
-               `((with-args-lambda-list ,args-lambda-list
-                     ,generic-function-symbol
-                   , at forms)))))))
+         ,(if (null args-lambda-list)
+              `(lambda (,args-var)
+                 (let ((gf-args-var ,args-var))
+                   ,(wrap-with-call-method-macro generic-function-symbol
+                                                 args-var forms)))
+              `(lambda (,args-var)
+                 (let ((gf-args-var ,args-var))
+                   ,(wrap-with-call-method-macro generic-function-symbol
+                                                 args-var
+                       `(with-args-lambda-list ,args-lambda-list
+                            ,generic-function-symbol
+                          , at forms)))))))))
 
 (defun declarationp (expr)
   (and (consp expr) (eq (car expr) 'DECLARE)))
@@ -2082,14 +2090,9 @@
          (assert (typep mc-obj 'long-method-combination))
          (assert function)
          (setf emf-form
-               (let ((result (if arguments
-                                 (apply function gf methods arguments)
-                                 (funcall function gf methods)))
-                     (args-var (gensym)))
-                 `(lambda (,args-var)
-                    (let ((gf-args-var ,args-var))
-                      ,(wrap-with-call-method-macro gf args-var
-                                                    (list result))))))))
+               (if arguments
+                   (apply function gf methods arguments)
+                   (funcall function gf methods)))))
       (t
        (let ((mc-obj (get mc-name 'method-combination-object)))
          (unless (typep mc-obj 'short-method-combination)