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

[Erik Huelsmann]

Author: ehuelsmann
Date: Sat May 16 15:03:21 2009
New Revision: 11885

Log:
p2-compiland cleanup.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sat May 16 15:03:21 2009
@@ -1762,7 +1762,7 @@
   name-index
   descriptor-index)
 
-(defstruct (java-method (:conc-name method-) (:constructor make-method))
+(defstruct (java-method (:conc-name method-) (:constructor %make-method))
   access-flags
   name
   descriptor
@@ -1773,6 +1773,14 @@
   code
   handlers)
 
+(defun make-method (&rest args &key descriptor name
+                                    descriptor-index name-index
+                               &allow-other-keys)
+  (apply #'%make-method
+         (list* :descriptor-index (or descriptor-index (pool-name descriptor))
+                :name-index (or name-index (pool-name name))
+                args)))
+
 (defun emit-constructor-lambda-name (lambda-name)
   (cond ((and lambda-name (symbolp lambda-name) (symbol-package (truly-the symbol lambda-name)))
          (emit 'ldc (pool-string (symbol-name (truly-the symbol lambda-name))))
@@ -1800,8 +1808,6 @@
                                    :descriptor "()V"))
          (*code* ())
          (*handlers* nil))
-    (setf (method-name-index constructor) (pool-name (method-name constructor)))
-    (setf (method-descriptor-index constructor) (pool-name (method-descriptor constructor)))
     (setf (method-max-locals constructor) 1)
     (aload 0) ;; this
     (cond ((equal super +lisp-compiled-function-class+)
@@ -8008,7 +8014,6 @@
 
          (*thread* nil)
          (*initialize-thread-var* nil)
-         (super nil)
          (label-START (gensym)))
 
     (dolist (var (compiland-arg-vars compiland))
@@ -8016,11 +8021,6 @@
     (dolist (var (compiland-free-specials compiland))
       (push var *visible-variables*))
 
-    (setf (method-name-index execute-method)
-          (pool-name (method-name execute-method)))
-    (setf (method-descriptor-index execute-method)
-          (pool-name (method-descriptor execute-method)))
-
     (when *using-arg-array*
       (setf (compiland-argument-register compiland) (allocate-register)))
 
@@ -8040,8 +8040,8 @@
 
     (when *closure-variables*
       (setf (compiland-closure-register compiland) (allocate-register))
-       (dformat t "p2-compiland 2 closure register = ~S~%"
-                (compiland-closure-register compiland)))
+      (dformat t "p2-compiland 2 closure register = ~S~%"
+               (compiland-closure-register compiland)))
 
     (when *closure-variables*
       (if (not *child-p*)
@@ -8198,31 +8198,19 @@
 
     ;; Remove handler if its protected range is empty.
     (setf *handlers*
-          (delete-if (lambda (handler) (eql (symbol-value (handler-from handler))
-                                            (symbol-value (handler-to handler))))
+          (delete-if (lambda (handler)
+                       (eql (symbol-value (handler-from handler))
+                            (symbol-value (handler-to handler))))
                      *handlers*))
 
     (setf (method-max-locals execute-method) *registers-allocated*)
     (setf (method-handlers execute-method) (nreverse *handlers*))
 
     (setf (class-file-superclass class-file)
-          (cond (super
-                 super)
-                (*child-p*
-                 (if *closure-variables*
-                     (progn
-                       (setf (method-name-index execute-method)
-                             (pool-name (method-name execute-method)))
-                       (setf (method-descriptor-index execute-method)
-                             (pool-name (method-descriptor execute-method)))
-                       +lisp-compiled-closure-class+)
-                     (if *hairy-arglist-p*
-                         +lisp-compiled-function-class+
-                         +lisp-primitive-class+)))
-                (*hairy-arglist-p*
-                 +lisp-compiled-function-class+)
-                (t
-                 +lisp-primitive-class+)))
+          (cond
+            ((and *child-p* *closure-variables*) +lisp-compiled-closure-class+)
+            (*hairy-arglist-p* +lisp-compiled-function-class+)
+            (t +lisp-primitive-class+)))
 
     (setf (class-file-lambda-list class-file) args)