[armedbear-cvs] r12904 - branches/generic-class-file/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Sun Aug 29 17:30:06 UTC 2010
Author: ehuelsmann
Date: Sun Aug 29 13:30:04 2010
New Revision: 12904
Log:
Resolve the WRITE-CLASS-FILE double-use.
Modified:
branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Aug 29 13:30:04 2010
@@ -515,7 +515,7 @@
+lisp-symbol+)
(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)
@@ -910,12 +910,16 @@
(defvar *source-line-number* nil)
-(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))
(defknown declare-field (t t t) t)
@@ -3790,7 +3794,7 @@
(with-saved-compiler-policy
(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)
(setf (compiland-class-file compiland) class-file)
@@ -7085,34 +7089,38 @@
(*local-functions* *local-functions*)
(*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*)
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Sun Aug 29 13:30:04 2010
@@ -532,12 +532,13 @@
(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)
(equal (method-descriptor c) return-and-args)))
@@ -661,7 +662,7 @@
(write-ascii string length stream))))
-(defun !write-class-file (class stream)
+(defun write-class-file (class stream)
"Serializes `class' to `stream', after it has been finalized."
;; header
@@ -845,11 +846,11 @@
"Methods should be identified by strings containing their names, or,
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)
"<init>")
@@ -859,7 +860,7 @@
"Creates a method for addition to a class file."
(%make-method :descriptor (cons return args)
:access-flags flags
- :name name))
+ :name (map-method-name name)))
(defun method-add-attribute (method attribute)
"Add `attribute' to the list of attributes of `method',
@@ -898,7 +899,7 @@
(method-descriptor method)
(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))
@@ -992,8 +993,12 @@
(mapcar #'exception-end-pc handlers)
(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)
(code-bytes c)
@@ -1143,14 +1148,13 @@
*registers-allocated* (code-max-locals code)
*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))
(*pool* (class-file-constants ,class-file))
@@ -1160,12 +1164,10 @@
(*current-code-attribute* ,c))
, at 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*)))))
(defstruct (source-file-attribute (:conc-name source-)
More information about the armedbear-cvs
mailing list