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

Last change on this file since 13850 was 13850, checked in by ehuelsmann, 10 years ago

Remove Closure.fastProcessArgs(): it's concept has been abstracted away
in ArgumentListProcessor?.

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