[armedbear-cvs] r12785 - branches/generic-class-file/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Sun Jul 4 21:31:19 UTC 2010
Author: ehuelsmann
Date: Sun Jul 4 17:31:17 2010
New Revision: 12785
Log:
Documentation.
Modified:
branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
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 Jul 4 17:31:17 2010
@@ -58,6 +58,7 @@
(defun map-primitive-type (type)
+ "Maps a symbolic primitive type name to its Java string representation."
(case type
(:int "I")
(:long "J")
@@ -86,12 +87,18 @@
array-ref)
(defun make-class-name (name)
+ "Creates a `class-name' structure for the class or interface `name'.
+
+`name' should be specified using Java representation, which is converted
+to 'internal' (JVM) representation by this function."
(setf name (substitute #\/ #\. name))
(%make-class-name :name-internal name
:ref (concatenate 'string "L" name ";")
:array-ref (concatenate 'string "[L" name ";")))
(defmacro define-class-name (symbol java-dotted-name &optional documentation)
+ "Convenience macro to define constants for `class-name' structures,
+initialized from the `java-dotted-name'."
`(defconstant ,symbol (make-class-name ,java-dotted-name)
,documentation))
@@ -153,16 +160,24 @@
|#
(defun internal-field-type (field-type)
+ "Returns a string containing the JVM-internal representation
+of `field-type', which should either be a symbol identifying a primitive
+type, or a `class-name' structure identifying a class or interface."
(if (symbolp field-type)
(map-primitive-type field-type)
(class-name-internal field-type)))
(defun internal-field-ref (field-type)
+ "Returns a string containing the JVM-internal representation of a reference
+to `field-type', which should either be a symbol identifying a primitive
+type, or a `class-name' structure identifying a class or interface."
(if (symbolp field-type)
(map-primitive-type field-type)
(class-ref field-type)))
(defun descriptor (return-type &rest argument-types)
+ "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)))
@@ -177,7 +192,9 @@
;; utf8, because both are string values
(entries (make-hash-table :test #'equal :size 2048 :rehash-size 2.0)))
+
(defstruct constant
+ "Structure to be included in all constant sub-types."
tag
index)
@@ -209,19 +226,23 @@
(declaim (inline make-constant-field-ref make-constant-method-ref
make-constant-interface-method-ref))
(defun make-constant-field-ref (index class-index name/type-index)
+ "Creates a `constant-member-ref' instance containing a field reference."
(%make-constant-member-ref 9 index class-index name/type-index))
(defun make-constant-method-ref (index class-index name/type-index)
+ "Creates a `constant-member-ref' instance containing a method reference."
(%make-constant-member-ref 10 index class-index name/type-index))
(defun make-constant-interface-method-ref (index class-index name/type-index)
+ "Creates a `constant-member-ref' instance containing an
+interface-method reference."
(%make-constant-member-ref 11 index class-index name/type-index))
(defstruct (constant-string (:constructor
make-constant-string (index value-index))
(:include constant
(tag 8)))
- value-index) ;;; #### is this the value or the value index???
+ value-index)
(defstruct (constant-float/int (:constructor
%make-constant-float/int (tag index value))
@@ -230,9 +251,11 @@
(declaim (inline make-constant-float make-constant-int))
(defun make-constant-float (index value)
+ "Creates a `constant-float/int' structure instance containing a float."
(%make-constant-float/int 4 index value))
(defun make-constant-int (index value)
+ "Creates a `constant-float/int' structure instance containing an int."
(%make-constant-float/int 3 index value))
(defstruct (constant-double/long (:constructor
@@ -242,9 +265,11 @@
(declaim (inline make-constant-double make-constant-float))
(defun make-constant-double (index value)
+ "Creates a `constant-double/long' structure instance containing a double."
(%make-constant-double/long 6 index value))
(defun make-constant-long (index value)
+ "Creates a `constant-double/long' structure instance containing a long."
(%make-constant-double/long 5 index value))
(defstruct (constant-name/type (:constructor
@@ -263,7 +288,9 @@
(defun pool-add-class (pool class)
- ;; ### do we make class a string or class-name structure?
+ "Returns the index of the constant-pool class item for `class'.
+
+`class' must be an instance of `class-name'."
(let ((entry (gethash class (pool-entries pool))))
(unless entry
(setf entry
@@ -275,6 +302,12 @@
(constant-index entry)))
(defun pool-add-field-ref (pool class name type)
+ "Returns the index of the constant-pool item which denotes a reference
+to the `name' field of the `class', being of `type'.
+
+`class' should be an instance of `class-name'.
+`name' is a string.
+`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))
@@ -285,6 +318,11 @@
(constant-index entry)))
(defun pool-add-method-ref (pool class name type)
+ "Returns the index of the constant-pool item which denotes a reference
+to the method with `name' in `class', which is of `type'.
+
+Here, `type' is a method descriptor, which defines the argument types
+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))
@@ -295,6 +333,10 @@
(constant-index entry)))
(defun pool-add-interface-method-ref (pool class name type)
+ "Returns the index of the constant-pool item which denotes a reference to
+the method `name' in the interface `class', which is of `type'.
+
+See `pool-add-method-ref' for remarks."
(let ((entry (gethash (acons name type class) (pool-entries pool))))
(unless entry
(setf entry
@@ -307,6 +349,7 @@
(constant-index entry)))
(defun pool-add-string (pool string)
+ "Returns the index of the constant-pool item denoting the string."
(let ((entry (gethash (cons 8 string) ;; 8 == string-tag
(pool-entries pool))))
(unless entry
@@ -317,6 +360,7 @@
(constant-index entry)))
(defun pool-add-int (pool int)
+ "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)
@@ -325,6 +369,7 @@
(constant-index entry)))
(defun pool-add-float (pool float)
+ "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)
@@ -333,6 +378,7 @@
(constant-index entry)))
(defun pool-add-long (pool long)
+ "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)
@@ -342,6 +388,7 @@
(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)
@@ -351,6 +398,8 @@
(constant-index entry)))
(defun pool-add-name/type (pool name type)
+ "Returns the index of the constant-pool item denoting
+the name/type identifier."
(let ((entry (gethash (cons name type) (pool-entries pool)))
(internal-type (if (listp type)
(apply #'descriptor type)
@@ -364,6 +413,8 @@
(constant-index entry)))
(defun pool-add-utf8 (pool utf8-as-string)
+ "Returns the index of the textual value that will be stored in the
+class file as UTF-8 encoded data."
(let ((entry (gethash (cons 11 utf8-as-string) ;; 11 == utf8
(pool-entries pool))))
(unless entry
@@ -384,20 +435,27 @@
attributes)
(defun class-add-field (class field)
+ "Adds a `field' created by `make-field'."
(push field (class-file-fields class)))
(defun class-field (class name)
+ "Finds a field by name." ;; ### strictly speaking, a field is uniquely
+ ;; identified by its name and type, not by the name alone.
(find name (class-file-fields class)
:test #'string= :key #'field-name))
(defun class-add-method (class method)
+ "Adds a `method' to `class'; the method must have been created using
+`make-method'."
(push method (class-file-methods class)))
(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))
(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)
@@ -405,15 +463,21 @@
(class-file-methods class))))
(defun class-add-attribute (class attribute)
+ "Adds `attribute' to the class; attributes must be instances of
+structure classes which include the `attribute' structure class."
(push attribute (class-file-attributes class)))
(defun class-attribute (class name)
+ "Returns the attribute which is named `name'."
(find name (class-file-attributes class)
:test #'string= :key #'attribute-name))
(defun finalize-class-file (class)
+ "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."
;; constant pool contains constants finalized on addition;
;; no need for additional finalization
@@ -428,14 +492,10 @@
(dolist (method (class-file-methods class))
(finalize-method method class))
;; top-level attributes (no parent attributes to refer to)
- (finalize-attributes (class-file-attributes class) nil class)
-
-)
+ (finalize-attributes (class-file-attributes class) nil class))
(defun !write-class-file (class stream)
- ;; all components need to finalize themselves:
- ;; the constant pool needs to be complete before we start
- ;; writing our output.
+ "Serializes `class' to `stream', after it has been finalized."
;; header
(write-u4 #xCAFEBABE stream)
@@ -473,23 +533,23 @@
(let ((tag (constant-tag entry)))
(write-u1 tag stream)
(case tag
- (1 ; UTF8
+ (1 ; UTF8
(write-utf8 (constant-utf8-value entry) stream))
- ((3 4) ; int
+ ((3 4) ; int
(write-u4 (constant-float/int-value entry) stream))
- ((5 6) ; long double
+ ((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
+ (12 ; nameAndType
(write-u2 (constant-name/type-name-index entry) stream)
(write-u2 (constant-name/type-descriptor-index entry) stream))
- (7 ; class
+ (7 ; class
(write-u2 (constant-class-name-index entry) stream))
- (8 ; string
+ (8 ; string
(write-u2 (constant-string-value-index entry) stream))
(t
(error "write-constant-pool-entry unhandled tag ~D~%" tag))))))
@@ -517,6 +577,7 @@
(:strict #x0800)))
(defun map-flags (flags)
+ "Calculates the bitmap of the flags from a list of symbols."
(reduce #'(lambda (y x)
(logior (or (when (member (car x) flags)
(second x))
@@ -528,8 +589,7 @@
access-flags
name
descriptor
- attributes
- )
+ attributes)
(defun make-field (name type &key (flags '(:public)))
(%make-field :access-flags flags
@@ -564,11 +624,16 @@
access-flags
name
descriptor
- attributes
- )
+ attributes)
(defun map-method-name (name)
+ "Methods should be identified by strings containing their names, or,
+be one of two keyword identifiers to identify special methods:
+
+ * :class-constructor
+ * :constructor
+"
(cond
((eq name :class-constructor)
"<clinit>")
More information about the armedbear-cvs
mailing list