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

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

generic-class-file branch merged.

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