Changeset 11885

Timestamp:

05/16/09 19:03:21 (14 years ago)

Author:

ehuelsmann

Message:

p2-compiland cleanup.

File:

• trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (modified) (8 diffs)

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

@@ -1763 +1763 @@
   descriptor-index)
 
-(defstruct (java-method (:conc-name method-) (:constructor make-method))
+(defstruct (java-method (:conc-name method-) (:constructor %make-method))
   access-flags
   name
@@ -1774 +1774 @@
   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)))
@@ -1801 +1809 @@
          (*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
@@ -8009 +8015 @@
          (*thread* nil)
          (*initialize-thread-var* nil)
-         (super nil)
          (label-START (gensym)))
 
@@ -8016 +8021 @@
     (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*
@@ -8041 +8041 @@
     (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*
@@ -8199 +8199 @@
     ;; 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*))
 
@@ -8207 +8208 @@
 
     (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)