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

Last change on this file since 13739 was 13739, checked in by astalla, 9 years ago

Annotations in class-file:

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