source: branches/1.1.x/src/org/armedbear/lisp/jvm-class-file.lisp

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

Don't generate empty static initializers.

Note: Given that this commit shrinks our JAR by more than 3k

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