[armedbear-cvs] r12895 - branches/generic-class-file/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Fri Aug 13 21:10:40 UTC 2010
Author: ehuelsmann
Date: Fri Aug 13 17:10:39 2010
New Revision: 12895
Log:
Remove exclamation marks which were in place to avoid naming
conflicts; the conflicting names have been deleted from pass2 now.
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
branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.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 Fri Aug 13 17:10:39 2010
@@ -796,7 +796,7 @@
(defun make-constructor (super lambda-name args)
(let* ((*compiler-debug* nil)
;; We don't normally need to see debugging output for constructors.
- (method (!make-method :constructor :void nil
+ (method (make-method :constructor :void nil
:flags '(:public)))
(code (method-add-code method))
req-params-register
@@ -3808,7 +3808,7 @@
(defmacro with-temp-class-file (pathname class-file lambda-list &body body)
`(let* ((,pathname (make-temp-file))
- (,class-file (make-class-file :pathname ,pathname
+ (,class-file (make-abcl-class-file :pathname ,pathname
:lambda-list ,lambda-list)))
(unwind-protect
(progn , at body)
@@ -3820,13 +3820,13 @@
(lambda-list (cadr (compiland-lambda-expression compiland))))
(cond (*file-compilation*
(let* ((pathname (funcall *pathnames-generator*))
- (class-file (make-class-file :pathname pathname
+ (class-file (make-abcl-class-file :pathname pathname
:lambda-list lambda-list)))
(with-open-class-file (f class-file)
(set-compiland-and-write-class class-file compiland f))
(setf (local-function-class-file local-function) class-file)))
(t
- (let ((class-file (make-class-file :lambda-list lambda-list)))
+ (let ((class-file (make-abcl-class-file :lambda-list lambda-list)))
(with-open-stream (stream (sys::%make-byte-array-output-stream))
(set-compiland-and-write-class class-file compiland stream)
(setf (local-function-class-file local-function) class-file)
@@ -3854,8 +3854,8 @@
(lambda-list (cadr (compiland-lambda-expression compiland))))
(cond (*file-compilation*
(let* ((pathname (funcall *pathnames-generator*))
- (class-file (make-class-file :pathname pathname
- :lambda-list lambda-list)))
+ (class-file (make-abcl-class-file :pathname pathname
+ :lambda-list lambda-list)))
(with-open-class-file (f class-file)
(set-compiland-and-write-class class-file compiland f))
(setf (local-function-class-file local-function) class-file)
@@ -3863,7 +3863,7 @@
(emit-make-compiled-closure-for-labels
local-function compiland g))))
(t
- (let ((class-file (make-class-file :lambda-list lambda-list)))
+ (let ((class-file (make-abcl-class-file :lambda-list lambda-list)))
(with-open-stream (stream (sys::%make-byte-array-output-stream))
(set-compiland-and-write-class class-file compiland stream)
(setf (local-function-class-file local-function) class-file)
@@ -3916,8 +3916,8 @@
(aver (null (compiland-class-file compiland)))
(cond (*file-compilation*
(setf (compiland-class-file compiland)
- (make-class-file :pathname (funcall *pathnames-generator*)
- :lambda-list lambda-list))
+ (make-abcl-class-file :pathname (funcall *pathnames-generator*)
+ :lambda-list lambda-list))
(let ((class-file (compiland-class-file compiland)))
(with-open-class-file (f class-file)
(compile-and-write-to-stream class-file compiland f))
@@ -3927,7 +3927,7 @@
+lisp-object+)))
(t
(setf (compiland-class-file compiland)
- (make-class-file :lambda-list lambda-list))
+ (make-abcl-class-file :lambda-list lambda-list))
(with-open-stream (stream (sys::%make-byte-array-output-stream))
(compile-and-write-to-stream (compiland-class-file compiland)
compiland stream)
@@ -6850,7 +6850,7 @@
(write-u2 (length (abcl-class-file-methods class-file)) stream)
;; methods
(dolist (method (abcl-class-file-methods class-file))
- (!write-method method stream))
+ (write-method method stream))
;; attributes count
(cond (*file-compilation*
;; attributes count
@@ -6925,7 +6925,7 @@
(*child-p* (not (null (compiland-parent compiland))))
(arg-types (analyze-args compiland))
- (method (!make-method "execute" +lisp-object+ arg-types
+ (method (make-method "execute" +lisp-object+ arg-types
:flags '(:final :public)))
(code (method-add-code method))
(*current-code-attribute* code)
@@ -7111,7 +7111,9 @@
+lisp-object-array+)))
(astore (compiland-argument-register compiland)))
- (maybe-initialize-thread-var)
+ (unless (and *hairy-arglist-p*
+ (or (memq '&OPTIONAL args) (memq '&KEY args)))
+ (maybe-initialize-thread-var))
(setf *code* (nconc code *code*)))
(setf (abcl-class-file-superclass class-file)
@@ -7180,25 +7182,26 @@
to derive a Java class name from."
(aver (eq (car form) 'LAMBDA))
(catch 'compile-defun-abort
- (let* ((class-file (make-class-file :pathname filespec
- :lambda-name name
- :lambda-list (cadr form)))
+ (let* ((class-file (make-abcl-class-file :pathname filespec
+ :lambda-name name
+ :lambda-list (cadr form)))
(*compiler-error-bailout*
`(lambda ()
- (compile-1 (make-compiland :name ',name
- :lambda-expression (make-compiler-error-form ',form)
- :class-file
- (make-class-file :pathname ,filespec
- :lambda-name ',name
- :lambda-list (cadr ',form)))
- ,stream)))
+ (compile-1
+ (make-compiland :name ',name
+ :lambda-expression (make-compiler-error-form ',form)
+ :class-file
+ (make-abcl-class-file :pathname ,filespec
+ :lambda-name ',name
+ :lambda-list (cadr ',form)))
+ ,stream)))
(*compile-file-environment* environment))
- (compile-1 (make-compiland :name name
- :lambda-expression
- (precompiler:precompile-form form t
- environment)
- :class-file class-file)
- stream))))
+ (compile-1 (make-compiland :name name
+ :lambda-expression
+ (precompiler:precompile-form form t
+ environment)
+ :class-file class-file)
+ stream))))
(defvar *catch-errors* t)
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 Fri Aug 13 17:10:39 2010
@@ -503,7 +503,7 @@
(constant-index entry)))
(defstruct (class-file (:constructor
- !make-class-file (class superclass access-flags)))
+ make-class-file (class superclass access-flags)))
"Holds the components of a class file."
(constants (make-pool))
access-flags
@@ -533,14 +533,14 @@
(defun class-methods-by-name (class name)
"Returns all methods which have `name'."
(remove name (class-file-methods class)
- :test-not #'string= :key #'!method-name))
+ :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)))
(find-if #'(lambda (c)
- (and (string= (!method-name c) name)
- (equal (!method-descriptor c) return-and-args)))
+ (and (string= (method-name c) name)
+ (equal (method-descriptor c) return-and-args)))
(class-file-methods class))))
(defun class-add-attribute (class attribute)
@@ -673,9 +673,10 @@
(write-constants (class-file-constants class) stream)
;; flags
(write-u2 (class-file-access-flags class) stream)
- ;; class name
+ ;; class name
(write-u2 (class-file-class class) stream)
+
;; superclass
(write-u2 (class-file-superclass class) stream)
@@ -690,7 +691,7 @@
;; methods
(write-u2 (length (class-file-methods class)) stream)
(dolist (method (class-file-methods class))
- (!write-method method stream))
+ (write-method method stream))
;; attributes
(write-attributes (class-file-attributes class) stream))
@@ -831,8 +832,8 @@
(write-attributes (field-attributes field) stream))
-(defstruct (method (:constructor %!make-method)
- (:conc-name !method-))
+(defstruct (method (:constructor %make-method)
+ (:conc-name method-))
"Holds information on the properties of methods in the class(-file)."
access-flags
name
@@ -854,16 +855,16 @@
"<init>")
(t name)))
-(defun !make-method (name return args &key (flags '(:public)))
+(defun make-method (name return args &key (flags '(:public)))
"Creates a method for addition to a class file."
- (%!make-method :descriptor (cons return args)
+ (%make-method :descriptor (cons return args)
:access-flags flags
:name name))
(defun method-add-attribute (method attribute)
"Add `attribute' to the list of attributes of `method',
returning `attribute'."
- (push attribute (!method-attributes method))
+ (push attribute (method-attributes method))
attribute)
(defun method-add-code (method)
@@ -871,8 +872,8 @@
returning the created attribute."
(method-add-attribute
method
- (make-code-attribute (+ (length (cdr (!method-descriptor method)))
- (if (member :static (!method-access-flags method))
+ (make-code-attribute (+ (length (cdr (method-descriptor method)))
+ (if (member :static (method-access-flags method))
0 1))))) ;; 1 == implicit 'this'
(defun method-ensure-code (method)
@@ -885,29 +886,29 @@
(defun method-attribute (method name)
"Returns the first attribute of `method' with `name'."
- (find name (!method-attributes method)
+ (find name (method-attributes method)
:test #'string= :key #'attribute-name))
(defun finalize-method (method class)
"Prepares `method' for serialization."
(let ((pool (class-file-constants class)))
- (setf (!method-access-flags method)
- (map-flags (!method-access-flags method))
- (!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)))))
- (finalize-attributes (!method-attributes method) nil class))
+ (setf (method-access-flags method)
+ (map-flags (method-access-flags method))
+ (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)))))
+ (finalize-attributes (method-attributes method) nil class))
-(defun !write-method (method stream)
+(defun write-method (method stream)
"Write class file representation of `method' to `stream'."
- (write-u2 (!method-access-flags method) stream)
- (write-u2 (!method-name method) stream)
- ;;(sys::%format t "method-name: ~a~%" (!method-name method))
- (write-u2 (!method-descriptor method) stream)
- (write-attributes (!method-attributes method) stream))
+ (write-u2 (method-access-flags method) stream)
+ (write-u2 (method-name method) stream)
+ ;;(sys::%format t "method-name: ~a~%" (method-name method))
+ (write-u2 (method-descriptor method) stream)
+ (write-attributes (method-attributes method) stream))
(defstruct attribute
"Parent attribute structure to be included into other attributes, mainly
@@ -950,8 +951,8 @@
(defstruct (code-attribute (:conc-name code-)
(:include attribute
(name "Code")
- (finalizer #'!finalize-code)
- (writer #'!write-code))
+ (finalizer #'finalize-code-attribute)
+ (writer #'write-code-attribute))
(:constructor %make-code-attribute))
"The attribute containing the actual JVM byte code;
an attribute of a method."
@@ -981,7 +982,7 @@
(setf (code-labels code)
(acons label offset (code-labels code))))
-(defun !finalize-code (code parent class)
+(defun finalize-code-attribute (code parent class)
"Prepares the `code' attribute for serialization, within method `parent'."
(declare (ignore parent))
(let* ((handlers (code-exception-handlers code))
@@ -999,6 +1000,12 @@
(setf (code-code code) c
(code-labels code) labels)))
+ (setf (code-exception-handlers code)
+ (remove-if #'(lambda (h)
+ (eql (code-label-offset code (exception-start-pc h))
+ (code-label-offset code (exception-end-pc h))))
+ (code-exception-handlers code)))
+
(dolist (exception (code-exception-handlers code))
(setf (exception-start-pc exception)
(code-label-offset code (exception-start-pc exception))
@@ -1014,7 +1021,7 @@
(finalize-attributes (code-attributes code) code class))
-(defun !write-code (code stream)
+(defun write-code-attribute (code stream)
"Writes the attribute `code' to `stream'."
;;(sys::%format t "max-stack: ~a~%" (code-max-stack code))
(write-u2 (code-max-stack code) stream)
@@ -1085,7 +1092,7 @@
"An attribute of a field of primitive type.
"
-
+ ;;; ### TODO
)
@@ -1129,12 +1136,10 @@
(defun save-code-specials (code)
(setf (code-code code) *code*
(code-max-locals code) *registers-allocated*
-;; (code-exception-handlers code) *handlers*
(code-current-local code) *register*))
(defun restore-code-specials (code)
(setf *code* (code-code code)
-;; *handlers* (code-exception-handlers code)
*registers-allocated* (code-max-locals code)
*register* (code-current-local code)))
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp Fri Aug 13 17:10:39 2010
@@ -150,7 +150,7 @@
(java:jstatic "randomUUID"
"java.util.UUID"))))))
-(defun make-class-file (&key pathname lambda-name lambda-list)
+(defun make-abcl-class-file (&key pathname lambda-name lambda-list)
"Creates a `class-file' structure. If `pathname' is non-NIL, it's
used to derive a class name. If it is NIL, a random one created
using `make-unique-class-name'."
More information about the armedbear-cvs
mailing list