source: branches/streams/abcl/src/org/armedbear/lisp/jvm-class-file.lisp

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

Inline calls to jrun-exception-protected
(used by handler-bind to catch out of memory conditions).

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