Changeset 12904

Timestamp:

08/29/10 17:30:04 (13 years ago)

Author:

ehuelsmann

Message:

Resolve the WRITE-CLASS-FILE double-use.

Location:

branches/generic-class-file/abcl/src/org/armedbear/lisp

Files:

• compiler-pass2.lisp (modified) (4 diffs)
• jvm-class-file.lisp (modified) (8 diffs)

branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

@@ -516 +516 @@
     (emit-invokestatic +lisp+ "type_error"
                        (lisp-object-arg-types 2) +lisp-object+)
-    (emit 'pop) ; Needed for JVM stack consistency.
+    (emit 'areturn) ; Needed for JVM stack consistency.
     (label LABEL1))
   t)
@@ -911 +911 @@
 
 
-(defun write-class-file (class stream)
+(defun finish-class (class stream)
+  "Finalizes the `class' and writes the result to `stream'.
+
+The compiler calls this function to indicate it doesn't want to
+extend the class any further."
   (class-add-method class (make-constructor (class-file-superclass class)
                                             (abcl-class-file-lambda-name class)
                                             (abcl-class-file-lambda-list class)))
   (finalize-class-file class)
-  (!write-class-file class stream))
+  (write-class-file class stream))
 
 
@@ -3791 +3795 @@
     (p2-compiland compiland)
 ;;        (finalize-class-file (compiland-class-file compiland))
-  (write-class-file (compiland-class-file compiland) stream)))))
+  (finish-class (compiland-class-file compiland) stream)))))
 
 (defun set-compiland-and-write-class (class-file compiland stream)
@@ -7086 +7090 @@
         (*current-compiland* compiland))
     (with-saved-compiler-policy
-      ;; Pass 1.
-      (p1-compiland compiland)
-      ;; *all-variables* doesn't contain variables which
-      ;; are in an enclosing lexical environment (variable-environment)
-      ;; so we don't need to filter them out
-      (setf *closure-variables*
-            (remove-if #'variable-special-p
-                       (remove-if-not #'variable-used-non-locally-p
-                                                 *all-variables*)))
-      (let ((i 0))
-        (dolist (var (reverse *closure-variables*))
-          (setf (variable-closure-index var) i)
-          (dformat t "var = ~S closure index = ~S~%" (variable-name var)
-                   (variable-closure-index var))
-          (incf i)))
+        ;; Pass 1.
+        (p1-compiland compiland))
+
+    ;; *all-variables* doesn't contain variables which
+    ;; are in an enclosing lexical environment (variable-environment)
+    ;; so we don't need to filter them out
+    (setf *closure-variables*
+          (remove-if #'variable-special-p
+                     (remove-if-not #'variable-used-non-locally-p
+                                    *all-variables*)))
+    (let ((i 0))
+      (dolist (var (reverse *closure-variables*))
+        (setf (variable-closure-index var) i)
+        (dformat t "var = ~S closure index = ~S~%" (variable-name var)
+                 (variable-closure-index var))
+        (incf i)))
 
       ;; Assert that we're not refering to any variables
       ;; we're not allowed to use
-      (assert (= 0
-                 (length (remove-if (complement #'variable-references)
-                                    (remove-if #'variable-references-allowed-p
-                                               *visible-variables*)))))
+
+    (assert (= 0
+               (length (remove-if (complement #'variable-references)
+                                  (remove-if #'variable-references-allowed-p
+                                             *visible-variables*)))))
 
       ;; Pass 2.
-      (with-class-file (compiland-class-file compiland)
+
+    (with-class-file (compiland-class-file compiland)
+      (with-saved-compiler-policy
         (p2-compiland compiland)
-;;        (finalize-class-file (compiland-class-file compiland))
-        (write-class-file (compiland-class-file compiland) stream)))))
+        ;;        (finalize-class-file (compiland-class-file compiland))
+        (finish-class (compiland-class-file compiland) stream)))))
 
 (defvar *compiler-error-bailout*)

branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp

@@ -533 +533 @@
 (defun class-methods-by-name (class name)
   "Returns all methods which have `name'."
-  (remove name (class-file-methods class)
+  (remove (map-method-name name) (class-file-methods class)
           :test-not #'string= :key #'method-name))
 
 (defun class-method (class name return &rest args)
   "Return the method which is (uniquely) identified by its name AND descriptor."
-  (let ((return-and-args (cons return args)))
+  (let ((return-and-args (cons return args))
+        (name (map-method-name name)))
     (find-if #'(lambda (c)
                  (and (string= (method-name c) name)
@@ -662 +663 @@
 
 
-(defun !write-class-file (class stream)
+(defun write-class-file (class stream)
   "Serializes `class' to `stream', after it has been finalized."
 
@@ -846 +847 @@
 be one of two keyword identifiers to identify special methods:
 
- * :class-constructor
+ * :static-initializer
  * :constructor
 "
   (cond
-    ((eq name :class-constructor)
+    ((eq name :static-initializer)
      "<clinit>")
     ((eq name :constructor)
@@ -860 +861 @@
   (%make-method :descriptor (cons return args)
                 :access-flags flags
-                :name name))
+                :name (map-method-name name)))
 
 (defun method-add-attribute (method attribute)
@@ -899 +900 @@
           (pool-add-utf8 pool (apply #'descriptor (method-descriptor method)))
           (method-name method)
-          (pool-add-utf8 pool (map-method-name (method-name method)))))
+          (pool-add-utf8 pool (method-name method))))
   (finalize-attributes (method-attributes method) nil class))
 
@@ -993 +994 @@
                             (mapcar #'exception-handler-pc handlers))
                      t)))
-    (setf (code-max-stack code)
-          (analyze-stack c (mapcar #'exception-handler-pc handlers)))
+    (unless (code-max-stack code)
+      (setf (code-max-stack code)
+            (analyze-stack c (mapcar #'exception-handler-pc handlers))))
+    (unless (code-max-locals code)
+      (setf (code-max-locals code)
+            (analyze-locals code)))
     (multiple-value-bind
           (c labels)
@@ -1144 +1149 @@
         *register* (code-current-local code)))
 
-(defmacro with-code-to-method ((class-file method &key (safe-nesting t))
-             &body body)
+(defmacro with-code-to-method ((class-file method)
+                               &body body)
   (let ((m (gensym))
         (c (gensym)))
     `(progn
-       ,@(when safe-nesting
-           `((when *current-code-attribute*
-               (save-code-specials *current-code-attribute*))))
+       (when *current-code-attribute*
+         (save-code-specials *current-code-attribute*))
        (let* ((,m ,method)
               (,c (method-ensure-code ,method))
@@ -1161 +1165 @@
          ,@body
          (setf (code-code ,c) *code*
-         (code-current-local ,c) *register*
-;;               (code-exception-handlers ,c) *handlers*
+               (code-current-local ,c) *register*
                (code-max-locals ,c) *registers-allocated*))
-       ,@(when safe-nesting
-           `((when *current-code-attribute*
-               (restore-code-specials *current-code-attribute*)))))))
+       (when *current-code-attribute*
+         (restore-code-specials *current-code-attribute*)))))