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

Last change on this file since 13849 was 13849, checked in by ehuelsmann, 12 years ago

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