source: trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp @ 13792

Last change on this file since 13792 was 13792, checked in by astalla, 12 years ago

A small reorganization of compiler/jvm code. Runtime-class wasn't autoloading properly in certain situations due to a wrong dependency graph among some system files.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 61.4 KB
Line 
1;;; jvm-class-file.lisp
2;;;
3;;; Copyright (C) 2010 Erik Huelsmann
4;;; $Id: jvm-class-file.lisp 13792 2012-01-20 01:10:39Z astalla $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32(in-package "JVM")
33(require '#:compiler-types)
34
35#|
36
37The general design of the class-file writer is to have generic
38- human readable - representations of the class being generated
39during the construction and manipulation phases.
40
41After completing the creation/manipulation of the class, all its
42components will be finalized. This process translates readable
43(e.g. string) representations to indices to be stored on disc.
44
45The only thing to be done after finalization is sending the
46output to a stream ("writing").
47
48
49Finalization happens highest-level first. As an example, take a
50method with exception handlers. The exception handlers are stored
51as attributes in the class file structure. They are children of the
52method's Code attribute. In this example, the body of the Code
53attribute (the higher level) gets finalized before the attributes.
54The reason to do so is that the exceptions need to refer to labels
55(offsets) in the Code segment.
56
57
58|#
59
60
61(defun map-primitive-type (type)
62  "Maps a symbolic primitive type name to its Java string representation."
63  (case type
64    (:int        "I")
65    (:long       "J")
66    (:float      "F")
67    (:double     "D")
68    (:boolean    "Z")
69    (:char       "C")
70    (:byte       "B")
71    (:short      "S")
72    ((nil :void) "V")))
73
74
75#|
76
77The `class-name' facility helps to abstract from "this instruction takes
78a reference" and "this instruction takes a class name". We simply pass
79the class name around and the instructions themselves know which
80representation to use.
81
82|#
83
84(defstruct (jvm-class-name (:conc-name class-)
85                           (:constructor %make-jvm-class-name))
86  "Used for class identification.
87
88The caller should instantiate only one `class-name' per class, as they are
89used as class identifiers and compared using EQ.
90
91Some instructions need a class argument, others need a reference identifier.
92This class is used to abstract from the difference."
93  name-internal
94  ref
95  array-class ;; cached array class reference
96  ;; keeping a reference to the associated array class allows class
97  ;; name comparisons to be EQ: all classes should exist only once,
98  )
99
100(defun make-jvm-class-name (name)
101  "Creates a `class-name' structure for the class or interface `name'.
102
103`name' should be specified using Java representation, which is converted
104to 'internal' (JVM) representation by this function."
105  (setf name (substitute #\/ #\. name))
106  (%make-jvm-class-name :name-internal name
107      :ref (concatenate 'string "L" name ";")))
108
109(defun class-array (class-name)
110  "Returns a class-name representing an array of `class-name'.
111For multi-dimensional arrays, call this function multiple times, using
112its own result.
113
114This function can be called multiple times on the same `class-name' without
115violating the 'only one instance' requirement: the returned value is cached
116and used on successive calls."
117  (unless (class-array-class class-name)
118    ;; Alessio Stalla found by dumping a class file that the JVM uses
119    ;; the same representation (ie '[L<class-name>;') in CHECKCAST as
120    ;; it does in field references, meaning the class name and class ref
121    ;; are identified by the same string
122    (let ((name-and-ref (concatenate 'string "[" (class-ref class-name))))
123      (setf (class-array-class class-name)
124            (%make-jvm-class-name :name-internal name-and-ref
125          :ref name-and-ref))))
126  (class-array-class class-name))
127
128(defmacro define-class-name (symbol java-dotted-name &optional documentation)
129  "Convenience macro to define constants for `class-name' structures,
130initialized from the `java-dotted-name'."
131  `(defconstant ,symbol (make-jvm-class-name ,java-dotted-name)
132     ,documentation))
133
134(define-class-name +java-class+ "java.lang.Class")
135(define-class-name +java-object+ "java.lang.Object")
136(define-class-name +java-string+ "java.lang.String")
137(define-class-name +java-system+ "java.lang.System")
138(define-class-name +java-io-input-stream+ "java.io.InputStream")
139(define-class-name +lisp-object+ "org.armedbear.lisp.LispObject")
140(defconstant +lisp-object-array+ (class-array +lisp-object+))
141(define-class-name +lisp-simple-string+ "org.armedbear.lisp.SimpleString")
142(define-class-name +lisp+ "org.armedbear.lisp.Lisp")
143(define-class-name +lisp-nil+ "org.armedbear.lisp.Nil")
144(define-class-name +lisp-class+ "org.armedbear.lisp.LispClass")
145(define-class-name +lisp-symbol+ "org.armedbear.lisp.Symbol")
146(define-class-name +lisp-thread+ "org.armedbear.lisp.LispThread")
147(define-class-name +lisp-closure-binding+ "org.armedbear.lisp.ClosureBinding")
148(defconstant +closure-binding-array+ (class-array +lisp-closure-binding+))
149(define-class-name +lisp-integer+ "org.armedbear.lisp.LispInteger")
150(define-class-name +lisp-fixnum+ "org.armedbear.lisp.Fixnum")
151(defconstant +lisp-fixnum-array+ (class-array +lisp-fixnum+))
152(define-class-name +lisp-bignum+ "org.armedbear.lisp.Bignum")
153(define-class-name +lisp-single-float+ "org.armedbear.lisp.SingleFloat")
154(define-class-name +lisp-double-float+ "org.armedbear.lisp.DoubleFloat")
155(define-class-name +lisp-cons+ "org.armedbear.lisp.Cons")
156(define-class-name +lisp-load+ "org.armedbear.lisp.Load")
157(define-class-name +lisp-character+ "org.armedbear.lisp.LispCharacter")
158(defconstant +lisp-character-array+ (class-array +lisp-character+))
159(define-class-name +lisp-structure-object+ "org.armedbear.lisp.StructureObject")
160(define-class-name +lisp-simple-vector+ "org.armedbear.lisp.SimpleVector")
161(define-class-name +lisp-abstract-string+ "org.armedbear.lisp.AbstractString")
162(define-class-name +lisp-abstract-vector+ "org.armedbear.lisp.AbstractVector")
163(define-class-name +lisp-abstract-bit-vector+
164    "org.armedbear.lisp.AbstractBitVector")
165(define-class-name +lisp-environment+ "org.armedbear.lisp.Environment")
166(define-class-name +lisp-special-binding+ "org.armedbear.lisp.SpecialBinding")
167(define-class-name +lisp-special-bindings-mark+
168    "org.armedbear.lisp.SpecialBindingsMark")
169(define-class-name +lisp-throw+ "org.armedbear.lisp.Throw")
170(define-class-name +lisp-return+ "org.armedbear.lisp.Return")
171(define-class-name +lisp-go+ "org.armedbear.lisp.Go")
172(define-class-name +lisp-primitive+ "org.armedbear.lisp.Primitive")
173(define-class-name +lisp-compiled-primitive+
174    "org.armedbear.lisp.CompiledPrimitive")
175(define-class-name +lisp-eql-hash-table+ "org.armedbear.lisp.EqlHashTable")
176(define-class-name +lisp-hash-table+ "org.armedbear.lisp.HashTable")
177(define-class-name +lisp-package+ "org.armedbear.lisp.Package")
178(define-class-name +lisp-readtable+ "org.armedbear.lisp.Readtable")
179(define-class-name +lisp-stream+ "org.armedbear.lisp.Stream")
180(define-class-name +lisp-closure+ "org.armedbear.lisp.Closure")
181(define-class-name +lisp-compiled-closure+ "org.armedbear.lisp.CompiledClosure")
182(define-class-name +lisp-closure-parameter+
183    "org.armedbear.lisp.Closure$Parameter")
184(defconstant +lisp-closure-parameter-array+
185  (class-array +lisp-closure-parameter+))
186
187#|
188
189Lisp-side descriptor representation:
190
191 - list: a list starting with a method return value, followed by
192     the argument types
193 - keyword: the primitive type associated with that keyword
194 - class-name structure instance: the class-ref value
195
196The latter two can be converted to a Java representation using
197the `internal-field-ref' function, the former is to be fed to
198`descriptor'.
199
200|#
201
202(defun internal-field-type (field-type)
203  "Returns a string containing the JVM-internal representation
204of `field-type', which should either be a symbol identifying a primitive
205type, or a `class-name' structure identifying a class or interface."
206  (if (symbolp field-type)
207      (map-primitive-type field-type)
208      (class-name-internal field-type)))
209
210(defun internal-field-ref (field-type)
211  "Returns a string containing the JVM-internal representation of a reference
212to `field-type', which should either be a symbol identifying a primitive
213type, or a `class-name' structure identifying a class or interface."
214  (if (symbolp field-type)
215      (map-primitive-type field-type)
216      (class-ref field-type)))
217
218(defun descriptor (return-type &rest argument-types)
219  "Returns a string describing the `return-type' and `argument-types'
220in JVM-internal representation."
221  (let* ((arg-strings (mapcar #'internal-field-ref argument-types))
222         (ret-string (internal-field-ref return-type))
223         (size (+ 2 (reduce #'+ arg-strings
224                            :key #'length
225                            :initial-value (length ret-string))))
226         (str (make-array size :fill-pointer 0 :element-type 'character)))
227    (with-output-to-string (s str)
228      (princ #\( s)
229      (dolist (arg-string arg-strings)
230        (princ arg-string s))
231      (princ #\) s)
232      (princ ret-string s))
233    str)
234;;  (format nil "(~{~A~})~A"
235;;          (internal-field-ref return-type))
236  )
237
238(defun descriptor-stack-effect (return-type &rest argument-types)
239  "Returns the effect on the stack position of the `argument-types' and
240`return-type' of a method call.
241
242If the method consumes an implicit `this' argument, this function does not
243take that effect into account."
244  (flet ((type-stack-effect (arg)
245           (case arg
246             ((:long :double) 2)
247             ((nil :void) 0)
248             (otherwise 1))))
249    (+ (reduce #'- argument-types
250               :key #'type-stack-effect
251               :initial-value 0)
252       (type-stack-effect return-type))))
253
254
255(defstruct pool
256  ;; `index' contains the index of the last allocated slot (0 == empty)
257  ;; "A constant pool entry is considered valid if it has
258  ;; an index greater than 0 (zero) and less than pool-count"
259  (index 0)
260  entries-list
261  ;; the entries hash stores raw values, except in case of string and
262  ;; utf8, because both are string values
263  (entries (make-hash-table :test #'equal :size 2048 :rehash-size 2.0)))
264
265
266(defstruct constant
267  "Structure to be included in all constant sub-types."
268  tag
269  index)
270
271(defparameter +constant-type-map+
272  '((:class          7 1)
273    (:field-ref      9 1)
274    (:method-ref    10 1)
275    ;; (:interface-method-ref 11)
276    (:string         8 1)
277    (:integer        3 1)
278    (:float          4 1)
279    (:long           5 2)
280    (:double         6 2)
281    (:name-and-type 12 1)
282    (:utf8           1 1)))
283
284(defstruct (constant-class (:constructor make-constant-class (index name-index))
285                           (:include constant
286                                     (tag 7)))
287  "Structure holding information on a 'class' type item in the constant pool."
288  name-index)
289
290(defstruct (constant-member-ref (:constructor
291                                 %make-constant-member-ref
292                                     (tag index class-index name/type-index))
293                                (:include constant))
294  "Structure holding information on a member reference type item
295(a field, method or interface method reference) in the constant pool."
296  class-index
297  name/type-index)
298
299(declaim (inline make-constant-field-ref make-constant-method-ref
300                 make-constant-interface-method-ref))
301(defun make-constant-field-ref (index class-index name/type-index)
302  "Creates a `constant-member-ref' instance containing a field reference."
303  (%make-constant-member-ref 9 index class-index name/type-index))
304
305(defun make-constant-method-ref (index class-index name/type-index)
306  "Creates a `constant-member-ref' instance containing a method reference."
307  (%make-constant-member-ref 10 index class-index name/type-index))
308
309(defun make-constant-interface-method-ref (index class-index name/type-index)
310  "Creates a `constant-member-ref' instance containing an
311interface-method reference."
312  (%make-constant-member-ref 11 index class-index name/type-index))
313
314(defstruct (constant-string (:constructor
315                             make-constant-string (index value-index))
316                            (:include constant
317                                      (tag 8)))
318  "Structure holding information on a 'string' type item in the constant pool."
319  value-index)
320
321(defstruct (constant-float/int (:constructor
322                                %make-constant-float/int (tag index value))
323                               (:include constant))
324  "Structure holding information on a 'float' or 'integer' type item
325in the constant pool."
326  value)
327
328(declaim (inline make-constant-float make-constant-int))
329(defun make-constant-float (index value)
330  "Creates a `constant-float/int' structure instance containing a float."
331  (%make-constant-float/int 4 index value))
332
333(defun make-constant-int (index value)
334  "Creates a `constant-float/int' structure instance containing an int."
335  (%make-constant-float/int 3 index value))
336
337(defstruct (constant-double/long (:constructor
338                                  %make-constant-double/long (tag index value))
339                                 (:include constant))
340  "Structure holding information on a 'double' or 'long' type item
341in the constant pool."
342  value)
343
344(declaim (inline make-constant-double make-constant-float))
345(defun make-constant-double (index value)
346  "Creates a `constant-double/long' structure instance containing a double."
347  (%make-constant-double/long 6 index value))
348
349(defun make-constant-long (index value)
350  "Creates a `constant-double/long' structure instance containing a long."
351  (%make-constant-double/long 5 index value))
352
353(defstruct (constant-name/type (:constructor
354                                make-constant-name/type (index
355                                                         name-index
356                                                         descriptor-index))
357                               (:include constant
358                                         (tag 12)))
359  "Structure holding information on a 'name-and-type' type item in the
360constant pool; this type of element is used by 'member-ref' type items."
361  name-index
362  descriptor-index)
363
364(defstruct (constant-utf8 (:constructor make-constant-utf8 (index value))
365                          (:include constant
366                                    (tag 1)))
367  "Structure holding information on a 'utf8' type item in the constant pool;
368
369This type of item is used for text representation of identifiers
370and string contents."
371  value)
372
373
374(defun pool-add-class (pool class)
375  "Returns the index of the constant-pool class item for `class'.
376
377`class' must be an instance of `class-name' or a string (which will be converted
378to a `class-name')."
379  (let ((class (if (jvm-class-name-p class)
380                   class
381                   (make-jvm-class-name class))))
382    (let ((entry (gethash class (pool-entries pool))))
383      (unless entry
384        (let ((utf8 (pool-add-utf8 pool (class-name-internal class))))
385          (setf entry
386                (make-constant-class (incf (pool-index pool)) utf8)
387                (gethash class (pool-entries pool)) entry))
388        (push entry (pool-entries-list pool)))
389      (constant-index entry))))
390
391(defun pool-add-field-ref (pool class name type)
392  "Returns the index of the constant-pool item which denotes a reference
393to the `name' field of the `class', being of `type'.
394
395`class' should be an instance of `class-name'.
396`name' is a string.
397`type' is a field-type (see `internal-field-type')"
398  (let ((entry (gethash (acons name type class) (pool-entries pool))))
399    (unless entry
400      (let ((c (pool-add-class pool class))
401            (n/t (pool-add-name/type pool name type)))
402        (setf entry (make-constant-field-ref (incf (pool-index pool)) c n/t)
403            (gethash (acons name type class) (pool-entries pool)) entry))
404      (push entry (pool-entries-list pool)))
405    (constant-index entry)))
406
407(defun pool-add-method-ref (pool class name type)
408  "Returns the index of the constant-pool item which denotes a reference
409to the method with `name' in `class', which is of `type'.
410
411Here, `type' is a method descriptor, which defines the argument types
412and return type. `class' is an instance of `class-name'."
413  (let ((entry (gethash (acons name type class) (pool-entries pool))))
414    (unless entry
415      (let ((c (pool-add-class pool class))
416            (n/t (pool-add-name/type pool name type)))
417        (setf entry (make-constant-method-ref (incf (pool-index pool)) c n/t)
418              (gethash (acons name type class) (pool-entries pool)) entry))
419      (push entry (pool-entries-list pool)))
420    (constant-index entry)))
421
422(defun pool-add-interface-method-ref (pool class name type)
423  "Returns the index of the constant-pool item which denotes a reference to
424the method `name' in the interface `class', which is of `type'.
425
426See `pool-add-method-ref' for remarks."
427  (let ((entry (gethash (acons name type class) (pool-entries pool))))
428    (unless entry
429      (let ((c (pool-add-class pool class))
430            (n/t (pool-add-name/type pool name type)))
431        (setf entry
432            (make-constant-interface-method-ref (incf (pool-index pool)) c n/t)
433            (gethash (acons name type class) (pool-entries pool)) entry))
434      (push entry (pool-entries-list pool)))
435    (constant-index entry)))
436
437(defun pool-add-string (pool string)
438  "Returns the index of the constant-pool item denoting the string."
439  (let ((entry (gethash (cons 8 string) ;; 8 == string-tag
440                        (pool-entries pool))))
441    (unless entry
442      (let ((utf8 (pool-add-utf8 pool string)))
443        (setf entry (make-constant-string (incf (pool-index pool)) utf8)
444              (gethash (cons 8 string) (pool-entries pool)) entry))
445      (push entry (pool-entries-list pool)))
446    (constant-index entry)))
447
448(defun pool-add-int (pool int)
449  "Returns the index of the constant-pool item denoting the int."
450  (let ((entry (gethash (cons 3 int) (pool-entries pool))))
451    (unless entry
452      (setf entry (make-constant-int (incf (pool-index pool)) int)
453            (gethash (cons 3 int) (pool-entries pool)) entry)
454      (push entry (pool-entries-list pool)))
455    (constant-index entry)))
456
457(defun pool-add-float (pool float)
458  "Returns the index of the constant-pool item denoting the float."
459  (let ((entry (gethash (cons 4 float) (pool-entries pool))))
460    (unless entry
461      (setf entry (make-constant-float (incf (pool-index pool))
462                                       (sys::%float-bits float))
463            (gethash (cons 4 float) (pool-entries pool)) entry)
464      (push entry (pool-entries-list pool)))
465    (constant-index entry)))
466
467(defun pool-add-long (pool long)
468  "Returns the index of the constant-pool item denoting the long."
469  (let ((entry (gethash (cons 5 long) (pool-entries pool))))
470    (unless entry
471      (setf entry (make-constant-long (incf (pool-index pool)) long)
472            (gethash (cons 5 long) (pool-entries pool)) entry)
473      (push entry (pool-entries-list pool))
474      (incf (pool-index pool))) ;; double index increase; long takes 2 slots
475    (constant-index entry)))
476
477(defun pool-add-double (pool double)
478  "Returns the index of the constant-pool item denoting the double."
479  (let ((entry (gethash (cons 6 double) (pool-entries pool))))
480    (unless entry
481      (setf entry (make-constant-double (incf (pool-index pool))
482                                        (sys::%float-bits double))
483            (gethash (cons 6 double) (pool-entries pool)) entry)
484      (push entry (pool-entries-list pool))
485      (incf (pool-index pool))) ;; double index increase; 'double' takes 2 slots
486    (constant-index entry)))
487
488(defun pool-add-name/type (pool name type)
489  "Returns the index of the constant-pool item denoting
490the name/type identifier."
491  (let ((entry (gethash (cons name type) (pool-entries pool)))
492        (internal-type (if (listp type)
493                           (apply #'descriptor type)
494                           (internal-field-ref type))))
495    (unless entry
496      (let ((n (pool-add-utf8 pool name))
497            (i-t (pool-add-utf8 pool internal-type)))
498        (setf entry (make-constant-name/type (incf (pool-index pool)) n i-t)
499              (gethash (cons name type) (pool-entries pool)) entry))
500      (push entry (pool-entries-list pool)))
501    (constant-index entry)))
502
503(defun pool-add-utf8 (pool utf8-as-string)
504  "Returns the index of the textual value that will be stored in the
505class file as UTF-8 encoded data."
506  (let ((entry (gethash (cons 11 utf8-as-string) ;; 11 == utf8
507                        (pool-entries pool))))
508    (unless entry
509      (setf entry (make-constant-utf8 (incf (pool-index pool)) utf8-as-string)
510            (gethash (cons 11 utf8-as-string) (pool-entries pool)) entry)
511      (push entry (pool-entries-list pool)))
512    (constant-index entry)))
513
514(defstruct (class-file (:constructor
515                        make-class-file (class superclass access-flags)))
516  "Holds the components of a class file."
517  (constants (make-pool))
518  access-flags
519  class
520  superclass
521  interfaces
522  fields
523  methods
524  attributes)
525
526(defun make-class-interface-file (class)
527  "Create the components of a class file representing a public Java
528interface."
529  (make-class-file class +java-object+ '(:public :abstract :interface)))
530
531(defun class-add-field (class field)
532  "Adds a `field' created by `make-field'."
533  (push field (class-file-fields class)))
534
535(defun class-field (class name)
536  "Finds a field by name." ;; ### strictly speaking, a field is uniquely
537  ;; identified by its name and type, not by the name alone.
538  (find name (class-file-fields class)
539        :test #'string= :key #'field-name))
540
541(defun class-add-method (class method)
542  "Adds a `method' to `class'; the method must have been created using
543`make-jvm-method'."
544  (push method (class-file-methods class)))
545
546(defun class-methods-by-name (class name)
547  "Returns all methods which have `name'."
548  (remove (map-method-name name) (class-file-methods class)
549          :test-not #'string= :key #'method-name))
550
551(defun class-method (class name return &rest args)
552  "Return the method which is (uniquely) identified by its name AND descriptor."
553  (let ((return-and-args (cons return args))
554        (name (map-method-name name)))
555    (find-if #'(lambda (c)
556                 (and (string= (method-name c) name)
557                      (equal (method-descriptor c) return-and-args)))
558             (class-file-methods class))))
559
560(defun class-add-attribute (class attribute)
561  "Adds `attribute' to the class; attributes must be instances of
562structure classes which include the `attribute' structure class."
563  (push attribute (class-file-attributes class)))
564
565(defun class-add-superinterface (class interface)
566  "Adds the java-class-name contained in `interface' as a superinterface of the `class'.
567
568For a class that represents an object, the requirements in `interface'
569must then be implemented in the class.  For a class that represents an
570interface, the `interface' imposes additional requirements to the
571classes which implement this class."
572  (push interface (class-file-interfaces class)))
573
574(defun class-attribute (class name)
575  "Returns the attribute which is named `name'."
576  (find name (class-file-attributes class)
577        :test #'string= :key #'attribute-name))
578
579(defun finalize-interfaces (class)
580  "Finalize the interfaces for `class'.
581
582Interface finalization first ensures that all the classes referenced
583by the interfaces members exist in the pool.  Then, it destructively
584modfies the interfaces members with a list of the references to the
585corresponding pool indices."
586  (let ((interface-refs nil))
587    (dolist (interface (class-file-interfaces class))
588      (push 
589       (pool-add-class (class-file-constants class)
590                       interface)
591       interface-refs))
592    (setf (class-file-interfaces class) interface-refs)))
593
594(defun finalize-class-file (class)
595  "Transforms the representation of the class-file from one
596which allows easy modification to one which works best for serialization.
597
598The class can't be modified after finalization."
599
600  ;; constant pool contains constants finalized on addition;
601  ;; no need for additional finalization
602
603  (setf (class-file-access-flags class)
604        (map-flags (class-file-access-flags class)))
605  (setf (class-file-superclass class)
606        (pool-add-class (class-file-constants class)
607                        (class-file-superclass class))
608        (class-file-class class)
609        (pool-add-class (class-file-constants class)
610                        (class-file-class class)))
611  (finalize-interfaces class)
612  (dolist (field (class-file-fields class))
613    (finalize-field field class))
614  (dolist (method (class-file-methods class))
615    (finalize-method method class))
616  ;; top-level attributes (no parent attributes to refer to)
617  (finalize-attributes (class-file-attributes class) nil class))
618
619
620(declaim (inline write-u1 write-u2 write-u4 write-s4))
621(defun write-u1 (n stream)
622  (declare (optimize speed))
623  (declare (type (unsigned-byte 8) n))
624  (declare (type stream stream))
625  (write-8-bits n stream))
626
627(defknown write-u2 (t t) t)
628(defun write-u2 (n stream)
629  (declare (optimize speed))
630  (declare (type (unsigned-byte 16) n))
631  (declare (type stream stream))
632  (write-8-bits (logand (ash n -8) #xFF) stream)
633  (write-8-bits (logand n #xFF) stream))
634
635(defknown write-u4 (integer stream) t)
636(defun write-u4 (n stream)
637  (declare (optimize speed))
638  (declare (type (unsigned-byte 32) n))
639  (write-u2 (logand (ash n -16) #xFFFF) stream)
640  (write-u2 (logand n #xFFFF) stream))
641
642(declaim (ftype (function (t t) t) write-s4))
643(defun write-s4 (n stream)
644  (declare (optimize speed))
645  (cond ((minusp n)
646         (write-u4 (1+ (logxor (- n) #xFFFFFFFF)) stream))
647        (t
648         (write-u4 n stream))))
649
650(declaim (ftype (function (t t t) t) write-ascii))
651(defun write-ascii (string length stream)
652  (declare (type string string))
653  (declare (type (unsigned-byte 16) length))
654  (declare (type stream stream))
655  (write-u2 length stream)
656  (dotimes (i length)
657    (declare (type (unsigned-byte 16) i))
658    (write-8-bits (char-code (char string i)) stream)))
659
660
661(declaim (ftype (function (t t) t) write-utf8))
662(defun write-utf8 (string stream)
663  (declare (optimize speed))
664  (declare (type string string))
665  (declare (type stream stream))
666  (let ((length (length string))
667        (must-convert nil))
668    (declare (type fixnum length))
669    (dotimes (i length)
670      (declare (type fixnum i))
671      (unless (< 0 (char-code (char string i)) #x80)
672        (setf must-convert t)
673        (return)))
674    (if must-convert
675        (let ((octets (make-array (* length 2)
676                                  :element-type '(unsigned-byte 8)
677                                  :adjustable t
678                                  :fill-pointer 0)))
679          (declare (type (vector (unsigned-byte 8)) octets))
680          (dotimes (i length)
681            (declare (type fixnum i))
682            (let* ((c (char string i))
683                   (n (char-code c)))
684              (cond ((zerop n)
685                     (vector-push-extend #xC0 octets)
686                     (vector-push-extend #x80 octets))
687                    ((< 0 n #x80)
688                     (vector-push-extend n octets))
689                    (t
690                     (let ((char-octets (char-to-utf8 c)))
691                       (dotimes (j (length char-octets))
692                         (declare (type fixnum j))
693                         (vector-push-extend (svref char-octets j) octets)))))))
694          (write-u2 (length octets) stream)
695          (dotimes (i (length octets))
696            (declare (type fixnum i))
697            (write-8-bits (aref octets i) stream)))
698        (write-ascii string length stream))))
699
700
701(defun write-class-file (class stream)
702  "Serializes `class' to `stream', after it has been finalized."
703
704  ;; header
705  (write-u4 #xCAFEBABE stream)
706  (write-u2 0 stream)
707  (write-u2 49 stream)  ;; our <clinit> methods use class literals
708  ;; which require a high enough class file format
709  ;; we used to have 45, but the LDC instruction doesn't support
710  ;; class literals in that version... (49 == Java 1.5)
711
712   ;; constants pool
713  (write-constants (class-file-constants class) stream)
714  ;; flags
715  (write-u2  (class-file-access-flags class) stream)
716
717  ;; class name
718  (write-u2 (class-file-class class) stream)
719
720  ;; superclass
721  (write-u2 (class-file-superclass class) stream)
722
723  ;; interfaces
724  (if (class-file-interfaces class)
725      (progn
726        (write-u2 (length (class-file-interfaces class)) stream)
727        (dolist (interface-ref (class-file-interfaces class))
728          (write-u2 interface-ref stream)))
729      (write-u2 0 stream))
730
731  ;; fields
732  (write-u2 (length (class-file-fields class)) stream)
733  (dolist (field (class-file-fields class))
734    (write-field field stream))
735
736  ;; methods
737  (write-u2 (length (class-file-methods class)) stream)
738  (dolist (method (class-file-methods class))
739    (write-method method stream))
740
741  ;; attributes
742  (write-attributes (class-file-attributes class) stream))
743
744
745(defvar *jvm-class-debug-pool* nil
746  "When bound to a non-NIL value, enables output to *standard-output*
747to allow debugging output of the constant section of the class file.")
748
749(defun write-constants (constants stream)
750  "Writes the constant section given in `constants' to the class file `stream'."
751  (let ((pool-index 0))
752    (write-u2 (1+ (pool-index constants)) stream)
753    (when *jvm-class-debug-pool*
754      (sys::%format t "pool count ~A~%" (pool-index constants)))
755    (dolist (entry (reverse (pool-entries-list constants)))
756      (incf pool-index)
757      (let ((tag (constant-tag entry)))
758        (when *jvm-class-debug-pool*
759          (print-constant entry t))
760        (write-u1 tag stream)
761        (case tag
762          (1                            ; UTF8
763           (write-utf8 (constant-utf8-value entry) stream))
764          ((3 4)                        ; float int
765           (write-u4 (constant-float/int-value entry) stream))
766          ((5 6)                        ; long double
767           (write-u4 (logand (ash (constant-double/long-value entry) -32)
768                             #xFFFFffff) stream)
769           (write-u4 (logand (constant-double/long-value entry) #xFFFFffff)
770                     stream))
771          ((9 10 11)           ; fieldref methodref InterfaceMethodref
772           (write-u2 (constant-member-ref-class-index entry) stream)
773           (write-u2 (constant-member-ref-name/type-index entry) stream))
774          (12                           ; nameAndType
775           (write-u2 (constant-name/type-name-index entry) stream)
776           (write-u2 (constant-name/type-descriptor-index entry) stream))
777          (7                            ; class
778           (write-u2 (constant-class-name-index entry) stream))
779          (8                            ; string
780           (write-u2 (constant-string-value-index entry) stream))
781          (t
782           (error "write-constant-pool-entry unhandled tag ~D~%" tag)))))))
783
784
785(defun print-constant (entry stream)
786  "Debugging helper to print the content of a constant-pool entry."
787  (let ((tag (constant-tag entry))
788        (index (constant-index entry)))
789    (sys::%format stream "pool element ~a, tag ~a, " index tag)
790    (case tag
791      (1     (sys::%format t "utf8: ~a~%" (constant-utf8-value entry)))
792      ((3 4) (sys::%format t "f/i: ~a~%" (constant-float/int-value entry)))
793      ((5 6) (sys::%format t "d/l: ~a~%" (constant-double/long-value entry)))
794      ((9 10 11) (sys::%format t "ref: ~a,~a~%"
795                               (constant-member-ref-class-index entry)
796                               (constant-member-ref-name/type-index entry)))
797      (12 (sys::%format t "n/t: ~a,~a~%"
798                        (constant-name/type-name-index entry)
799                        (constant-name/type-descriptor-index entry)))
800      (7 (sys::%format t "cls: ~a~%" (constant-class-name-index entry)))
801      (8 (sys::%format t "str: ~a~%" (constant-string-value-index entry))))))
802
803
804#|
805
806ABCL doesn't use interfaces, so don't implement it here at this time
807
808(defstruct interface)
809
810|#
811
812
813(defparameter +access-flags-map+
814  '((:public       #x0001)
815    (:private      #x0002)
816    (:protected    #x0004)
817    (:static       #x0008)
818    (:final        #x0010)
819    (:volatile     #x0040)
820    (:synchronized #x0020)
821    (:transient    #x0080)
822    (:native       #x0100)
823    (:interface    #x0200)
824    (:abstract     #x0400)
825    (:strict       #x0800))
826  "List of keyword symbols used for human readable representation of (access)
827flags and their binary values.")
828
829(defun map-flags (flags)
830  "Calculates the bitmap of the flags from a list of symbols."
831  (reduce #'(lambda (y x)
832              (logior (or (when (member (car x) flags)
833                            (second x))
834                          0) y))
835          +access-flags-map+
836          :initial-value 0))
837
838(defstruct (field (:constructor %make-field))
839  "Holds information on the properties of fields in the class(-file)."
840  access-flags
841  name
842  descriptor
843  attributes)
844
845(defun make-field (name type &key (flags '(:public)))
846  "Creates a field for addition to a class file."
847  (%make-field :access-flags flags
848               :name name
849               :descriptor type))
850
851(defun field-add-attribute (field attribute)
852  "Adds an attribute to a field."
853  (push attribute (field-attributes field)))
854
855(defun field-attribute (field name)
856  "Retrieves an attribute named `name' of `field'.
857
858Returns NIL if the attribute isn't found."
859  (find name (field-attributes field)
860        :test #'string= :key #'attribute-name))
861
862(defun finalize-field (field class)
863  "Prepares `field' for serialization."
864  (let ((pool (class-file-constants class)))
865    (setf (field-access-flags field)
866          (map-flags (field-access-flags field))
867          (field-descriptor field)
868          (pool-add-utf8 pool (internal-field-ref (field-descriptor field)))
869          (field-name field)
870          (pool-add-utf8 pool (field-name field))))
871  (finalize-attributes (field-attributes field) nil class))
872
873(defun write-field (field stream)
874  "Writes classfile representation of `field' to `stream'."
875  (write-u2 (field-access-flags field) stream)
876  (write-u2 (field-name field) stream)
877  (write-u2 (field-descriptor field) stream)
878  (write-attributes (field-attributes field) stream))
879
880
881(defstruct (jvm-method (:constructor %make-jvm-method)
882           (:conc-name method-))
883  "Holds information on the properties of methods in the class(-file)."
884  access-flags
885  name
886  descriptor
887  attributes)
888
889
890(defun map-method-name (name)
891  "Methods should be identified by strings containing their names, or,
892be one of two keyword identifiers to identify special methods:
893
894 * :static-initializer
895 * :constructor
896"
897  (cond
898    ((eq name :static-initializer)
899     "<clinit>")
900    ((eq name :constructor)
901     "<init>")
902    (t name)))
903
904(defun make-jvm-method (name return args &key (flags '(:public)))
905  "Creates a method for addition to a class file."
906  (%make-jvm-method :descriptor (cons return args)
907        :access-flags flags
908        :name (map-method-name name)))
909
910(defun method-add-attribute (method attribute)
911  "Add `attribute' to the list of attributes of `method',
912returning `attribute'."
913  (push attribute (method-attributes method))
914  attribute)
915
916(defun method-add-code (method &optional (optimize t))
917  "Creates an (empty) 'Code' attribute for the method,
918returning the created attribute."
919  (method-add-attribute
920   method
921   (make-code-attribute (+ (length (cdr (method-descriptor method)))
922                           (if (member :static (method-access-flags method))
923                               0 1)) ;; 1 == implicit 'this'
924      optimize)))
925
926(defun method-ensure-code (method &optional (optimize t))
927  "Ensures the existence of a 'Code' attribute for the method,
928returning the attribute."
929  (let ((code (method-attribute method "Code")))
930    (if (null code)
931        (method-add-code method optimize)
932        code)))
933
934(defun method-attribute (method name)
935  "Returns the first attribute of `method' with `name'."
936  (find name (method-attributes method)
937        :test #'string= :key #'attribute-name))
938
939
940(defun finalize-method (method class)
941  "Prepares `method' for serialization."
942  (let ((pool (class-file-constants class)))
943    (setf (method-access-flags method)
944          (map-flags (method-access-flags method))
945          (method-descriptor method)
946          (pool-add-utf8 pool (apply #'descriptor (method-descriptor method)))
947          (method-name method)
948          (pool-add-utf8 pool (method-name method))))
949  (finalize-attributes (method-attributes method) nil class))
950
951
952(defun write-method (method stream)
953  "Write class file representation of `method' to `stream'."
954  (write-u2 (method-access-flags method) stream)
955  (write-u2 (method-name method) stream)
956  ;;(sys::%format t "method-name: ~a~%" (method-name method))
957  (write-u2 (method-descriptor method) stream)
958  (write-attributes (method-attributes method) stream))
959
960(defstruct attribute
961  "Parent attribute structure to be included into other attributes, mainly
962to define common fields.
963
964Having common fields allows common driver code for
965finalizing and serializing attributes."
966  name
967
968  ;; not in the class file:
969  finalizer  ;; function of 3 arguments: the attribute, parent and class-file
970  writer     ;; function of 2 arguments: the attribute and the output stream
971  )
972
973(defun finalize-attributes (attributes att class)
974  "Prepare `attributes' (a list) of attribute `att' list for serialization."
975  (dolist (attribute attributes)
976    ;; assure header: make sure 'name' is in the pool
977    (setf (attribute-name attribute)
978          (pool-add-utf8 (class-file-constants class)
979                         (attribute-name attribute)))
980    ;; we're saving "root" attributes: attributes which have no parent
981    (funcall (attribute-finalizer attribute) attribute att class)))
982
983(defun write-attributes (attributes stream)
984  "Writes the `attributes' to `stream'."
985  (write-u2 (length attributes) stream)
986  (dolist (attribute attributes)
987    (write-u2 (attribute-name attribute) stream)
988    ;; set up a bulk catcher for (UNSIGNED-BYTE 8)
989    ;; since we need to know the attribute length (excluding the header)
990    (let ((local-stream (sys::%make-byte-array-output-stream)))
991      (funcall (attribute-writer attribute) attribute local-stream)
992      (let ((array (sys::%get-output-stream-array local-stream)))
993        (write-u4 (length array) stream)
994        (write-sequence array stream)))))
995
996
997
998(defstruct (code-attribute (:conc-name code-)
999                           (:include attribute
1000                                     (name "Code")
1001                                     (finalizer #'finalize-code-attribute)
1002                                     (writer #'write-code-attribute))
1003                           (:constructor %make-code-attribute))
1004  "The attribute containing the actual JVM byte code;
1005an attribute of a method."
1006  max-stack
1007  max-locals
1008  code
1009  exception-handlers
1010  attributes
1011
1012  ;; fields not in the class file start here
1013
1014  ;; labels contains offsets into the code array after it's finalized
1015  labels ;; an alist
1016  optimize
1017  (current-local 0)) ;; used for handling nested WITH-CODE-TO-METHOD blocks
1018
1019
1020
1021(defun code-label-offset (code label)
1022  "Retrieves the `label' offset within a `code' attribute after the
1023attribute has been finalized."
1024  (cdr (assoc label (code-labels code))))
1025
1026(defun (setf code-label-offset) (offset code label)
1027  "Sets the `label' offset within a `code' attribute after the attribute
1028has been finalized."
1029  (setf (code-labels code)
1030        (acons label offset (code-labels code))))
1031
1032(defun finalize-code-attribute (code parent class)
1033  "Prepares the `code' attribute for serialization, within method `parent'."
1034  (let* ((handlers (code-exception-handlers code))
1035         (c (finalize-code
1036                     (code-code code)
1037                     (nconc (mapcar #'exception-start-pc handlers)
1038                            (mapcar #'exception-end-pc handlers)
1039                            (mapcar #'exception-handler-pc handlers))
1040                     (code-optimize code))))
1041    (invoke-callbacks :code-finalized class parent
1042                      (coerce c 'list) handlers)
1043    (unless (code-max-stack code)
1044      (setf (code-max-stack code)
1045            (analyze-stack c (mapcar #'exception-handler-pc handlers))))
1046    (unless (code-max-locals code)
1047      (setf (code-max-locals code)
1048            (analyze-locals code)))
1049    (multiple-value-bind
1050          (c labels)
1051        (code-bytes c)
1052      (setf (code-code code) c
1053            (code-labels code) labels)))
1054
1055  (setf (code-exception-handlers code)
1056        (remove-if #'(lambda (h)
1057                       (eql (code-label-offset code (exception-start-pc h))
1058                            (code-label-offset code (exception-end-pc h))))
1059                   (code-exception-handlers code)))
1060
1061  (dolist (exception (code-exception-handlers code))
1062    (setf (exception-start-pc exception)
1063          (code-label-offset code (exception-start-pc exception))
1064          (exception-end-pc exception)
1065          (code-label-offset code (exception-end-pc exception))
1066          (exception-handler-pc exception)
1067          (code-label-offset code (exception-handler-pc exception))
1068          (exception-catch-type exception)
1069          (if (null (exception-catch-type exception))
1070              0  ;; generic 'catch all' class index number
1071              (pool-add-class (class-file-constants class)
1072                              (exception-catch-type exception)))))
1073
1074  (finalize-attributes (code-attributes code) code class))
1075
1076(defun write-code-attribute (code stream)
1077  "Writes the attribute `code' to `stream'."
1078  ;;(sys::%format t "max-stack: ~a~%" (code-max-stack code))
1079  (write-u2 (code-max-stack code) stream)
1080  ;;(sys::%format t "max-locals: ~a~%" (code-max-locals code))
1081  (write-u2 (code-max-locals code) stream)
1082  (let ((code-array (code-code code)))
1083    ;;(sys::%format t "length: ~a~%" (length code-array))
1084    (write-u4 (length code-array) stream)
1085    (dotimes (i (length code-array))
1086      (write-u1 (svref code-array i) stream)))
1087
1088  (write-u2 (length (code-exception-handlers code)) stream)
1089  (dolist (exception (reverse (code-exception-handlers code)))
1090    ;;(sys::%format t "start-pc: ~a~%" (exception-start-pc exception))
1091    (write-u2 (exception-start-pc exception) stream)
1092    ;;(sys::%format t "end-pc: ~a~%" (exception-end-pc exception))
1093    (write-u2 (exception-end-pc exception) stream)
1094    ;;(sys::%format t "handler-pc: ~a~%" (exception-handler-pc exception))
1095    (write-u2 (exception-handler-pc exception) stream)
1096    (write-u2 (exception-catch-type exception) stream))
1097
1098  (write-attributes (code-attributes code) stream))
1099
1100(defun make-code-attribute (arg-count &optional optimize)
1101  "Creates an empty 'Code' attribute for a method which takes
1102`arg-count` parameters, including the implicit `this` parameter."
1103  (%make-code-attribute :max-locals arg-count :optimize optimize))
1104
1105(defun code-add-attribute (code attribute)
1106  "Adds `attribute' to `code', returning `attribute'."
1107  (push attribute (code-attributes code))
1108  attribute)
1109
1110(defun code-attribute (code name)
1111  "Returns an attribute of `code' identified by `name'."
1112  (find name (code-attributes code)
1113        :test #'string= :key #'attribute-name))
1114
1115
1116(defun code-add-exception-handler (code start end handler type)
1117  "Adds an exception handler to `code' protecting the region from
1118labels `start' to `end' (inclusive) from exception `type' - where
1119a value of NIL indicates all types. Upon an exception of the given
1120type, control is transferred to label `handler'."
1121  (push (make-exception :start-pc start
1122                        :end-pc end
1123                        :handler-pc handler
1124                        :catch-type type)
1125        (code-exception-handlers code)))
1126
1127(defstruct exception
1128  "Exception handler information.
1129
1130After finalization, the fields contain offsets instead of labels."
1131  start-pc    ;; label target
1132  end-pc      ;; label target
1133  handler-pc  ;; label target
1134  catch-type  ;; a string for a specific type, or NIL for all
1135  )
1136
1137
1138(defstruct (constant-value-attribute (:conc-name constant-value-)
1139                                     (:include attribute
1140                                               (name "ConstantValue")
1141                                               ;; finalizer
1142                                               ;; writer
1143                                               ))
1144  "An attribute of a field of primitive type.
1145
1146"
1147  ;;; ### TODO
1148  )
1149
1150
1151(defstruct (checked-exceptions-attribute
1152             (:conc-name checked-)
1153             (:include attribute
1154                       (name "Exceptions")
1155                       (finalizer #'finalize-checked-exceptions)
1156                       (writer #'write-checked-exceptions)))
1157  "An attribute of `code-attribute', "
1158  table ;; a list of checked classes corresponding to Java's 'throws'
1159)
1160
1161(defun finalize-checked-exceptions (checked-exceptions code class)
1162  (declare (ignorable code class))
1163
1164  "Prepare `checked-exceptions' for serialization."
1165  (setf (checked-table checked-exceptions)
1166        (mapcar #'(lambda (exception)
1167                    (pool-add-class (class-file-constants class)
1168                                    exception))
1169                (checked-table checked-exceptions))))
1170
1171(defun write-checked-exceptions (checked-exceptions stream)
1172  "Write `checked-exceptions' to `stream' in class file representation."
1173  (write-u2 (length (checked-table checked-exceptions)) stream)
1174  (dolist (exception (reverse (checked-table checked-exceptions)))
1175    (write-u2 exception stream)))
1176
1177;; Can't be used yet: serialization missing
1178(defstruct (deprecated-attribute (:include attribute
1179                                           (name "Deprecated")
1180                                           (finalizer (constantly nil))
1181                                           (writer (constantly nil))))
1182  ;; finalizer and writer need to do nothing: Deprecated attributes are empty
1183  "An attribute of a class file, field or method, indicating the element
1184to which it has been attached has been superseded.")
1185
1186(defvar *current-code-attribute* nil)
1187(defvar *method*)
1188
1189(defun save-code-specials (code)
1190  (setf (code-code code) *code*
1191        (code-max-locals code) *registers-allocated*
1192        (code-current-local code) *register*))
1193
1194(defun restore-code-specials (code)
1195  (setf *code* (code-code code)
1196        *registers-allocated* (code-max-locals code)
1197        *register* (code-current-local code)))
1198
1199(defmacro with-code-to-method ((class-file method)
1200                               &body body)
1201  (let ((m (gensym))
1202        (c (gensym)))
1203    `(progn
1204       (when *current-code-attribute*
1205         (save-code-specials *current-code-attribute*))
1206       (unwind-protect
1207           (let* ((,m ,method)
1208                  (*method* ,m)
1209                  (,c (method-ensure-code ,method))
1210                  (*pool* (class-file-constants ,class-file))
1211                  (*code* (code-code ,c))
1212                  (*registers-allocated* (code-max-locals ,c))
1213                  (*register* (code-current-local ,c))
1214                  (*current-code-attribute* ,c))
1215             (unwind-protect
1216                 ,@body
1217               ;; in case of a RETURN-FROM or GO, save the current state
1218               (setf (code-code ,c) *code*
1219                     (code-current-local ,c) *register*
1220                     (code-max-locals ,c) *registers-allocated*)))
1221         ;; using the same line of reasoning, restore the outer-scope state
1222         (when *current-code-attribute*
1223           (restore-code-specials *current-code-attribute*))))))
1224
1225
1226(defstruct (source-file-attribute (:conc-name source-)
1227                                  (:include attribute
1228                                            (name "SourceFile")
1229                                            (finalizer #'finalize-source-file)
1230                                            (writer #'write-source-file)))
1231  "An attribute of the class file indicating which source file
1232it was compiled from."
1233  filename)
1234
1235(defun finalize-source-file (source-file code class)
1236  (declare (ignorable code class))
1237  (setf (source-filename source-file)
1238        (pool-add-utf8 (class-file-constants class)
1239                       (source-filename source-file))))
1240
1241(defun write-source-file (source-file stream)
1242  (write-u2 (source-filename source-file) stream))
1243
1244
1245(defstruct (synthetic-attribute (:include attribute
1246                                          (name "Synthetic")
1247                                          (finalizer (constantly nil))
1248                                          (writer (constantly nil))))
1249  ;; finalizer and writer need to do nothing: Synthetic attributes are empty
1250  "An attribute of a class file, field or method to mark that it wasn't
1251included in the sources - but was generated artificially.")
1252
1253
1254(defstruct (line-numbers-attribute
1255             (:conc-name line-numbers-)
1256             (:include attribute
1257                       (name "LineNumberTable")
1258                       (finalizer #'finalize-line-numbers)
1259                       (writer #'write-line-numbers)))
1260  "An attribute of `code-attribute', containing a mapping of offsets
1261within the code section to the line numbers in the source file."
1262  table ;; a list of line-number structures, in reverse order
1263  )
1264
1265(defstruct line-number
1266  start-pc  ;; a label, before finalization, or 0 for "start of function"
1267  line)
1268
1269(defun finalize-line-numbers (line-numbers code class)
1270  (declare (ignorable code class))
1271  (dolist (line-number (line-numbers-table line-numbers))
1272    (unless (zerop (line-number-start-pc line-number))
1273      (setf (line-number-start-pc line-number)
1274            (code-label-offset code (line-number-start-pc line-number))))))
1275
1276(defun write-line-numbers (line-numbers stream)
1277  (write-u2 (length (line-numbers-table line-numbers)) stream)
1278  (dolist (line-number (reverse (line-numbers-table line-numbers)))
1279    (write-u2 (line-number-start-pc line-number) stream)
1280    (write-u2 (line-number-line line-number) stream)))
1281
1282(defun line-numbers-add-line (line-numbers start-pc line)
1283  (push (make-line-number :start-pc start-pc :line line)
1284        (line-numbers-table line-numbers)))
1285
1286(defstruct (local-variables-attribute
1287             (:conc-name local-var-)
1288             (:include attribute
1289                       (name "LocalVariableTable")
1290                       (finalizer #'finalize-local-variables)
1291                       (writer #'write-local-variables)))
1292  "An attribute of the `code-attribute', containing a table of local variable
1293names, their type and their scope of validity."
1294  table ;; a list of local-variable structures, in reverse order
1295  )
1296
1297(defstruct (local-variable (:conc-name local-))
1298  start-pc  ;; a label, before finalization
1299  length    ;; a label (at the ending position) before finalization
1300  name
1301  descriptor
1302  index ;; The index of the variable inside the block of locals
1303  )
1304
1305(defun finalize-local-variables (local-variables code class)
1306  (dolist (local-variable (local-var-table local-variables))
1307    (setf (local-start-pc local-variable)
1308          (code-label-offset code (local-start-pc local-variable))
1309          (local-length local-variable)
1310          ;; calculate 'length' from the distance between 2 labels
1311          (- (code-label-offset code (local-length local-variable))
1312             (local-start-pc local-variable))
1313          (local-name local-variable)
1314          (pool-add-utf8 (class-file-constants class)
1315                         (local-name local-variable))
1316          (local-descriptor local-variable)
1317          (pool-add-utf8 (class-file-constants class)
1318                         (local-descriptor local-variable)))))
1319
1320(defun write-local-variables (local-variables stream)
1321  (write-u2 (length (local-var-table local-variables)) stream)
1322  (dolist (local-variable (reverse (local-var-table local-variables)))
1323    (write-u2 (local-start-pc local-variable) stream)
1324    (write-u2 (local-length local-variable) stream)
1325    (write-u2 (local-name local-variable) stream)
1326    (write-u2 (local-descriptor local-variable) stream)
1327    (write-u2 (local-index local-variable) stream)))
1328
1329;;Annotations
1330
1331(defstruct (annotations-attribute
1332             (:conc-name annotations-)
1333             (:include attribute
1334                       ;;Name is to be provided by subtypes
1335                       (finalizer #'finalize-annotations)
1336                       (writer #'write-annotations)))
1337  "An attribute of a class, method or field, containing a list of annotations.
1338This structure serves as the abstract supertype of concrete annotations types."
1339  list ;; a list of annotation structures, in reverse order
1340  )
1341
1342(defstruct annotation
1343  "Each value of the annotations table represents a single runtime-visible annotation on a program element.
1344   The annotation structure has the following format:
1345     annotation {
1346       u2 type_index;
1347       u2 num_element_value_pairs;
1348       {
1349         u2 element_name_index;
1350         element_value value;
1351       } element_value_pairs[num_element_value_pairs]
1352     }"
1353  type
1354  elements)
1355
1356(defstruct annotation-element (name "value") tag finalizer writer)
1357
1358(defstruct (primitive-or-string-annotation-element
1359             (:include annotation-element
1360                       (finalizer (lambda (self class)
1361                                    (let ((value (primitive-or-string-annotation-element-value self)))
1362                                      (etypecase value
1363                                        (boolean
1364                                         (setf (annotation-element-tag self)
1365                                               (char-code #\Z)
1366                                               (primitive-or-string-annotation-element-value self)
1367                                               (pool-add-int (class-file-constants class) (if value 1 0))))
1368                                        (character
1369                                         (setf (annotation-element-tag self)
1370                                               (char-code #\C)
1371                                               (primitive-or-string-annotation-element-value self)
1372                                               (pool-add-int (class-file-constants class) (char-code value))))
1373                                        (fixnum
1374                                         (setf (annotation-element-tag self)
1375                                               (char-code #\I)
1376                                               (primitive-or-string-annotation-element-value self)
1377                                               (pool-add-int (class-file-constants class) value)))
1378                                        (integer
1379                                         (setf (annotation-element-tag self)
1380                                               (char-code #\J)
1381                                               (primitive-or-string-annotation-element-value self)
1382                                               (pool-add-long (class-file-constants class) value)))
1383                                        (double-float
1384                                         (setf (annotation-element-tag self)
1385                                               (char-code #\D)
1386                                               (primitive-or-string-annotation-element-value self)
1387                                               (pool-add-double (class-file-constants class) value)))
1388                                        (single-float
1389                                         (setf (annotation-element-tag self)
1390                                               (char-code #\F)
1391                                               (primitive-or-string-annotation-element-value self)
1392                                               (pool-add-float (class-file-constants class) value)))
1393                                        (string
1394                                         (setf (annotation-element-tag self)
1395                                               (char-code #\s)
1396                                               (primitive-or-string-annotation-element-value self)
1397                                               (pool-add-utf8 (class-file-constants class) value)))))))
1398                       (writer (lambda (self stream)
1399                                 (write-u1 (annotation-element-tag self) stream)
1400                                 (write-u2 (primitive-or-string-annotation-element-value self) stream)))))
1401  value)
1402
1403(defstruct (enum-value-annotation-element
1404             (:include annotation-element
1405                       (tag (char-code #\e))
1406                       (finalizer (lambda (self class)
1407                                    (setf (enum-value-annotation-element-type self)
1408                                          (pool-add-utf8 (class-file-constants class)
1409                                                         (enum-value-annotation-element-type self)) ;;Binary name as string
1410                                          (enum-value-annotation-element-value self)
1411                                          (pool-add-utf8 (class-file-constants class)
1412                                                         (enum-value-annotation-element-value self)))))
1413                       (writer (lambda (self stream)
1414                                 (write-u1 (annotation-element-tag self) stream)
1415                                 (write-u2 (enum-value-annotation-element-type self) stream)
1416                                 (write-u2 (enum-value-annotation-element-value self) stream)))))
1417  type
1418  value)
1419
1420(defstruct (annotation-value-annotation-element
1421             (:include annotation-element
1422                       (tag (char-code #\@))
1423                       (finalizer (lambda (self class)
1424                                    (finalize-annotation (annotation-value-annotation-element-value self) class)))
1425                       (writer (lambda (self stream)
1426                                 (write-u1 (annotation-element-tag self) stream)
1427                                 (write-annotation (annotation-value-annotation-element-value self) stream)))))
1428  value)
1429
1430(defstruct (array-annotation-element
1431             (:include annotation-element
1432                       (tag (char-code #\[))
1433                       (finalizer (lambda (self class)
1434                                    (dolist (elem (array-annotation-element-values self))
1435                                      (finalize-annotation-element elem class))))
1436                       (writer (lambda (self stream)
1437                                 (write-u1 (annotation-element-tag self) stream)
1438                                 (write-u2 (length (array-annotation-element-values self)) stream)
1439                                 (dolist (elem (array-annotation-element-values self))
1440                                   (write-annotation-element elem stream))))))
1441  values) ;;In proper order
1442
1443(defstruct (runtime-visible-annotations-attribute
1444             (:include annotations-attribute
1445                       (name "RuntimeVisibleAnnotations")))
1446  "4.8.15 The RuntimeVisibleAnnotations attribute
1447The RuntimeVisibleAnnotations attribute is a variable length attribute in the
1448attributes table of the ClassFile, field_info, and method_info structures. The
1449RuntimeVisibleAnnotations attribute records runtime-visible Java program-
1450ming language annotations on the corresponding class, method, or field. Each
1451ClassFile, field_info, and method_info structure may contain at most one
1452RuntimeVisibleAnnotations attribute, which records all the runtime-visible
1453Java programming language annotations on the corresponding program element.
1454The JVM must make these annotations available so they can be returned by the
1455appropriate reflective APIs.")
1456
1457(defun finalize-annotations (annotations code class)
1458  (declare (ignore code))
1459  (dolist (ann (annotations-list annotations))
1460    (finalize-annotation ann class)))
1461
1462(defun finalize-annotation (ann class)
1463  (setf (annotation-type ann)
1464        (pool-add-class (class-file-constants class) (annotation-type ann)))
1465  (dolist (elem (annotation-elements ann))
1466    (finalize-annotation-element elem class)))
1467
1468(defun finalize-annotation-element (elem class)
1469  (when (annotation-element-name elem)
1470    (setf (annotation-element-name elem)
1471          (pool-add-utf8 (class-file-constants class)
1472                         (annotation-element-name elem))))
1473  (funcall (annotation-element-finalizer elem)
1474           elem class))
1475
1476(defun write-annotations (annotations stream)
1477  (write-u2 (length (annotations-list annotations)) stream)
1478  (dolist (annotation (reverse (annotations-list annotations)))
1479    (write-annotation annotation stream)))
1480
1481(defun write-annotation (annotation stream)
1482  (write-u2 (annotation-type annotation) stream)
1483  (write-u2 (length (annotation-elements annotation)) stream)
1484  (dolist (elem (reverse (annotation-elements annotation)))
1485    (write-annotation-element elem stream)))
1486
1487(defun write-annotation-element (elem stream)
1488  (when (annotation-element-name elem)
1489    (write-u2 (annotation-element-name elem) stream))
1490  (funcall (annotation-element-writer elem)
1491           elem stream))
1492
1493#|
1494
1495;; this is the minimal sequence we need to support:
1496
1497;;  create a class file structure
1498;;  add methods
1499;;  add code to the methods, switching from one method to the other
1500;;  finalize the methods, one by one
1501;;  write the class file
1502
1503to support the sequence above, we probably need to
1504be able to
1505
1506- find methods by signature
1507- find the method's code attribute
1508- add code to the code attribute
1509- finalize the code attribute contents (blocking it for further addition)
1510-
1511
1512
1513|#
1514
1515(provide '#:jvm-class-file)
Note: See TracBrowser for help on using the repository browser.