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

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

Rename writeToString() to printObject() since that's what it's being used for.
Additionally, create princToString() for use in error messages, making the

required replacement where appropriate.

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