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

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

[invokedynamic] Instruction effects are simulated at code resolving time, not emit time.
Stack map frames not yet emitted: compilation fails early.
More consistency in how constant indexes are handled.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 58.3 KB
Line 
1;;; jvm-class-file.lisp
2;;;
3;;; Copyright (C) 2010 Erik Huelsmann
4;;; $Id: jvm-class-file.lisp 12984 2010-10-30 00:15:58Z 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    ;(sys::%format t "descriptor ~S ~S -> ~S~%" return-type argument-types str)
233    str)
234;;  (format nil "(~{~A~})~A"
235;;          (internal-field-ref return-type))
236  )
237
238(defun descriptor-stack-effect (return-type &rest argument-types)
239  "Returns the effect on the stack position of the `argument-types' and
240`return-type' of a method call.
241
242If the method consumes an implicit `this' argument, this function does not
243take that effect into account."
244  (flet ((type-stack-effect (arg)
245           (case arg
246             ((:long :double) 2)
247             ((nil :void) 0)
248             (otherwise 1))))
249    (+ (reduce #'- argument-types
250               :key #'type-stack-effect
251               :initial-value 0)
252       (type-stack-effect return-type))))
253
254
255(defstruct pool
256  ;; `index' contains the index of the last allocated slot (0 == empty)
257  ;; "A constant pool entry is considered valid if it has
258  ;; an index greater than 0 (zero) and less than pool-count"
259  (index 0)
260  entries-list
261  ;; the entries hash stores raw values, except in case of string and
262  ;; utf8, because both are string values
263  (entries (make-hash-table :test #'equal :size 2048 :rehash-size 2.0)))
264
265
266(defstruct constant
267  "Structure to be included in all constant sub-types."
268  tag
269  index)
270
271(defparameter +constant-type-map+
272  '((:class          7 1)
273    (:field-ref      9 1)
274    (:method-ref    10 1)
275    ;; (:interface-method-ref 11)
276    (:string         8 1)
277    (:integer        3 1)
278    (:float          4 1)
279    (:long           5 2)
280    (:double         6 2)
281    (:name-and-type 12 1)
282    (:utf8           1 1)))
283
284(defun constant-type (constant)
285  (car (find (constant-tag constant) +constant-type-map+ :key #'cadr)))
286
287(defstruct (constant-class (:constructor make-constant-class (index name-index))
288                           (:include constant
289                                     (tag 7)))
290  "Structure holding information on a 'class' type item in the constant pool."
291  name-index)
292
293(defstruct (constant-member-ref (:constructor
294                                 %make-constant-member-ref
295                                     (tag index class name/type))
296                                (:include constant))
297  "Structure holding information on a member reference type item
298(a field, method or interface method reference) in the constant pool."
299  class
300  name/type)
301
302(declaim (inline make-constant-field-ref make-constant-method-ref
303                 make-constant-interface-method-ref))
304(defun make-constant-field-ref (index class name/type)
305  "Creates a `constant-member-ref' instance containing a field reference."
306  (%make-constant-member-ref 9 index class name/type))
307
308(defun make-constant-method-ref (index class name/type)
309  "Creates a `constant-member-ref' instance containing a method reference."
310  (%make-constant-member-ref 10 index class name/type))
311
312(defun make-constant-interface-method-ref (index class name/type)
313  "Creates a `constant-member-ref' instance containing an
314interface-method reference."
315  (%make-constant-member-ref 11 index class name/type))
316
317(defstruct (constant-string (:constructor
318                             make-constant-string (index value-index))
319                            (:include constant
320                                      (tag 8)))
321  "Structure holding information on a 'string' type item in the constant pool."
322  value-index)
323
324(defstruct (constant-float/int (:constructor
325                                %make-constant-float/int (tag index value))
326                               (:include constant))
327  "Structure holding information on a 'float' or 'integer' type item
328in the constant pool."
329  value)
330
331(declaim (inline make-constant-float make-constant-int))
332(defun make-constant-float (index value)
333  "Creates a `constant-float/int' structure instance containing a float."
334  (%make-constant-float/int 4 index value))
335
336(defun make-constant-int (index value)
337  "Creates a `constant-float/int' structure instance containing an int."
338  (%make-constant-float/int 3 index value))
339
340(defstruct (constant-double/long (:constructor
341                                  %make-constant-double/long (tag index value))
342                                 (:include constant))
343  "Structure holding information on a 'double' or 'long' type item
344in the constant pool."
345  value)
346
347(declaim (inline make-constant-double make-constant-float))
348(defun make-constant-double (index value)
349  "Creates a `constant-double/long' structure instance containing a double."
350  (%make-constant-double/long 6 index value))
351
352(defun make-constant-long (index value)
353  "Creates a `constant-double/long' structure instance containing a long."
354  (%make-constant-double/long 5 index value))
355
356(defstruct (constant-name/type (:constructor
357                                make-constant-name/type (index
358                                                         name
359               type
360                                                         descriptor))
361                               (:include constant
362                                         (tag 12)))
363  "Structure holding information on a 'name-and-type' type item in the
364constant pool; this type of element is used by 'member-ref' type items."
365  name
366  type
367  descriptor)
368
369(defstruct (constant-utf8 (:constructor make-constant-utf8 (index value))
370                          (:include constant
371                                    (tag 1)))
372  "Structure holding information on a 'utf8' type item in the constant pool;
373
374This type of item is used for text representation of identifiers
375and string contents."
376  value)
377
378
379(defun pool-add-class (pool class)
380  "Returns the constant-pool class item for `class'.
381
382`class' must be an instance of `class-name'."
383  (let ((entry (gethash class (pool-entries pool))))
384    (unless entry
385      (let ((utf8 (constant-index (pool-add-utf8 pool (class-name-internal class)))))
386        (setf entry
387              (make-constant-class (incf (pool-index pool)) utf8)
388              (gethash class (pool-entries pool)) entry))
389      (push entry (pool-entries-list pool)))
390    entry))
391
392(defun pool-add-field-ref (pool class name type)
393  "Returns the constant-pool item which denotes a reference
394to the `name' field of the `class', being of `type'.
395
396`class' should be an instance of `class-name'.
397`name' is a string.
398`type' is a field-type (see `internal-field-type')"
399  (let ((entry (gethash (acons name type class) (pool-entries pool))))
400    (unless entry
401      (let ((c (pool-add-class pool class))
402            (n/t (pool-add-name/type pool name type)))
403        (setf entry (make-constant-field-ref (incf (pool-index pool)) c n/t)
404            (gethash (acons name type class) (pool-entries pool)) entry))
405      (push entry (pool-entries-list pool)))
406    entry))
407
408(defun pool-add-method-ref (pool class name type)
409  "Returns the constant-pool item which denotes a reference
410to the method with `name' in `class', which is of `type'.
411
412Here, `type' is a method descriptor, which defines the argument types
413and return type. `class' is an instance of `class-name'."
414  (let ((entry (gethash (acons name type class) (pool-entries pool))))
415    (unless entry
416      (let ((c (pool-add-class pool class))
417            (n/t (pool-add-name/type pool name type)))
418        (setf entry (make-constant-method-ref (incf (pool-index pool)) c n/t)
419              (gethash (acons name type class) (pool-entries pool)) entry))
420      (push entry (pool-entries-list pool)))
421    entry))
422
423(defun pool-add-interface-method-ref (pool class name type)
424  "Returns the constant-pool item which denotes a reference to
425the method `name' in the interface `class', which is of `type'.
426
427See `pool-add-method-ref' for remarks."
428  (let ((entry (gethash (acons name type class) (pool-entries pool))))
429    (unless entry
430      (let ((c (pool-add-class pool class))
431            (n/t (pool-add-name/type pool name type)))
432        (setf entry
433            (make-constant-interface-method-ref (incf (pool-index pool)) c n/t)
434            (gethash (acons name type class) (pool-entries pool)) entry))
435      (push entry (pool-entries-list pool)))
436    entry))
437
438(defun pool-add-string (pool string)
439  "Returns the constant-pool item denoting the string."
440  (let ((entry (gethash (cons 8 string) ;; 8 == string-tag
441                        (pool-entries pool))))
442    (unless entry
443      (let ((utf8 (pool-add-utf8 pool string)))
444        (setf entry (make-constant-string (incf (pool-index pool))
445            (constant-index utf8))
446              (gethash (cons 8 string) (pool-entries pool)) entry))
447      (push entry (pool-entries-list pool)))
448    entry))
449
450(defun pool-add-int (pool int)
451  "Returns the constant-pool item denoting the int."
452  (let ((entry (gethash (cons 3 int) (pool-entries pool))))
453    (unless entry
454      (setf entry (make-constant-int (incf (pool-index pool)) int)
455            (gethash (cons 3 int) (pool-entries pool)) entry)
456      (push entry (pool-entries-list pool)))
457    entry))
458
459(defun pool-add-float (pool float)
460  "Returns the constant-pool item denoting the float."
461  (let ((entry (gethash (cons 4 float) (pool-entries pool))))
462    (unless entry
463      (setf entry (make-constant-float (incf (pool-index pool))
464                                       (sys::%float-bits float))
465            (gethash (cons 4 float) (pool-entries pool)) entry)
466      (push entry (pool-entries-list pool)))
467    entry))
468
469(defun pool-add-long (pool long)
470  "Returns the constant-pool item denoting the long."
471  (let ((entry (gethash (cons 5 long) (pool-entries pool))))
472    (unless entry
473      (setf entry (make-constant-long (incf (pool-index pool)) long)
474            (gethash (cons 5 long) (pool-entries pool)) entry)
475      (push entry (pool-entries-list pool))
476      (incf (pool-index pool))) ;; double index increase; long takes 2 slots
477    entry))
478
479(defun pool-add-double (pool double)
480  "Returns constant-pool item denoting the double."
481  (let ((entry (gethash (cons 6 double) (pool-entries pool))))
482    (unless entry
483      (setf entry (make-constant-double (incf (pool-index pool))
484                                        (sys::%float-bits double))
485            (gethash (cons 6 double) (pool-entries pool)) entry)
486      (push entry (pool-entries-list pool))
487      (incf (pool-index pool))) ;; double index increase; 'double' takes 2 slots
488    entry))
489
490(defun pool-add-name/type (pool name type)
491  "Returns the constant-pool item denoting the name/type identifier."
492  (let ((entry (gethash (cons name type) (pool-entries pool)))
493        (internal-type (if (listp type)
494                           (apply #'descriptor type)
495                           (internal-field-ref type))))
496    (unless entry
497      (let ((n (pool-add-utf8 pool name))
498            (i-t (pool-add-utf8 pool internal-type)))
499        (setf entry (make-constant-name/type
500         (incf (pool-index pool)) n type i-t)
501              (gethash (cons name type) (pool-entries pool)) entry))
502      (push entry (pool-entries-list pool)))
503    entry))
504
505(defun pool-add-utf8 (pool utf8-as-string)
506  "Returns the textual value that will be stored in the class file as UTF-8 encoded data."
507  (let ((entry (gethash (cons 11 utf8-as-string) ;; 11 == utf8
508                        (pool-entries pool))))
509    (unless entry
510      (setf entry (make-constant-utf8 (incf (pool-index pool)) utf8-as-string)
511            (gethash (cons 11 utf8-as-string) (pool-entries pool)) entry)
512      (push entry (pool-entries-list pool)))
513    entry))
514
515(defstruct (class-file (:constructor
516                        make-class-file (class superclass access-flags)))
517  "Holds the components of a class file."
518  (constants (make-pool))
519  (major-version 51)
520  (minor-version 0)
521  access-flags
522  class
523  superclass
524  ;; support for implementing interfaces not yet available
525  ;; interfaces
526  fields
527  methods
528  attributes)
529
530(defun class-add-field (class field)
531  "Adds a `field' created by `make-field'."
532  (push field (class-file-fields class)))
533
534(defun class-field (class name)
535  "Finds a field by name." ;; ### strictly speaking, a field is uniquely
536  ;; identified by its name and type, not by the name alone.
537  (find name (class-file-fields class)
538        :test #'string= :key #'field-name))
539
540(defun class-add-method (class method)
541  "Adds a `method' to `class'; the method must have been created using
542`make-method'."
543  (push method (class-file-methods class)))
544
545(defun class-methods-by-name (class name)
546  "Returns all methods which have `name'."
547  (remove (map-method-name name) (class-file-methods class)
548          :test-not #'string= :key #'method-name))
549
550(defun class-method (class name return &rest args)
551  "Return the method which is (uniquely) identified by its name AND descriptor."
552  (let ((return-and-args (cons return args))
553        (name (map-method-name name)))
554    (find-if #'(lambda (c)
555                 (and (string= (method-name c) name)
556                      (equal (method-descriptor c) return-and-args)))
557             (class-file-methods class))))
558
559(defun class-add-attribute (class attribute)
560  "Adds `attribute' to the class; attributes must be instances of
561structure classes which include the `attribute' structure class."
562  (push attribute (class-file-attributes class)))
563
564(defun class-attribute (class name)
565  "Returns the attribute which is named `name'."
566  (find name (class-file-attributes class)
567        :test #'string= :key #'attribute-name))
568
569
570(defun finalize-class-file (class)
571  "Transforms the representation of the class-file from one
572which allows easy modification to one which works best for serialization.
573
574The class can't be modified after finalization."
575
576  ;; constant pool contains constants finalized on addition;
577  ;; no need for additional finalization
578
579  (setf (class-file-access-flags class)
580        (map-flags (class-file-access-flags class)))
581  (setf (class-file-superclass class)
582        (constant-index (pool-add-class (class-file-constants class)
583          (class-file-superclass class)))
584        (class-file-class class)
585        (constant-index (pool-add-class (class-file-constants class)
586          (class-file-class class))))
587  ;;  (finalize-interfaces)
588  (dolist (field (class-file-fields class))
589    (finalize-field field class))
590  (dolist (method (class-file-methods class))
591    (finalize-method method class))
592  ;; top-level attributes (no parent attributes to refer to)
593  (finalize-attributes (class-file-attributes class) nil class))
594
595
596(declaim (inline write-u1 write-u2 write-u4 write-s4))
597(defun write-u1 (n stream)
598  (declare (optimize speed))
599  (declare (type (unsigned-byte 8) n))
600  (declare (type stream stream))
601  (write-8-bits n stream))
602
603(defknown write-u2 (t t) t)
604(defun write-u2 (n stream)
605  (declare (optimize speed))
606  (declare (type (unsigned-byte 16) n))
607  (declare (type stream stream))
608  (write-8-bits (logand (ash n -8) #xFF) stream)
609  (write-8-bits (logand n #xFF) stream))
610
611(defknown write-u4 (integer stream) t)
612(defun write-u4 (n stream)
613  (declare (optimize speed))
614  (declare (type (unsigned-byte 32) n))
615  (write-u2 (logand (ash n -16) #xFFFF) stream)
616  (write-u2 (logand n #xFFFF) stream))
617
618(declaim (ftype (function (t t) t) write-s4))
619(defun write-s4 (n stream)
620  (declare (optimize speed))
621  (cond ((minusp n)
622         (write-u4 (1+ (logxor (- n) #xFFFFFFFF)) stream))
623        (t
624         (write-u4 n stream))))
625
626(declaim (ftype (function (t t t) t) write-ascii))
627(defun write-ascii (string length stream)
628  (declare (type string string))
629  (declare (type (unsigned-byte 16) length))
630  (declare (type stream stream))
631  (write-u2 length stream)
632  (dotimes (i length)
633    (declare (type (unsigned-byte 16) i))
634    (write-8-bits (char-code (char string i)) stream)))
635
636
637(declaim (ftype (function (t t) t) write-utf8))
638(defun write-utf8 (string stream)
639  (declare (optimize speed))
640  (declare (type string string))
641  (declare (type stream stream))
642  (let ((length (length string))
643        (must-convert nil))
644    (declare (type fixnum length))
645    (dotimes (i length)
646      (declare (type fixnum i))
647      (unless (< 0 (char-code (char string i)) #x80)
648        (setf must-convert t)
649        (return)))
650    (if must-convert
651        (let ((octets (make-array (* length 2)
652                                  :element-type '(unsigned-byte 8)
653                                  :adjustable t
654                                  :fill-pointer 0)))
655          (declare (type (vector (unsigned-byte 8)) octets))
656          (dotimes (i length)
657            (declare (type fixnum i))
658            (let* ((c (char string i))
659                   (n (char-code c)))
660              (cond ((zerop n)
661                     (vector-push-extend #xC0 octets)
662                     (vector-push-extend #x80 octets))
663                    ((< 0 n #x80)
664                     (vector-push-extend n octets))
665                    (t
666                     (let ((char-octets (char-to-utf8 c)))
667                       (dotimes (j (length char-octets))
668                         (declare (type fixnum j))
669                         (vector-push-extend (svref char-octets j) octets)))))))
670          (write-u2 (length octets) stream)
671          (dotimes (i (length octets))
672            (declare (type fixnum i))
673            (write-8-bits (aref octets i) stream)))
674        (write-ascii string length stream))))
675
676
677(defun write-class-file (class stream)
678  "Serializes `class' to `stream', after it has been finalized."
679
680  ;; header
681  (write-u4 #xCAFEBABE stream)
682  (write-u2 (class-file-minor-version class) stream)
683  (write-u2 (class-file-major-version class) stream)
684
685   ;; constants pool
686  (write-constants (class-file-constants class) stream)
687  ;; flags
688  (write-u2  (class-file-access-flags class) stream)
689
690  ;; class name
691  (write-u2 (class-file-class class) stream)
692
693  ;; superclass
694  (write-u2 (class-file-superclass class) stream)
695
696  ;; interfaces
697  (write-u2 0 stream)
698
699  ;; fields
700  (write-u2 (length (class-file-fields class)) stream)
701  (dolist (field (class-file-fields class))
702    (write-field field stream))
703
704  ;; methods
705  (write-u2 (length (class-file-methods class)) stream)
706  (dolist (method (class-file-methods class))
707    (write-method method stream))
708
709  ;; attributes
710  (write-attributes (class-file-attributes class) stream))
711
712
713(defvar *jvm-class-debug-pool* nil
714  "When bound to a non-NIL value, enables output to *standard-output*
715to allow debugging output of the constant section of the class file.")
716
717(defun write-constants (constants stream)
718  "Writes the constant section given in `constants' to the class file `stream'."
719  (let ((pool-index 0))
720    (write-u2 (1+ (pool-index constants)) stream)
721    (when *jvm-class-debug-pool*
722      (sys::%format t "pool count ~A~%" (pool-index constants)))
723    (dolist (entry (reverse (pool-entries-list constants)))
724      (incf pool-index)
725      (let ((tag (constant-tag entry)))
726        (when *jvm-class-debug-pool*
727          (print-constant entry t))
728        (write-u1 tag stream)
729        (case tag
730          (1                            ; UTF8
731           (write-utf8 (constant-utf8-value entry) stream))
732          ((3 4)                        ; float int
733           (write-u4 (constant-float/int-value entry) stream))
734          ((5 6)                        ; long double
735           (write-u4 (logand (ash (constant-double/long-value entry) -32)
736                             #xFFFFffff) stream)
737           (write-u4 (logand (constant-double/long-value entry) #xFFFFffff)
738                     stream))
739          ((9 10 11)           ; fieldref methodref InterfaceMethodref
740           (write-u2 (constant-index (constant-member-ref-class entry)) stream)
741           (write-u2 (constant-index (constant-member-ref-name/type entry)) stream))
742          (12                           ; nameAndType
743           (write-u2 (constant-index (constant-name/type-name entry)) stream)
744           (write-u2 (constant-index (constant-name/type-descriptor entry)) stream))
745          (7                            ; class
746           (write-u2 (constant-class-name-index entry) stream))
747          (8                            ; string
748           (write-u2 (constant-string-value-index entry) stream))
749          (t
750           (error "write-constant-pool-entry unhandled tag ~D~%" tag)))))))
751
752
753(defun print-constant (entry stream)
754  "Debugging helper to print the content of a constant-pool entry."
755  (let ((tag (constant-tag entry))
756        (index (constant-index entry)))
757    (sys::%format stream "pool element ~a, tag ~a, " index tag)
758    (case tag
759      (1     (sys::%format t "utf8: ~a~%" (constant-utf8-value entry)))
760      ((3 4) (sys::%format t "f/i: ~a~%" (constant-float/int-value entry)))
761      ((5 6) (sys::%format t "d/l: ~a~%" (constant-double/long-value entry)))
762      ((9 10 11) (sys::%format t "ref: ~a,~a~%"
763                               (constant-member-ref-class entry)
764                               (constant-member-ref-name/type entry)))
765      (12 (sys::%format t "n/t: ~a,~a~%"
766                        (constant-name/type-name entry)
767                        (constant-name/type-descriptor entry)))
768      (7 (sys::%format t "cls: ~a~%" (constant-class-name-index entry)))
769      (8 (sys::%format t "str: ~a~%" (constant-string-value-index entry))))))
770
771
772#|
773
774ABCL doesn't use interfaces, so don't implement it here at this time
775
776(defstruct interface)
777
778|#
779
780
781(defparameter +access-flags-map+
782  '((:public       #x0001)
783    (:private      #x0002)
784    (:protected    #x0004)
785    (:static       #x0008)
786    (:final        #x0010)
787    (:volatile     #x0040)
788    (:synchronized #x0020)
789    (:transient    #x0080)
790    (:native       #x0100)
791    (:abstract     #x0400)
792    (:strict       #x0800))
793  "List of keyword symbols used for human readable representation of (access)
794flags and their binary values.")
795
796(defun map-flags (flags)
797  "Calculates the bitmap of the flags from a list of symbols."
798  (reduce #'(lambda (y x)
799              (logior (or (when (member (car x) flags)
800                            (second x))
801                          0) y))
802          +access-flags-map+
803          :initial-value 0))
804
805(defstruct (field (:constructor %make-field))
806  "Holds information on the properties of fields in the class(-file)."
807  access-flags
808  name
809  descriptor
810  attributes)
811
812(defun make-field (name type &key (flags '(:public)))
813  "Creates a field for addition to a class file."
814  (%make-field :access-flags flags
815               :name name
816               :descriptor type))
817
818(defun field-add-attribute (field attribute)
819  "Adds an attribute to a field."
820  (push attribute (field-attributes field)))
821
822(defun field-attribute (field name)
823  "Retrieves an attribute named `name' of `field'.
824
825Returns NIL if the attribute isn't found."
826  (find name (field-attributes field)
827        :test #'string= :key #'attribute-name))
828
829(defun finalize-field (field class)
830  "Prepares `field' for serialization."
831  (let ((pool (class-file-constants class)))
832    (setf (field-access-flags field)
833          (map-flags (field-access-flags field))
834          (field-descriptor field)
835          (constant-index (pool-add-utf8 pool (internal-field-ref (field-descriptor field))))
836          (field-name field)
837          (constant-index (pool-add-utf8 pool (field-name field)))))
838  (finalize-attributes (field-attributes field) nil class))
839
840(defun write-field (field stream)
841  "Writes classfile representation of `field' to `stream'."
842  (write-u2 (field-access-flags field) stream)
843  (write-u2 (field-name field) stream)
844  (write-u2 (field-descriptor field) stream)
845  (write-attributes (field-attributes field) stream))
846
847
848(defstruct (method (:constructor %make-method)
849                   (:conc-name method-))
850  "Holds information on the properties of methods in the class(-file)."
851  access-flags
852  name
853  descriptor
854  attributes)
855
856
857(defun map-method-name (name)
858  "Methods should be identified by strings containing their names, or,
859be one of two keyword identifiers to identify special methods:
860
861 * :static-initializer
862 * :constructor
863"
864  (cond
865    ((eq name :static-initializer)
866     "<clinit>")
867    ((eq name :constructor)
868     "<init>")
869    (t name)))
870
871(defun make-method (name return args &key (flags '(:public)))
872  "Creates a method for addition to a class file."
873  (%make-method :descriptor (cons return args)
874                :access-flags flags
875                :name (map-method-name name)))
876
877(defun method-add-attribute (method attribute)
878  "Add `attribute' to the list of attributes of `method',
879returning `attribute'."
880  (push attribute (method-attributes method))
881  attribute)
882
883(defun method-add-code (method)
884  "Creates an (empty) 'Code' attribute for the method,
885returning the created attribute."
886  (method-add-attribute
887   method
888   (make-code-attribute (compute-initial-method-locals method))))
889
890(defun method-ensure-code (method)
891  "Ensures the existence of a 'Code' attribute for the method,
892returning the attribute."
893  (let ((code (method-attribute method "Code")))
894    (if (null code)
895        (method-add-code method)
896        code)))
897
898(defun method-attribute (method name)
899  "Returns the first attribute of `method' with `name'."
900  (find name (method-attributes method)
901        :test #'string= :key #'attribute-name))
902
903
904(defun finalize-method (method class)
905  "Prepares `method' for serialization."
906  (let ((pool (class-file-constants class)))
907    (setf (method-access-flags method)
908          (map-flags (method-access-flags method))
909          (method-descriptor method)
910          (constant-index (pool-add-utf8 pool (apply #'descriptor (method-descriptor method))))
911          (method-name method)
912          (constant-index (pool-add-utf8 pool (method-name method)))))
913    (finalize-attributes (method-attributes method) method class))
914
915
916(defun write-method (method stream)
917  "Write class file representation of `method' to `stream'."
918  (write-u2 (method-access-flags method) stream)
919  (write-u2 (method-name method) stream)
920  ;;(sys::%format t "method-name: ~a~%" (method-name method))
921  (write-u2 (method-descriptor method) stream)
922  (write-attributes (method-attributes method) stream))
923
924(defstruct attribute
925  "Parent attribute structure to be included into other attributes, mainly
926to define common fields.
927
928Having common fields allows common driver code for
929finalizing and serializing attributes."
930  name
931
932  ;; not in the class file:
933  finalizer  ;; function of 3 arguments: the attribute, parent and class-file
934  writer     ;; function of 2 arguments: the attribute and the output stream
935  )
936
937(defun finalize-attributes (attributes att class)
938  "Prepare `attributes' (a list) of attribute `att' list for serialization."
939  (dolist (attribute attributes)
940    ;; assure header: make sure 'name' is in the pool
941    (setf (attribute-name attribute)
942          (constant-index (pool-add-utf8 (class-file-constants class)
943           (attribute-name attribute))))
944    ;; we're saving "root" attributes: attributes which have no parent
945    (funcall (attribute-finalizer attribute) attribute att class)))
946
947(defun write-attributes (attributes stream)
948  "Writes the `attributes' to `stream'."
949  (write-u2 (length attributes) stream)
950  (dolist (attribute attributes)
951    (write-u2 (attribute-name attribute) stream)
952    ;; set up a bulk catcher for (UNSIGNED-BYTE 8)
953    ;; since we need to know the attribute length (excluding the header)
954    (let ((local-stream (sys::%make-byte-array-output-stream)))
955      (funcall (attribute-writer attribute) attribute local-stream)
956      (let ((array (sys::%get-output-stream-array local-stream)))
957        (write-u4 (length array) stream)
958        (write-sequence array stream)))))
959
960
961
962(defstruct (code-attribute (:conc-name code-)
963                           (:include attribute
964                                     (name "Code")
965                                     (finalizer #'finalize-code-attribute)
966                                     (writer #'write-code-attribute))
967                           (:constructor %make-code-attribute))
968  "The attribute containing the actual JVM byte code;
969an attribute of a method."
970  max-stack
971  max-locals
972  code
973  exception-handlers
974  attributes
975
976  ;; fields not in the class file start here
977
978  ;; labels contains offsets into the code array after it's finalized
979  labels ;; an alist
980
981  ;; these are used for handling nested WITH-CODE-TO-METHOD blocks
982  (current-local 0)
983  computed-locals)
984
985
986
987(defun code-label-offset (code label)
988  "Retrieves the `label' offset within a `code' attribute after the
989attribute has been finalized."
990  (cdr (assoc label (code-labels code))))
991
992(defun (setf code-label-offset) (offset code label)
993  "Sets the `label' offset within a `code' attribute after the attribute
994has been finalized."
995  (setf (code-labels code)
996        (acons label offset (code-labels code))))
997
998(defun finalize-code-attribute (code parent class)
999  "Prepares the `code' attribute for serialization, within method `parent'."
1000  (let* ((handlers (code-exception-handlers code))
1001         (c (finalize-code
1002                     (code-code code)
1003                     (nconc (mapcar #'exception-start-pc handlers)
1004                            (mapcar #'exception-end-pc handlers)
1005                            (mapcar #'exception-handler-pc handlers))
1006                     t))
1007   (compute-stack-map-table-p (>= (class-file-major-version class) 50)))
1008    (unless (code-max-stack code)
1009      (setf (code-max-stack code)
1010            (analyze-stack c (mapcar #'exception-handler-pc handlers))))
1011    (unless (code-max-locals code)
1012      (setf (code-max-locals code)
1013            (analyze-locals code)))
1014    (multiple-value-bind
1015          (c labels stack-map-table)
1016        (resolve-code code c class parent compute-stack-map-table-p)
1017      (setf (code-code code) c
1018            (code-labels code) labels)
1019      (when compute-stack-map-table-p
1020  #+todo (code-add-attribute code stack-map-table))))
1021
1022  (setf (code-exception-handlers code)
1023        (remove-if #'(lambda (h)
1024                       (eql (code-label-offset code (exception-start-pc h))
1025                            (code-label-offset code (exception-end-pc h))))
1026                   (code-exception-handlers code)))
1027
1028  (dolist (exception (code-exception-handlers code))
1029    (setf (exception-start-pc exception)
1030          (code-label-offset code (exception-start-pc exception))
1031          (exception-end-pc exception)
1032          (code-label-offset code (exception-end-pc exception))
1033          (exception-handler-pc exception)
1034          (code-label-offset code (exception-handler-pc exception))
1035          (exception-catch-type exception)
1036          (if (null (exception-catch-type exception))
1037              0  ;; generic 'catch all' class index number
1038              (constant-index (pool-add-class (class-file-constants class)
1039                (exception-catch-type exception))))))
1040
1041  (finalize-attributes (code-attributes code) code class))
1042
1043(defun write-code-attribute (code stream)
1044  "Writes the attribute `code' to `stream'."
1045  ;;(sys::%format t "max-stack: ~a~%" (code-max-stack code))
1046  (write-u2 (code-max-stack code) stream)
1047  ;;(sys::%format t "max-locals: ~a~%" (code-max-locals code))
1048  (write-u2 (code-max-locals code) stream)
1049  (let ((code-array (code-code code)))
1050    ;;(sys::%format t "length: ~a~%" (length code-array))
1051    (write-u4 (length code-array) stream)
1052    (dotimes (i (length code-array))
1053      (write-u1 (svref code-array i) stream)))
1054
1055  (write-u2 (length (code-exception-handlers code)) stream)
1056  (dolist (exception (reverse (code-exception-handlers code)))
1057    ;;(sys::%format t "start-pc: ~a~%" (exception-start-pc exception))
1058    (write-u2 (exception-start-pc exception) stream)
1059    ;;(sys::%format t "end-pc: ~a~%" (exception-end-pc exception))
1060    (write-u2 (exception-end-pc exception) stream)
1061    ;;(sys::%format t "handler-pc: ~a~%" (exception-handler-pc exception))
1062    (write-u2 (exception-handler-pc exception) stream)
1063    (write-u2 (exception-catch-type exception) stream))
1064
1065  (write-attributes (code-attributes code) stream))
1066
1067(defun make-code-attribute (locals)
1068  "Creates an empty 'Code' attribute for a method which takes
1069`arg-count` parameters, including the implicit `this` parameter."
1070  (%make-code-attribute :max-locals (length locals)
1071      :computed-locals locals))
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-attr 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   (computing-stack-map-table compute-stack-map-table-p)
1102   (*code-locals* (code-computed-locals code-attr))
1103   *code-stack*)
1104#||  (*basic-block* (when compute-stack-map-table-p
1105        (make-basic-block
1106         :offset 0
1107         :input-locals
1108         (method-initial-locals method))))
1109   (root-block *basic-block*)
1110   *basic-blocks*)||#
1111    (declare (type (unsigned-byte 16) length))
1112    ;; Pass 1: calculate label offsets and overall length and, if
1113    ;; compute-stack-map-table-p is true, also simulate the effect of the
1114    ;; instructions on the stack and locals.
1115    (dotimes (i (length code))
1116      (declare (type (unsigned-byte 16) i))
1117      (let* ((instruction (aref code i))
1118             (opcode (instruction-opcode instruction)))
1119  (setf (instruction-offset instruction) length)
1120  ;;(sys::format t "simulating instruction ~S ~S stack ~S locals ~S ~%"
1121  ;;opcode (mapcar #'type-of (instruction-args instruction))
1122  ;;(length *code-stack*) (length *code-locals*))
1123  (if computing-stack-map-table
1124      (progn
1125        (when (= opcode 202) ;;label: simulate a jump
1126    (record-jump-to-label (car (instruction-args instruction))))
1127        (simulate-instruction-effect instruction)
1128        ;;Simulation must be stopped if we encounter a goto, it will be
1129        ;;resumed by the next label that is the target of a jump
1130        (setf computing-stack-map-table (not (unconditional-jump-p opcode))))
1131      (when (and (= opcode 202) ; LABEL
1132           (get (first (instruction-args instruction))
1133          'jump-target-p))
1134        (simulate-instruction-effect instruction)
1135        (setf computing-stack-map-table t)))
1136        (if (= opcode 202) ; LABEL
1137            (let ((label (car (instruction-args instruction))))
1138              (set label length)
1139              (setf labels
1140                    (acons label length labels)))
1141      (incf length (opcode-size opcode)))))
1142    ;; Pass 2: replace labels with calculated offsets.
1143    (let ((index 0))
1144      (declare (type (unsigned-byte 16) index))
1145      (dotimes (i (length code))
1146        (declare (type (unsigned-byte 16) i))
1147        (let ((instruction (aref code i)))
1148          (when (branch-p (instruction-opcode instruction))
1149            (let* ((label (car (instruction-args instruction)))
1150                   (offset (- (the (unsigned-byte 16)
1151                                (symbol-value (the symbol label)))
1152                              index)))
1153        (unless (get label 'jump-target-p)
1154    (sys::%format "error - label not target of a jump ~S~%" label))
1155              (setf (instruction-args instruction) (s2 offset))))
1156          (unless (= (instruction-opcode instruction) 202) ; LABEL
1157            (incf index (opcode-size (instruction-opcode instruction)))))))
1158    ;; Expand instructions into bytes, skipping LABEL pseudo-instructions.
1159    (let ((bytes (make-array length))
1160          (index 0))
1161      (declare (type (unsigned-byte 16) index))
1162      (dotimes (i (length code))
1163        (declare (type (unsigned-byte 16) i))
1164        (let ((instruction (aref code i)))
1165          (unless (= (instruction-opcode instruction) 202) ; LABEL
1166            (setf (svref bytes index) (instruction-opcode instruction))
1167            (incf index)
1168            (dolist (arg (instruction-args instruction))
1169        (if (constant-p arg)
1170      (let ((idx (constant-index arg))
1171      (opcode (instruction-opcode instruction)))
1172        ;;(sys::%format t "constant ~A ~A index-size ~A index ~A~%" (type-of arg) idx (constant-index-size arg) index)
1173        (if (or (<= 178 opcode 187)
1174          (= opcode 189)
1175          (= opcode 192)
1176          (= opcode 193))
1177      (let ((idx (u2 idx)))
1178        (setf (svref bytes index) (car idx)
1179        (svref bytes (1+ index)) (cadr idx))
1180        (incf index 2))
1181      (progn
1182        (setf (svref bytes index) idx)
1183        (incf index))))
1184      (progn
1185        (setf (svref bytes index) arg)
1186        (incf index)))))))
1187      (sys::%format t "~%~%~%BYTES ~S~%~%~%" bytes)
1188      (values bytes labels stack-map-table))))
1189
1190(defun unconditional-jump-p (opcode)
1191  (= opcode 167))
1192
1193(defstruct exception
1194  "Exception handler information.
1195
1196After finalization, the fields contain offsets instead of labels."
1197  start-pc    ;; label target
1198  end-pc      ;; label target
1199  handler-pc  ;; label target
1200  catch-type  ;; a string for a specific type, or NIL for all
1201  )
1202
1203
1204(defstruct (constant-value-attribute (:conc-name constant-value-)
1205                                     (:include attribute
1206                                               (name "ConstantValue")
1207                                               ;; finalizer
1208                                               ;; writer
1209                                               ))
1210  "An attribute of a field of primitive type.
1211
1212"
1213  ;;; ### TODO
1214  )
1215
1216
1217(defstruct (checked-exceptions-attribute
1218             (:conc-name checked-)
1219             (:include attribute
1220                       (name "Exceptions")
1221                       (finalizer #'finalize-checked-exceptions)
1222                       (writer #'write-checked-exceptions)))
1223  "An attribute of `code-attribute', "
1224  table ;; a list of checked classes corresponding to Java's 'throws'
1225)
1226
1227(defun finalize-checked-exceptions (checked-exceptions code class)
1228  (declare (ignorable code class))
1229
1230  "Prepare `checked-exceptions' for serialization."
1231  (setf (checked-table checked-exceptions)
1232        (mapcar #'(lambda (exception)
1233                    (constant-index (pool-add-class (class-file-constants class)
1234                exception)))
1235                (checked-table checked-exceptions))))
1236
1237(defun write-checked-exceptions (checked-exceptions stream)
1238  "Write `checked-exceptions' to `stream' in class file representation."
1239  (write-u2 (length (checked-table checked-exceptions)) stream)
1240  (dolist (exception (reverse (checked-table checked-exceptions)))
1241    (write-u2 exception stream)))
1242
1243;; Can't be used yet: serialization missing
1244(defstruct (deprecated-attribute (:include attribute
1245                                           (name "Deprecated")
1246                                           (finalizer (constantly nil))
1247                                           (writer (constantly nil))))
1248  ;; finalizer and writer need to do nothing: Deprecated attributes are empty
1249  "An attribute of a class file, field or method, indicating the element
1250to which it has been attached has been superseded.")
1251
1252(defvar *current-code-attribute* nil)
1253(defvar *method* nil)
1254
1255(defun save-code-specials (code)
1256  (setf (code-code code) *code*
1257        (code-max-locals code) *registers-allocated*
1258        (code-current-local code) *register*))
1259
1260(defun restore-code-specials (code)
1261  (setf *code* (code-code code)
1262        *registers-allocated* (code-max-locals code)
1263        *register* (code-current-local code)))
1264
1265(defmacro with-code-to-method ((class-file method)
1266                               &body body)
1267  (let ((m (gensym))
1268        (c (gensym)))
1269    `(progn
1270       (when *current-code-attribute*
1271         (save-code-specials *current-code-attribute*))
1272       (let* ((,m ,method)
1273        (*method* ,m)
1274              (,c (method-ensure-code ,method))
1275              (*pool* (class-file-constants ,class-file))
1276              (*code* (code-code ,c))
1277              (*registers-allocated* (code-max-locals ,c))
1278              (*register* (code-current-local ,c))
1279              (*current-code-attribute* ,c))
1280         ,@body
1281         (setf (code-code ,c) *code*
1282               (code-current-local ,c) *register*
1283               (code-max-locals ,c) *registers-allocated*))
1284       (when *current-code-attribute*
1285         (restore-code-specials *current-code-attribute*)))))
1286
1287
1288(defstruct (source-file-attribute (:conc-name source-)
1289                                  (:include attribute
1290                                            (name "SourceFile")
1291                                            (finalizer #'finalize-source-file)
1292                                            (writer #'write-source-file)))
1293  "An attribute of the class file indicating which source file
1294it was compiled from."
1295  filename)
1296
1297(defun finalize-source-file (source-file code class)
1298  (declare (ignorable code class))
1299  (setf (source-filename source-file)
1300        (constant-index (pool-add-utf8 (class-file-constants class)
1301               (source-filename source-file)))))
1302
1303(defun write-source-file (source-file stream)
1304  (write-u2 (source-filename source-file) stream))
1305
1306
1307(defstruct (synthetic-attribute (:include attribute
1308                                          (name "Synthetic")
1309                                          (finalizer (constantly nil))
1310                                          (writer (constantly nil))))
1311  ;; finalizer and writer need to do nothing: Synthetic attributes are empty
1312  "An attribute of a class file, field or method to mark that it wasn't
1313included in the sources - but was generated artificially.")
1314
1315
1316(defstruct (line-numbers-attribute
1317             (:conc-name line-numbers-)
1318             (:include attribute
1319                       (name "LineNumberTable")
1320                       (finalizer #'finalize-line-numbers)
1321                       (writer #'write-line-numbers)))
1322  "An attribute of `code-attribute', containing a mapping of offsets
1323within the code section to the line numbers in the source file."
1324  table ;; a list of line-number structures, in reverse order
1325  )
1326
1327(defstruct line-number
1328  start-pc  ;; a label, before finalization, or 0 for "start of function"
1329  line)
1330
1331(defun finalize-line-numbers (line-numbers code class)
1332  (declare (ignorable code class))
1333  (dolist (line-number (line-numbers-table line-numbers))
1334    (unless (zerop (line-number-start-pc line-number))
1335      (setf (line-number-start-pc line-number)
1336            (code-label-offset code (line-number-start-pc line-number))))))
1337
1338(defun write-line-numbers (line-numbers stream)
1339  (write-u2 (length (line-numbers-table line-numbers)) stream)
1340  (dolist (line-number (reverse (line-numbers-table line-numbers)))
1341    (write-u2 (line-number-start-pc line-number) stream)
1342    (write-u2 (line-number-line line-number) stream)))
1343
1344(defun line-numbers-add-line (line-numbers start-pc line)
1345  (push (make-line-number :start-pc start-pc :line line)
1346        (line-numbers-table line-numbers)))
1347
1348(defstruct (local-variables-attribute
1349             (:conc-name local-var-)
1350             (:include attribute
1351                       (name "LocalVariableTable")
1352                       (finalizer #'finalize-local-variables)
1353                       (writer #'write-local-variables)))
1354  "An attribute of the `code-attribute', containing a table of local variable
1355names, their type and their scope of validity."
1356  table ;; a list of local-variable structures, in reverse order
1357  )
1358
1359(defstruct (local-variable (:conc-name local-))
1360  start-pc  ;; a label, before finalization
1361  length    ;; a label (at the ending position) before finalization
1362  name
1363  descriptor
1364  index ;; The index of the variable inside the block of locals
1365  )
1366
1367(defun finalize-local-variables (local-variables code class)
1368  (dolist (local-variable (local-var-table local-variables))
1369    (setf (local-start-pc local-variable)
1370          (code-label-offset code (local-start-pc local-variable))
1371          (local-length local-variable)
1372          ;; calculate 'length' from the distance between 2 labels
1373          (- (code-label-offset code (local-length local-variable))
1374             (local-start-pc local-variable))
1375          (local-name local-variable)
1376          (constant-index (pool-add-utf8 (class-file-constants class)
1377           (local-name local-variable)))
1378          (local-descriptor local-variable)
1379          (constant-index (pool-add-utf8 (class-file-constants class)
1380           (local-descriptor local-variable))))))
1381
1382(defun write-local-variables (local-variables stream)
1383  (write-u2 (length (local-var-table local-variables)) stream)
1384  (dolist (local-variable (reverse (local-var-table local-variables)))
1385    (write-u2 (local-start-pc local-variable) stream)
1386    (write-u2 (local-length local-variable) stream)
1387    (write-u2 (local-name local-variable) stream)
1388    (write-u2 (local-descriptor local-variable) stream)
1389    (write-u2 (local-index local-variable) stream)))
1390
1391;;Support for the StackMapTable attribute used by the typechecking verifier
1392;;from class file version number 50.0 onward (astalla)
1393
1394(defstruct (stack-map-table-attribute
1395       (:conc-name stack-map-table-)
1396       (:include attribute
1397           (name "StackMapTable")
1398           (finalizer #'finalize-stack-map-table-attribute)
1399           (writer #'write-stack-map-table-attribute)))
1400       ;(:constructor %make-stack-map-table-attribute))
1401  "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."
1402  entries)
1403
1404(defun add-stack-map-frame (stack-map-table instruction-offset locals
1405          stack-items)
1406  (error "TODO!"))
1407
1408(defun finalize-stack-map-table-attribute (table parent class)
1409  "Prepares the `stack-map-table' attribute for serialization, within method `parent': replaces all virtual types in the stack map frames with variable-info objects."
1410  (declare (ignore parent class)) ;;TODO
1411  table)
1412
1413(defun write-stack-map-table-attribute (table stream)
1414  (write-u2 (length (stack-map-table-entries table)) stream)
1415  (dolist (frame (stack-map-table-entries table))
1416    (funcall (frame-writer frame) stream)))
1417
1418(defstruct (stack-map-frame (:conc-name frame-))
1419  offset-delta
1420  writer)
1421
1422(defstruct (stack-map-full-frame
1423       (:conc-name full-frame-)
1424       (:include stack-map-frame
1425           (writer #'write-stack-map-full-frame)))
1426  locals
1427  stack-items)
1428
1429(defun write-stack-map-full-frame (frame stream)
1430  (write-u1 255 stream)
1431  (write-u2 (frame-offset-delta frame) stream)
1432  (write-u2 (length (full-frame-locals frame)) stream)
1433  (dolist (local (full-frame-locals frame))
1434    (funcall (verification-type-info-writer local) local stream))
1435  (write-u2 (length (full-frame-stack-items frame)) stream)
1436  (dolist (stack-item (full-frame-stack-items frame))
1437    (funcall (verification-type-info-writer stack-item) stack-item stream)))
1438
1439(defstruct verification-type-info tag (writer #'write-simple-verification-type-info))
1440
1441(defstruct (top-variable-info (:include verification-type-info (tag 0))))
1442(defstruct (integer-variable-info (:include verification-type-info (tag 1))))
1443(defstruct (float-variable-info (:include verification-type-info (tag 2))))
1444(defstruct (double-variable-info (:include verification-type-info (tag 3))))
1445(defstruct (long-variable-info (:include verification-type-info (tag 4))))
1446(defstruct (null-variable-info (:include verification-type-info (tag 5))))
1447(defstruct (uninitialized-this-variable-info (:include verification-type-info (tag 6))))
1448(defstruct (object-variable-info
1449       (:include verification-type-info
1450           (tag 7) (writer #'write-object-variable-info)))
1451  constant-pool-index)
1452(defstruct (uninitialized-variable-info
1453       (:include verification-type-info
1454           (tag 8) (writer #'write-unitialized-variable-info)))
1455  offset)
1456
1457(defun write-simple-verification-type-info (vti stream)
1458  (write-u1 (verification-type-info-tag vti) stream))
1459(defun write-object-variable-type-info (vti stream)
1460  (write-u1 (verification-type-info-tag vti) stream)
1461  (write-u2 (object-variable-info-constant-pool-index vti) stream))
1462(defun write-uninitialized-verification-type-info (vti stream)
1463  (write-u1 (verification-type-info-tag vti) stream)
1464  (write-u2 (uninitialized-variable-info-offset vti) stream))
1465
1466(defun compute-initial-method-locals (method)
1467  (let (locals)
1468    (unless (member :static (method-access-flags method))
1469      (if (string= "<init>" (method-name method))
1470    ;;the method is a constructor.
1471    (push :uninitialized-this locals)
1472    ;;the method is an instance method.
1473    (push :this locals)))
1474    (dolist (x (cdr (method-descriptor method)))
1475      (push x locals))
1476    (nreverse locals)))
1477
1478(defun smf-type->variable-info (type)
1479  :todo)
1480
1481#|
1482
1483;; this is the minimal sequence we need to support:
1484
1485;;  create a class file structure
1486;;  add methods
1487;;  add code to the methods, switching from one method to the other
1488;;  finalize the methods, one by one
1489;;  write the class file
1490
1491to support the sequence above, we probably need to
1492be able to
1493
1494- find methods by signature
1495- find the method's code attribute
1496- add code to the code attribute
1497- finalize the code attribute contents (blocking it for further addition)
1498-
1499
1500
1501|#
1502
Note: See TracBrowser for help on using the repository browser.