[armedbear-cvs] r12832 - in branches/generic-class-file/abcl: src/org/armedbear/lisp test/lisp/abcl
Erik Huelsmann
ehuelsmann at common-lisp.net
Thu Jul 29 18:27:12 UTC 2010
Author: ehuelsmann
Date: Thu Jul 29 14:27:10 2010
New Revision: 12832
Log:
Lots of fixes from writing tests. Most notable the correction of
my perception that the exceptions table was stored as an attribute
of the "Code" attribute. It's not: it's part of said attribute.
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/test/lisp/abcl/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 Thu Jul 29 14:27:10 2010
@@ -1304,11 +1304,10 @@
;; Current path ends.
(return-from walk-code))))))
-(declaim (ftype (function () t) analyze-stack))
-(defun analyze-stack ()
+(declaim (ftype (function (t) t) analyze-stack))
+(defun analyze-stack (code)
(declare (optimize speed))
- (let* ((code *code*)
- (code-length (length code)))
+ (let* ((code-length (length code)))
(declare (type vector code))
(dotimes (i code-length)
(declare (type (unsigned-byte 16) i))
@@ -1572,7 +1571,9 @@
t)
(defun code-bytes (code)
- (let ((length 0))
+ (let ((length 0)
+ labels ;; alist
+ )
(declare (type (unsigned-byte 16) length))
;; Pass 1: calculate label offsets and overall length.
(dotimes (i (length code))
@@ -1581,7 +1582,9 @@
(opcode (instruction-opcode instruction)))
(if (= opcode 202) ; LABEL
(let ((label (car (instruction-args instruction))))
- (set label length))
+ (set label length)
+ (setf labels
+ (acons label length labels)))
(incf length (opcode-size opcode)))))
;; Pass 2: replace labels with calculated offsets.
(let ((index 0))
@@ -1608,7 +1611,7 @@
(dolist (byte (instruction-args instruction))
(setf (svref bytes index) byte)
(incf index)))))
- bytes)))
+ (values bytes labels))))
(declaim (inline write-u1))
(defun write-u1 (n stream)
@@ -1878,7 +1881,7 @@
(emit 'return)
(finalize-code)
(setf *code* (resolve-instructions *code*))
- (setf (method-max-stack constructor) (analyze-stack))
+ (setf (method-max-stack constructor) (analyze-stack *code*))
(setf (method-code constructor) (code-bytes *code*))
(setf (method-handlers constructor) (nreverse *handlers*))
constructor))
@@ -8205,7 +8208,7 @@
(optimize-code)
(setf *code* (resolve-instructions *code*))
- (setf (method-max-stack execute-method) (analyze-stack))
+ (setf (method-max-stack execute-method) (analyze-stack *code*))
(setf (method-code execute-method) (code-bytes *code*))
;; Remove handler if its protected range is empty.
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 Thu Jul 29 14:27:10 2010
@@ -180,14 +180,14 @@
"Returns a string describing the `return-type' and `argument-types'
in JVM-internal representation."
(format nil "(~{~A~})~A" (mapcar #'internal-field-ref argument-types)
- (internal-field-type return-type)))
+ (internal-field-ref return-type)))
(defstruct pool
- ;; `count' contains a reference to the last-used slot (0 being empty)
+ ;; `index' contains the index of the last allocated slot (0 == empty)
;; "A constant pool entry is considered valid if it has
;; an index greater than 0 (zero) and less than pool-count"
- (count 0)
+ (index 0)
entries-list
;; the entries hash stores raw values, except in case of string and
;; utf8, because both are string values
@@ -284,7 +284,7 @@
(defstruct (constant-utf8 (:constructor make-constant-utf8 (index value))
(:include constant
- (tag 11)))
+ (tag 1)))
value)
@@ -294,11 +294,10 @@
`class' must be an instance of `class-name'."
(let ((entry (gethash class (pool-entries pool))))
(unless entry
- (setf entry
- (make-constant-class (incf (pool-count pool))
- (pool-add-utf8 pool
- (class-name-internal class)))
- (gethash class (pool-entries pool)) entry)
+ (let ((utf8 (pool-add-utf8 pool (class-name-internal class))))
+ (setf entry
+ (make-constant-class (incf (pool-index pool)) utf8)
+ (gethash class (pool-entries pool)) entry))
(push entry (pool-entries-list pool)))
(constant-index entry)))
@@ -311,10 +310,10 @@
`type' is a field-type (see `internal-field-type')"
(let ((entry (gethash (acons name type class) (pool-entries pool))))
(unless entry
- (setf entry (make-constant-field-ref (incf (pool-count pool))
- (pool-add-class pool class)
- (pool-add-name/type pool name type))
- (gethash (acons name type class) (pool-entries pool)) entry)
+ (let ((c (pool-add-class pool class))
+ (n/t (pool-add-name/type pool name type)))
+ (setf entry (make-constant-field-ref (incf (pool-index pool)) c n/t)
+ (gethash (acons name type class) (pool-entries pool)) entry))
(push entry (pool-entries-list pool)))
(constant-index entry)))
@@ -326,10 +325,10 @@
and return type. `class' is an instance of `class-name'."
(let ((entry (gethash (acons name type class) (pool-entries pool))))
(unless entry
- (setf entry (make-constant-method-ref (incf (pool-count pool))
- (pool-add-class pool class)
- (pool-add-name/type pool name type))
- (gethash (acons name type class) (pool-entries pool)) entry)
+ (let ((c (pool-add-class pool class))
+ (n/t (pool-add-name/type pool name type)))
+ (setf entry (make-constant-method-ref (incf (pool-index pool)) c n/t)
+ (gethash (acons name type class) (pool-entries pool)) entry))
(push entry (pool-entries-list pool)))
(constant-index entry)))
@@ -340,12 +339,11 @@
See `pool-add-method-ref' for remarks."
(let ((entry (gethash (acons name type class) (pool-entries pool))))
(unless entry
- (setf entry
- (make-constant-interface-method-ref (incf (pool-count pool))
- (pool-add-class pool class)
- (pool-add-name/type pool
- name type))
- (gethash (acons name type class) (pool-entries pool)) entry)
+ (let ((c (pool-add-class pool class))
+ (n/t (pool-add-name/type pool name type)))
+ (setf entry
+ (make-constant-interface-method-ref (incf (pool-index pool)) c n/t)
+ (gethash (acons name type class) (pool-entries pool)) entry))
(push entry (pool-entries-list pool)))
(constant-index entry)))
@@ -354,9 +352,9 @@
(let ((entry (gethash (cons 8 string) ;; 8 == string-tag
(pool-entries pool))))
(unless entry
- (setf entry (make-constant-string (incf (pool-count pool))
- (pool-add-utf8 pool string))
- (gethash (cons 8 string) (pool-entries pool)) entry)
+ (let ((utf8 (pool-add-utf8 pool string)))
+ (setf entry (make-constant-string (incf (pool-index pool)) utf8)
+ (gethash (cons 8 string) (pool-entries pool)) entry))
(push entry (pool-entries-list pool)))
(constant-index entry)))
@@ -364,7 +362,7 @@
"Returns the index of the constant-pool item denoting the int."
(let ((entry (gethash (cons 3 int) (pool-entries pool))))
(unless entry
- (setf entry (make-constant-int (incf (pool-count pool)) int)
+ (setf entry (make-constant-int (incf (pool-index pool)) int)
(gethash (cons 3 int) (pool-entries pool)) entry)
(push entry (pool-entries-list pool)))
(constant-index entry)))
@@ -373,7 +371,7 @@
"Returns the index of the constant-pool item denoting the float."
(let ((entry (gethash (cons 4 float) (pool-entries pool))))
(unless entry
- (setf entry (make-constant-float (incf (pool-count pool)) float)
+ (setf entry (make-constant-float (incf (pool-index pool)) float)
(gethash (cons 4 float) (pool-entries pool)) entry)
(push entry (pool-entries-list pool)))
(constant-index entry)))
@@ -382,20 +380,20 @@
"Returns the index of the constant-pool item denoting the long."
(let ((entry (gethash (cons 5 long) (pool-entries pool))))
(unless entry
- (setf entry (make-constant-long (incf (pool-count pool)) long)
+ (setf entry (make-constant-long (incf (pool-index pool)) long)
(gethash (cons 5 long) (pool-entries pool)) entry)
(push entry (pool-entries-list pool))
- (incf (pool-count pool))) ;; double index increase; long takes 2 slots
+ (incf (pool-index pool))) ;; double index increase; long takes 2 slots
(constant-index entry)))
(defun pool-add-double (pool double)
"Returns the index of the constant-pool item denoting the double."
(let ((entry (gethash (cons 6 double) (pool-entries pool))))
(unless entry
- (setf entry (make-constant-double (incf (pool-count pool)) double)
+ (setf entry (make-constant-double (incf (pool-index pool)) double)
(gethash (cons 6 double) (pool-entries pool)) entry)
(push entry (pool-entries-list pool))
- (incf (pool-count pool))) ;; double index increase; 'double' takes 2 slots
+ (incf (pool-index pool))) ;; double index increase; 'double' takes 2 slots
(constant-index entry)))
(defun pool-add-name/type (pool name type)
@@ -406,10 +404,10 @@
(apply #'descriptor type)
(internal-field-ref type))))
(unless entry
- (setf entry (make-constant-name/type (incf (pool-count pool))
- (pool-add-utf8 pool name)
- (pool-add-utf8 pool internal-type))
- (gethash (cons name type) (pool-entries pool)) entry)
+ (let ((n (pool-add-utf8 pool name))
+ (i-t (pool-add-utf8 pool internal-type)))
+ (setf entry (make-constant-name/type (incf (pool-index pool)) n i-t)
+ (gethash (cons name type) (pool-entries pool)) entry))
(push entry (pool-entries-list pool)))
(constant-index entry)))
@@ -419,7 +417,7 @@
(let ((entry (gethash (cons 11 utf8-as-string) ;; 11 == utf8
(pool-entries pool))))
(unless entry
- (setf entry (make-constant-utf8 (incf (pool-count pool)) utf8-as-string)
+ (setf entry (make-constant-utf8 (incf (pool-index pool)) utf8-as-string)
(gethash (cons 11 utf8-as-string) (pool-entries pool)) entry)
(push entry (pool-entries-list pool)))
(constant-index entry)))
@@ -478,13 +476,17 @@
"Transforms the representation of the class-file from one
which allows easy modification to one which works best for serialization.
-The class can't be modified after serialization."
+The class can't be modified after finalization."
+
;; constant pool contains constants finalized on addition;
;; no need for additional finalization
(setf (class-file-access-flags class)
(map-flags (class-file-access-flags class)))
- (setf (class-file-class class)
+ (setf (class-file-superclass class)
+ (pool-add-class (class-file-constants class)
+ (class-file-superclass class))
+ (class-file-class class)
(pool-add-class (class-file-constants class)
(class-file-class class)))
;; (finalize-interfaces)
@@ -508,6 +510,7 @@
;; flags
(write-u2 (class-file-access-flags class) stream)
;; class name
+
(write-u2 (class-file-class class) stream)
;; superclass
(write-u2 (class-file-superclass class) stream)
@@ -528,32 +531,65 @@
;; attributes
(write-attributes (class-file-attributes class) stream))
+
+(defvar *jvm-class-debug-pool* nil
+ "When bound to a non-NIL value, enables output to *standard-output*
+to allow debugging output of the constant section of the class file.")
+
(defun write-constants (constants stream)
- (write-u2 (pool-count constants) stream)
- (dolist (entry (reverse (pool-entries-list constants)))
- (let ((tag (constant-tag entry)))
- (write-u1 tag stream)
+ "Writes the constant section given in `constants' to the class file `stream'."
+ (let ((pool-index 0))
+ (write-u2 (1+ (pool-index constants)) stream)
+ (when *jvm-class-debug-pool*
+ (sys::%format t "pool count ~A~%" (pool-index constants)))
+ (dolist (entry (reverse (pool-entries-list constants)))
+ (incf pool-index)
+ (let ((tag (constant-tag entry)))
+ (when *jvm-class-debug-pool*
+ (print-constant entry t))
+ (write-u1 tag stream)
+ (case tag
+ (1 ; UTF8
+ (write-utf8 (constant-utf8-value entry) stream))
+ ((3 4) ; float int
+ (write-u4 (constant-float/int-value entry) stream))
+ ((5 6) ; long double
+ (write-u4 (logand (ash (constant-double/long-value entry) -32)
+ #xFFFFffff) stream)
+ (write-u4 (logand (constant-double/long-value entry) #xFFFFffff)
+ stream))
+ ((9 10 11) ; fieldref methodref InterfaceMethodref
+ (write-u2 (constant-member-ref-class-index entry) stream)
+ (write-u2 (constant-member-ref-name/type-index entry) stream))
+ (12 ; nameAndType
+ (write-u2 (constant-name/type-name-index entry) stream)
+ (write-u2 (constant-name/type-descriptor-index entry) stream))
+ (7 ; class
+ (write-u2 (constant-class-name-index entry) stream))
+ (8 ; string
+ (write-u2 (constant-string-value-index entry) stream))
+ (t
+ (error "write-constant-pool-entry unhandled tag ~D~%" tag)))))))
+
+
+(defun print-constant (entry stream)
+ "Debugging helper to print the content of a constant-pool entry."
+ (let ((tag (constant-tag entry))
+ (index (constant-index entry)))
+ (sys::%format stream "pool element ~a, tag ~a, " index tag)
(case tag
- (1 ; UTF8
- (write-utf8 (constant-utf8-value entry) stream))
- ((3 4) ; int
- (write-u4 (constant-float/int-value entry) stream))
- ((5 6) ; long double
- (write-u4 (logand (ash (constant-double/long-value entry) -32)
- #xFFFFffff) stream)
- (write-u4 (logand (constant-double/long-value entry) #xFFFFffff) stream))
- ((9 10 11) ; fieldref methodref InterfaceMethodref
- (write-u2 (constant-member-ref-class-index entry) stream)
- (write-u2 (constant-member-ref-name/type-index entry) stream))
- (12 ; nameAndType
- (write-u2 (constant-name/type-name-index entry) stream)
- (write-u2 (constant-name/type-descriptor-index entry) stream))
- (7 ; class
- (write-u2 (constant-class-name-index entry) stream))
- (8 ; string
- (write-u2 (constant-string-value-index entry) stream))
- (t
- (error "write-constant-pool-entry unhandled tag ~D~%" tag))))))
+ (1 (sys::%format t "utf8: ~a~%" (constant-utf8-value entry)))
+ ((3 4) (sys::%format t "f/i: ~a~%" (constant-float/int-value entry)))
+ ((5 6) (sys::%format t "d/l: ~a~%" (constant-double/long-value entry)))
+ ((9 10 11) (sys::%format t "ref: ~a,~a~%"
+ (constant-member-ref-class-index entry)
+ (constant-member-ref-name/type-index entry)))
+ (12 (sys::%format t "n/t: ~a,~a~%"
+ (constant-name/type-name-index entry)
+ (constant-name/type-descriptor-index entry)))
+ (7 (sys::%format t "cls: ~a~%" (constant-class-name-index entry)))
+ (8 (sys::%format t "str: ~a~%" (constant-string-value-index entry))))))
+
#|
@@ -575,7 +611,9 @@
(:transient #x0080)
(:native #x0100)
(:abstract #x0400)
- (:strict #x0800)))
+ (:strict #x0800))
+ "List of keyword symbols used for human readable representation of (access)
+flags and their binary values.")
(defun map-flags (flags)
"Calculates the bitmap of the flags from a list of symbols."
@@ -587,12 +625,14 @@
:initial-value 0))
(defstruct (field (:constructor %make-field))
+ ""
access-flags
name
descriptor
attributes)
(defun make-field (name type &key (flags '(:public)))
+
(%make-field :access-flags flags
:name name
:descriptor type))
@@ -643,20 +683,33 @@
(t name)))
(defun !make-method (name return args &key (flags '(:public)))
- (%make-method :descriptor (cons return args)
+ (%!make-method :descriptor (cons return args)
:access-flags flags
:name name))
(defun method-add-attribute (method attribute)
- (push attribute (method-attributes method)))
+ "Add `attribute' to the list of attributes of `method',
+returning `attribute'."
+ (push attribute (method-attributes method))
+ attribute)
(defun method-add-code (method)
- "Creates an (empty) 'Code' attribute for the method."
+ "Creates an (empty) 'Code' attribute for the method,
+returning the created attribute."
(method-add-attribute
+ 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)
+ "Ensures the existence of a 'Code' attribute for the method,
+returning the attribute."
+ (let ((code (method-attribute method "Code")))
+ (if (null code)
+ (method-add-code method)
+ code)))
+
(defun method-attribute (method name)
(find name (method-attributes method)
:test #'string= :key #'attribute-name))
@@ -676,6 +729,7 @@
(defun !write-method (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))
@@ -691,8 +745,8 @@
(dolist (attribute attributes)
;; assure header: make sure 'name' is in the pool
(setf (attribute-name attribute)
- (pool-add-string (class-file-constants class)
- (attribute-name attribute)))
+ (pool-add-utf8 (class-file-constants class)
+ (attribute-name attribute)))
;; we're saving "root" attributes: attributes which have no parent
(funcall (attribute-finalizer attribute) attribute att class)))
@@ -705,7 +759,7 @@
(let ((local-stream (sys::%make-byte-array-output-stream)))
(funcall (attribute-writer attribute) attribute local-stream)
(let ((array (sys::%get-output-stream-array local-stream)))
- (write-u2 (length array) stream)
+ (write-u4 (length array) stream)
(write-sequence array stream)))))
@@ -719,34 +773,73 @@
max-stack
max-locals
code
+ exception-handlers
attributes
- ;; labels contains offsets into the code array after it's finalized
- (labels (make-hash-table :test #'eq))
;; fields not in the class file start here
- current-local ;; used for handling nested WITH-CODE-TO-METHOD blocks
- )
+
+ ;; labels contains offsets into the code array after it's finalized
+ labels ;; an alist
+
+ current-local) ;; used for handling nested WITH-CODE-TO-METHOD blocks
+
(defun code-label-offset (code label)
- (gethash label (code-labels code)))
+ (cdr (assoc label (code-labels code))))
(defun (setf code-label-offset) (offset code label)
- (setf (gethash label (code-labels code)) offset))
+ (setf (code-labels code)
+ (acons label offset (code-labels code))))
+
+
+
+(defun !finalize-code (code parent class)
+ (declare (ignore parent))
+ (let ((c (resolve-instructions (coerce (reverse (code-code code)) 'vector))))
+ (setf (code-max-stack code) (analyze-stack c))
+ (multiple-value-bind
+ (c labels)
+ (code-bytes c)
+ (setf (code-code code) c
+ (code-labels code) labels)))
+
+ (dolist (exception (code-exception-handlers code))
+ (setf (exception-start-pc exception)
+ (code-label-offset code (exception-start-pc exception))
+ (exception-end-pc exception)
+ (code-label-offset code (exception-end-pc exception))
+ (exception-handler-pc exception)
+ (code-label-offset code (exception-handler-pc exception))
+ (exception-catch-type exception)
+ (if (null (exception-catch-type exception))
+ 0 ;; generic 'catch all' class index number
+ (pool-add-class (class-file-constants class)
+ (exception-catch-type exception)))))
-(defun !finalize-code (code class)
- (let ((c (coerce (resolve-instructions (code-code code)) 'vector)))
- (setf (code-max-stack code) (analyze-stack c)
- (code-code code) (code-bytes c)))
(finalize-attributes (code-attributes code) code class))
(defun !write-code (code stream)
+ (sys::%format t "max-stack: ~a~%" (code-max-stack code))
(write-u2 (code-max-stack code) stream)
+ (sys::%format t "max-locals: ~a~%" (code-max-locals code))
(write-u2 (code-max-locals code) stream)
(let ((code-array (code-code code)))
+ (sys::%format t "length: ~a~%" (length code-array))
(write-u4 (length code-array) stream)
(dotimes (i (length code-array))
(write-u1 (svref code-array i) stream)))
+
+ (write-u2 (length (code-exception-handlers code)) stream)
+ (dolist (exception (reverse (code-exception-handlers code)))
+ (sys::%format t "start-pc: ~a~%" (exception-start-pc exception))
+ (write-u2 (exception-start-pc exception) stream)
+ (sys::%format t "end-pc: ~a~%" (exception-end-pc exception))
+ (write-u2 (exception-end-pc exception) stream)
+ (sys::%format t "handler-pc: ~a~%" (exception-handler-pc exception))
+ (write-u2 (exception-handler-pc exception) stream)
+ (write-u2 (exception-catch-type exception) stream))
+
(write-attributes (code-attributes code) stream))
(defun make-code-attribute (arg-count)
@@ -755,24 +848,44 @@
(%make-code-attribute :max-locals arg-count))
(defun code-add-attribute (code attribute)
- (push attribute (code-attributes code)))
+ "Adds `attribute' to `code', returning `attribute'."
+ (push attribute (code-attributes code))
+ attribute)
(defun code-attribute (code name)
(find name (code-attributes code)
:test #'string= :key #'attribute-name))
+(defun code-add-exception-handler (code start end handler type)
+ (push (make-exception :start-pc start
+ :end-pc end
+ :handler-pc handler
+ :catch-type type)
+ (code-exception-handlers code)))
+
+(defun add-exception-handler (start end handler type)
+ (code-add-exception-handler *current-code-attribute* start end handler type))
+
+(defstruct exception
+ start-pc ;; label target
+ end-pc ;; label target
+ handler-pc ;; label target
+ catch-type ;; a string for a specific type, or NIL for all
+ )
+
(defvar *current-code-attribute*)
(defun save-code-specials (code)
(setf (code-code code) *code*
(code-max-locals code) *registers-allocated*
- (code-exception-handlers code) *handlers*
+;; (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)))
@@ -784,67 +897,19 @@
`((when *current-code-attribute*
(save-code-specials *current-code-attribute*))))
(let* ((,m ,method)
- (,c (method-attribute ,m "Code"))
+ (,c (method-ensure-code method))
(*code* (code-code ,c))
(*registers-allocated* (code-max-locals ,c))
(*register* (code-current-local ,c))
(*current-code-attribute* ,c))
, at body
(setf (code-code ,c) *code*
- (code-exception-handlers ,c) *handlers*
+;; (code-exception-handlers ,c) *handlers*
(code-max-locals ,c) *registers-allocated*))
,@(when safe-nesting
`((when *current-code-attribute*
(restore-code-specials *current-code-attribute*)))))))
-(defstruct (exceptions-attribute (:constructor make-exceptions)
- (:conc-name exceptions-)
- (:include attribute
- (name "Exceptions")
- (finalizer #'finalize-exceptions)
- (writer #'write-exceptions)))
- exceptions)
-
-(defun finalize-exceptions (exceptions code class)
- (dolist (exception (exceptions-exceptions exceptions))
- ;; no need to finalize `catch-type': it's already the index required
- (setf (exception-start-pc exception)
- (code-label-offset code (exception-start-pc exception))
- (exception-end-pc exception)
- (code-label-offset code (exception-end-pc exception))
- (exception-handler-pc exception)
- (code-label-offset code (exception-handler-pc exception))
- (exception-catch-type exception)
- (pool-add-string (class-file-constants class)
- (exception-catch-type exception))))
- ;;(finalize-attributes (exceptions-attributes exception) exceptions class)
- )
-
-
-(defun write-exceptions (exceptions stream)
- ; number of entries
- (write-u2 (length (exceptions-exceptions exceptions)) stream)
- (dolist (exception (exceptions-exceptions exceptions))
- (write-u2 (exception-start-pc exception) stream)
- (write-u2 (exception-end-pc exception) stream)
- (write-u2 (exception-handler-pc exception) stream)
- (write-u2 (exception-catch-type exception) stream)))
-
-(defun code-add-exception (code start end handler type)
- (when (null (code-attribute code "Exceptions"))
- (code-add-attribute code (make-exceptions)))
- (push (make-exception :start-pc start
- :end-pc end
- :handler-pc handler
- :catch-type type)
- (exceptions-exceptions (code-attribute code "Exceptions"))))
-
-(defstruct exception
- start-pc ;; label target
- end-pc ;; label target
- handler-pc ;; label target
- catch-type ;; a string for a specific type, or NIL for all
- )
(defstruct (source-file-attribute (:conc-name source-)
(:include attribute
Modified: branches/generic-class-file/abcl/test/lisp/abcl/class-file.lisp
==============================================================================
--- branches/generic-class-file/abcl/test/lisp/abcl/class-file.lisp (original)
+++ branches/generic-class-file/abcl/test/lisp/abcl/class-file.lisp Thu Jul 29 14:27:10 2010
@@ -65,7 +65,7 @@
T)
(deftest fieldtype.2
- (string= (jvm::internal-field-type jvm::+!lisp-object+)
+ (string= (jvm::internal-field-type jvm::+lisp-object+)
"org/armedbear/lisp/LispObject")
T)
@@ -111,7 +111,7 @@
T)
(deftest fieldref.2
- (string= (jvm::internal-field-ref jvm::+!lisp-object+)
+ (string= (jvm::internal-field-ref jvm::+lisp-object+)
"Lorg/armedbear/lisp/LispObject;")
T)
@@ -124,58 +124,105 @@
T)
(deftest descriptor.2
- (string= (jvm::descriptor jvm::+!lisp-object+ jvm::+!lisp-object+)
+ (string= (jvm::descriptor jvm::+lisp-object+ jvm::+lisp-object+)
"(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")
T)
(deftest map-flags.1
- (eql (jvm::map-flags '(:public)) #x0001))
+ (eql (jvm::map-flags '(:public)) #x0001)
+ T)
(deftest pool.1
(let* ((pool (jvm::make-pool)))
- (jvm::pool-add-class pool jvm::+!lisp-readtable+)
- (jvm::pool-add-field-ref pool jvm::+!lisp-readtable+ "ABC" :int)
+ (jvm::pool-add-class pool jvm::+lisp-readtable+)
+ (jvm::pool-add-field-ref pool jvm::+lisp-readtable+ "ABC" :int)
(jvm::pool-add-field-ref pool
- jvm::+!lisp-readtable+ "ABD"
- jvm::+!lisp-readtable+)
- (jvm::pool-add-method-ref pool jvm::+!lisp-readtable+ "MBC" :int)
- (jvm::pool-add-method-ref pool jvm::+!lisp-readtable+ "MBD"
- jvm::+!lisp-readtable+)
+ jvm::+lisp-readtable+ "ABD"
+ jvm::+lisp-readtable+)
+ (jvm::pool-add-method-ref pool jvm::+lisp-readtable+ "MBC" :int)
+ (jvm::pool-add-method-ref pool jvm::+lisp-readtable+ "MBD"
+ jvm::+lisp-readtable+)
(jvm::pool-add-interface-method-ref pool
- jvm::+!lisp-readtable+ "MBD" :int)
+ jvm::+lisp-readtable+ "MBD" :int)
(jvm::pool-add-interface-method-ref pool
- jvm::+!lisp-readtable+ "MBD"
- jvm::+!lisp-readtable+)
+ jvm::+lisp-readtable+ "MBD"
+ jvm::+lisp-readtable+)
(jvm::pool-add-string pool "string")
(jvm::pool-add-int pool 1)
(jvm::pool-add-float pool 1.0f0)
(jvm::pool-add-long pool 1)
(jvm::pool-add-double pool 1.0d0)
(jvm::pool-add-name/type pool "name1" :int)
- (jvm::pool-add-name/type pool "name2" jvm::+!lisp-object+)
+ (jvm::pool-add-name/type pool "name2" jvm::+lisp-object+)
(jvm::pool-add-utf8 pool "utf8")
T)
T)
(deftest make-class-file.1
(let* ((class (jvm::make-class-name "org/armedbear/lisp/mcf_1"))
- (file (jvm::!make-class-file class jvm::+!lisp-object+ '(:public))))
+ (file (jvm::!make-class-file class jvm::+lisp-object+ '(:public))))
(jvm::class-add-field file (jvm::make-field "ABC" :int))
- (jvm::class-add-field file (jvm::make-field "ABD" jvm::+!lisp-object+))
+ (jvm::class-add-field file (jvm::make-field "ABD" jvm::+lisp-object+))
(jvm::class-add-method file (jvm::!make-method "MBC" nil :int))
- (jvm::class-add-method file (jvm::!make-method "MBD" nil jvm::+!lisp-object+))
+ (jvm::class-add-method file (jvm::!make-method "MBD" nil jvm::+lisp-object+))
+ (jvm::class-add-method file (jvm::!make-method :constructor :void nil))
+ (jvm::class-add-method file (jvm::!make-method :class-constructor :void nil))
T)
T)
(deftest finalize-class-file.1
- (let* ((class (jvm::make-class-name "org/armedbear/lisp/mcf_1"))
- (file (jvm::!make-class-file class jvm::+!lisp-object+ '(:public))))
+ (let* ((class (jvm::make-class-name "org/armedbear/lisp/fcf_1"))
+ (file (jvm::!make-class-file class jvm::+lisp-object+ '(:public))))
(jvm::class-add-field file (jvm::make-field "ABC" :int))
- (jvm::class-add-field file (jvm::make-field "ABD" jvm::+!lisp-object+))
+ (jvm::class-add-field file (jvm::make-field "ABD" jvm::+lisp-object+))
(jvm::class-add-method file (jvm::!make-method "MBC" nil '(:int)))
(jvm::class-add-method file
(jvm::!make-method "MBD" nil
- (list jvm::+!lisp-object+)))
+ (list jvm::+lisp-object+)))
+ (jvm::finalize-class-file file)
+ file
+ T)
+ T)
+
+(deftest generate-method.1
+ (let* ((class (jvm::make-class-name "org/armedbear/lisp/gm_1"))
+ (file (jvm::!make-class-file class jvm::+lisp-object+ '(:public)))
+ (method (jvm::!make-method :class-constructor :void nil
+ :flags '(:static))))
+ (jvm::class-add-method file method)
+ (jvm::with-code-to-method (method)
+ (jvm::emit 'return))
+ (jvm::finalize-class-file file)
+ (with-open-stream (stream (sys::%make-byte-array-output-stream))
+ (jvm::!write-class-file file stream)
+ (sys::load-compiled-function (sys::%get-output-stream-bytes stream)))
+ T)
+ T)
+
+(deftest generate-method.2
+ (let* ((class (jvm::make-class-name "org/armedbear/lisp/gm_2"))
+ (file (jvm::!make-class-file class jvm::+lisp-object+ '(:public)))
+ (method (jvm::!make-method "doNothing" :void nil)))
+ (jvm::class-add-method file method)
+ (jvm::with-code-to-method (method)
+ (let ((label1 (gensym))
+ (label2 (gensym))
+ (label3 (gensym)))
+ (jvm::label label1)
+ (jvm::emit 'jvm::iconst_1)
+ (jvm::label label2)
+ (jvm::emit 'return)
+ (jvm::label label3)
+ (jvm::code-add-exception-handler (jvm::method-attribute method "Code")
+ label1 label2 label3 nil))
+ (jvm::emit 'return))
(jvm::finalize-class-file file)
- file)
- T)
\ No newline at end of file
+ (with-open-stream (stream (sys::%make-byte-array-output-stream))
+ (jvm::!write-class-file file stream)
+ (sys::load-compiled-function (sys::%get-output-stream-bytes stream)))
+ T)
+ T)
+
+
+;;(deftest generate-method.2
+;; (let* ((class))))
\ No newline at end of file
More information about the armedbear-cvs
mailing list