source: branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-class-file.lisp @ 12980

Last change on this file since 12980 was 12980, checked in by astalla, 11 years ago

[invokedynamic branch] Save current state of affairs before revolutionizing it.

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