source: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp @ 12786

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

First step of integration of CLASS-NAME structure in pass2.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 33.3 KB
Line 
1;;; jvm-class-file.lisp
2;;;
3;;; Copyright (C) 2010 Erik Huelsmann
4;;; $Id: jvm-class-file.lisp 12786 2010-07-06 21:24:56Z ehuelsmann $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32(in-package "JVM")
33
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  name-internal
86  ref
87  array-ref)
88
89(defun make-class-name (name)
90  "Creates a `class-name' structure for the class or interface `name'.
91
92`name' should be specified using Java representation, which is converted
93to 'internal' (JVM) representation by this function."
94  (setf name (substitute #\/ #\. name))
95  (%make-class-name :name-internal name
96                    :ref (concatenate 'string "L" name ";")
97                    :array-ref (concatenate 'string "[L" name ";")))
98
99(defmacro define-class-name (symbol java-dotted-name &optional documentation)
100  "Convenience macro to define constants for `class-name' structures,
101initialized from the `java-dotted-name'."
102  `(defconstant ,symbol (make-class-name ,java-dotted-name)
103     ,documentation))
104
105(define-class-name +java-object+ "java.lang.Object")
106(define-class-name +java-string+ "java.lang.String")
107(define-class-name +!lisp-object+ "org.armedbear.lisp.LispObject")
108(define-class-name +!lisp-simple-string+ "org.armedbear.lisp.SimpleString")
109(define-class-name +lisp+ "org.armedbear.lisp.Lisp")
110(define-class-name +lisp-nil+ "org.armedbear.lisp.Nil")
111(define-class-name +!lisp-class+ "org.armedbear.lisp.LispClass")
112(define-class-name +!lisp-symbol+ "org.armedbear.lisp.Symbol")
113(define-class-name +!lisp-thread+ "org.armedbear.lisp.LispThread")
114(define-class-name +!lisp-closure-binding+ "org.armedbear.lisp.ClosureBinding")
115(define-class-name +!lisp-integer+ "org.armedbear.lisp.Integer")
116(define-class-name +!lisp-fixnum+ "org.armedbear.lisp.Fixnum")
117(define-class-name +!lisp-bignum+ "org.armedbear.lisp.Bignum")
118(define-class-name +!lisp-single-float+ "org.armedbear.lisp.SingleFloat")
119(define-class-name +!lisp-double-float+ "org.armedbear.lisp.DoubleFloat")
120(define-class-name +!lisp-cons+ "org.armedbear.lisp.Cons")
121(define-class-name +!lisp-load+ "org.armedbear.lisp.Load")
122(define-class-name +!lisp-character+ "org.armedbear.lisp.Character")
123(define-class-name +!lisp-simple-vector+ "org.armedbear.lisp.SimpleVector")
124(define-class-name +!lisp-abstract-string+ "org.armedbear.lisp.AbstractString")
125(define-class-name +!lisp-abstract-vector+ "org.armedbear.lisp.AbstractVector")
126(define-class-name +!lisp-abstract-bit-vector+
127    "org.armedbear.lisp.AbstractBitVector")
128(define-class-name +!lisp-environment+ "org.armedbear.lisp.Environment")
129(define-class-name +!lisp-special-binding+ "org.armedbear.lisp.SpecialBinding")
130(define-class-name +!lisp-special-binding-mark+
131    "org.armedbear.lisp.SpecialBindingMark")
132(define-class-name +!lisp-throw+ "org.armedbear.lisp.Throw")
133(define-class-name +!lisp-return+ "org.armedbear.lisp.Return")
134(define-class-name +!lisp-go+ "org.armedbear.lisp.Go")
135(define-class-name +!lisp-primitive+ "org.armedbear.lisp.Primitive")
136(define-class-name +!lisp-compiled-closure+
137    "org.armedbear.lisp.CompiledClosure")
138(define-class-name +!lisp-eql-hash-table+ "org.armedbear.lisp.EqlHashTable")
139(define-class-name +!lisp-package+ "org.armedbear.lisp.Package")
140(define-class-name +!lisp-readtable+ "org.armedbear.lisp.Readtable")
141(define-class-name +!lisp-stream+ "org.armedbear.lisp.Stream")
142(define-class-name +!lisp-closure+ "org.armedbear.lisp.Closure")
143(define-class-name +!lisp-closure-parameter+
144    "org.armedbear.lisp.Closure$Parameter")
145(define-class-name +!fasl-loader+ "org.armedbear.lisp.FaslClassLoader")
146
147#|
148
149Lisp-side descriptor representation:
150
151 - list: a list starting with a method return value, followed by
152     the argument types
153 - keyword: the primitive type associated with that keyword
154 - class-name structure instance: the class-ref value
155
156The latter two can be converted to a Java representation using
157the `internal-field-ref' function, the former is to be fed to
158`descriptor'.
159
160|#
161
162(defun internal-field-type (field-type)
163  "Returns a string containing the JVM-internal representation
164of `field-type', which should either be a symbol identifying a primitive
165type, or a `class-name' structure identifying a class or interface."
166  (if (symbolp field-type)
167      (map-primitive-type field-type)
168      (class-name-internal field-type)))
169
170(defun internal-field-ref (field-type)
171  "Returns a string containing the JVM-internal representation of a reference
172to `field-type', which should either be a symbol identifying a primitive
173type, or a `class-name' structure identifying a class or interface."
174  (if (symbolp field-type)
175      (map-primitive-type field-type)
176      (class-ref field-type)))
177
178(defun descriptor (return-type &rest argument-types)
179  "Returns a string describing the `return-type' and `argument-types'
180in JVM-internal representation."
181  (format nil "(~{~A~})~A" (mapcar #'internal-field-ref argument-types)
182          (internal-field-type return-type)))
183
184
185(defstruct pool
186  ;; `count' contains a reference to the last-used slot (0 being empty)
187  ;; "A constant pool entry is considered valid if it has
188  ;; an index greater than 0 (zero) and less than pool-count"
189  (count 0)
190  entries-list
191  ;; the entries hash stores raw values, except in case of string and
192  ;; utf8, because both are string values
193  (entries (make-hash-table :test #'equal :size 2048 :rehash-size 2.0)))
194
195
196(defstruct constant
197  "Structure to be included in all constant sub-types."
198  tag
199  index)
200
201(defparameter +constant-type-map+
202  '((:class          7 1)
203    (:field-ref      9 1)
204    (:method-ref    10 1)
205    ;; (:interface-method-ref 11)
206    (:string         8 1)
207    (:integer        3 1)
208    (:float          4 1)
209    (:long           5 2)
210    (:double         6 2)
211    (:name-and-type 12 1)
212    (:utf8           1 1)))
213
214(defstruct (constant-class (:constructor make-constant-class (index name-index))
215                           (:include constant
216                                     (tag 7)))
217  name-index)
218
219(defstruct (constant-member-ref (:constructor
220                                 %make-constant-member-ref
221                                     (tag index class-index name/type-index))
222                                (:include constant))
223  class-index
224  name/type-index)
225
226(declaim (inline make-constant-field-ref make-constant-method-ref
227                 make-constant-interface-method-ref))
228(defun make-constant-field-ref (index class-index name/type-index)
229  "Creates a `constant-member-ref' instance containing a field reference."
230  (%make-constant-member-ref 9 index class-index name/type-index))
231
232(defun make-constant-method-ref (index class-index name/type-index)
233  "Creates a `constant-member-ref' instance containing a method reference."
234  (%make-constant-member-ref 10 index class-index name/type-index))
235
236(defun make-constant-interface-method-ref (index class-index name/type-index)
237  "Creates a `constant-member-ref' instance containing an
238interface-method reference."
239  (%make-constant-member-ref 11 index class-index name/type-index))
240
241(defstruct (constant-string (:constructor
242                             make-constant-string (index value-index))
243                            (:include constant
244                                      (tag 8)))
245  value-index)
246
247(defstruct (constant-float/int (:constructor
248                                %make-constant-float/int (tag index value))
249                               (:include constant))
250  value)
251
252(declaim (inline make-constant-float make-constant-int))
253(defun make-constant-float (index value)
254  "Creates a `constant-float/int' structure instance containing a float."
255  (%make-constant-float/int 4 index value))
256
257(defun make-constant-int (index value)
258  "Creates a `constant-float/int' structure instance containing an int."
259  (%make-constant-float/int 3 index value))
260
261(defstruct (constant-double/long (:constructor
262                                  %make-constant-double/long (tag index value))
263                                 (:include constant))
264  value)
265
266(declaim (inline make-constant-double make-constant-float))
267(defun make-constant-double (index value)
268  "Creates a `constant-double/long' structure instance containing a double."
269  (%make-constant-double/long 6 index value))
270
271(defun make-constant-long (index value)
272  "Creates a `constant-double/long' structure instance containing a long."
273  (%make-constant-double/long 5 index value))
274
275(defstruct (constant-name/type (:constructor
276                                make-constant-name/type (index
277                                                         name-index
278                                                         descriptor-index))
279                               (:include constant
280                                         (tag 12)))
281  name-index
282  descriptor-index)
283
284(defstruct (constant-utf8 (:constructor make-constant-utf8 (index value))
285                          (:include constant
286                                    (tag 11)))
287  value)
288
289
290(defun pool-add-class (pool class)
291  "Returns the index of the constant-pool class item for `class'.
292
293`class' must be an instance of `class-name'."
294  (let ((entry (gethash class (pool-entries pool))))
295    (unless entry
296      (setf entry
297            (make-constant-class (incf (pool-count pool))
298                                 (pool-add-utf8 pool
299                                                (class-name-internal class)))
300            (gethash class (pool-entries pool)) entry)
301      (push entry (pool-entries-list pool)))
302    (constant-index entry)))
303
304(defun pool-add-field-ref (pool class name type)
305  "Returns the index of the constant-pool item which denotes a reference
306to the `name' field of the `class', being of `type'.
307
308`class' should be an instance of `class-name'.
309`name' is a string.
310`type' is a field-type (see `internal-field-type')"
311  (let ((entry (gethash (acons name type class) (pool-entries pool))))
312    (unless entry
313      (setf entry (make-constant-field-ref (incf (pool-count pool))
314                                           (pool-add-class pool class)
315                                           (pool-add-name/type pool name type))
316            (gethash (acons name type class) (pool-entries pool)) entry)
317      (push entry (pool-entries-list pool)))
318    (constant-index entry)))
319
320(defun pool-add-method-ref (pool class name type)
321  "Returns the index of the constant-pool item which denotes a reference
322to the method with `name' in `class', which is of `type'.
323
324Here, `type' is a method descriptor, which defines the argument types
325and return type. `class' is an instance of `class-name'."
326  (let ((entry (gethash (acons name type class) (pool-entries pool))))
327    (unless entry
328      (setf entry (make-constant-method-ref (incf (pool-count pool))
329                                            (pool-add-class pool class)
330                                            (pool-add-name/type pool name type))
331            (gethash (acons name type class) (pool-entries pool)) entry)
332      (push entry (pool-entries-list pool)))
333    (constant-index entry)))
334
335(defun pool-add-interface-method-ref (pool class name type)
336  "Returns the index of the constant-pool item which denotes a reference to
337the method `name' in the interface `class', which is of `type'.
338
339See `pool-add-method-ref' for remarks."
340  (let ((entry (gethash (acons name type class) (pool-entries pool))))
341    (unless entry
342      (setf entry
343            (make-constant-interface-method-ref (incf (pool-count pool))
344                                                (pool-add-class pool class)
345                                                (pool-add-name/type pool
346                                                                    name type))
347            (gethash (acons name type class) (pool-entries pool)) entry)
348      (push entry (pool-entries-list pool)))
349    (constant-index entry)))
350
351(defun pool-add-string (pool string)
352  "Returns the index of the constant-pool item denoting the string."
353  (let ((entry (gethash (cons 8 string) ;; 8 == string-tag
354                        (pool-entries pool))))
355    (unless entry
356      (setf entry (make-constant-string (incf (pool-count pool))
357                                        (pool-add-utf8 pool string))
358            (gethash (cons 8 string) (pool-entries pool)) entry)
359      (push entry (pool-entries-list pool)))
360    (constant-index entry)))
361
362(defun pool-add-int (pool int)
363  "Returns the index of the constant-pool item denoting the int."
364  (let ((entry (gethash (cons 3 int) (pool-entries pool))))
365    (unless entry
366      (setf entry (make-constant-int (incf (pool-count pool)) int)
367            (gethash (cons 3 int) (pool-entries pool)) entry)
368      (push entry (pool-entries-list pool)))
369    (constant-index entry)))
370
371(defun pool-add-float (pool float)
372  "Returns the index of the constant-pool item denoting the float."
373  (let ((entry (gethash (cons 4 float) (pool-entries pool))))
374    (unless entry
375      (setf entry (make-constant-float (incf (pool-count pool)) float)
376            (gethash (cons 4 float) (pool-entries pool)) entry)
377      (push entry (pool-entries-list pool)))
378    (constant-index entry)))
379
380(defun pool-add-long (pool long)
381  "Returns the index of the constant-pool item denoting the long."
382  (let ((entry (gethash (cons 5 long) (pool-entries pool))))
383    (unless entry
384      (setf entry (make-constant-long (incf (pool-count pool)) long)
385            (gethash (cons 5 long) (pool-entries pool)) entry)
386      (push entry (pool-entries-list pool))
387      (incf (pool-count pool))) ;; double index increase; long takes 2 slots
388    (constant-index entry)))
389
390(defun pool-add-double (pool double)
391  "Returns the index of the constant-pool item denoting the double."
392  (let ((entry (gethash (cons 6 double) (pool-entries pool))))
393    (unless entry
394      (setf entry (make-constant-double (incf (pool-count pool)) double)
395            (gethash (cons 6 double) (pool-entries pool)) entry)
396      (push entry (pool-entries-list pool))
397      (incf (pool-count pool))) ;; double index increase; 'double' takes 2 slots
398    (constant-index entry)))
399
400(defun pool-add-name/type (pool name type)
401  "Returns the index of the constant-pool item denoting
402the name/type identifier."
403  (let ((entry (gethash (cons name type) (pool-entries pool)))
404        (internal-type (if (listp type)
405                           (apply #'descriptor type)
406                           (internal-field-ref type))))
407    (unless entry
408      (setf entry (make-constant-name/type (incf (pool-count pool))
409                                           (pool-add-utf8 pool name)
410                                           (pool-add-utf8 pool internal-type))
411            (gethash (cons name type) (pool-entries pool)) entry)
412      (push entry (pool-entries-list pool)))
413    (constant-index entry)))
414
415(defun pool-add-utf8 (pool utf8-as-string)
416  "Returns the index of the textual value that will be stored in the
417class file as UTF-8 encoded data."
418  (let ((entry (gethash (cons 11 utf8-as-string) ;; 11 == utf8
419                        (pool-entries pool))))
420    (unless entry
421      (setf entry (make-constant-utf8 (incf (pool-count pool)) utf8-as-string)
422            (gethash (cons 11 utf8-as-string) (pool-entries pool)) entry)
423      (push entry (pool-entries-list pool)))
424    (constant-index entry)))
425
426(defstruct (class-file (:constructor
427                        !make-class-file (class superclass access-flags)))
428  (constants (make-pool))
429  access-flags
430  class
431  superclass
432  ;; interfaces
433  fields
434  methods
435  attributes)
436
437(defun class-add-field (class field)
438  "Adds a `field' created by `make-field'."
439  (push field (class-file-fields class)))
440
441(defun class-field (class name)
442  "Finds a field by name." ;; ### strictly speaking, a field is uniquely
443  ;; identified by its name and type, not by the name alone.
444  (find name (class-file-fields class)
445        :test #'string= :key #'field-name))
446
447(defun class-add-method (class method)
448  "Adds a `method' to `class'; the method must have been created using
449`make-method'."
450  (push method (class-file-methods class)))
451
452(defun class-methods-by-name (class name)
453  "Returns all methods which have `name'."
454  (remove name (class-file-methods class)
455          :test-not #'string= :key #'method-name))
456
457(defun class-method (class name return &rest args)
458  "Return the method which is (uniquely) identified by its name AND descriptor."
459  (let ((return-and-args (cons return args)))
460    (find-if #'(lambda (c)
461                 (and (string= (method-name c) name)
462                      (equal (method-descriptor c) return-and-args)))
463             (class-file-methods class))))
464
465(defun class-add-attribute (class attribute)
466  "Adds `attribute' to the class; attributes must be instances of
467structure classes which include the `attribute' structure class."
468  (push attribute (class-file-attributes class)))
469
470(defun class-attribute (class name)
471  "Returns the attribute which is named `name'."
472  (find name (class-file-attributes class)
473        :test #'string= :key #'attribute-name))
474
475
476(defun finalize-class-file (class)
477  "Transforms the representation of the class-file from one
478which allows easy modification to one which works best for serialization.
479
480The class can't be modified after serialization."
481  ;; constant pool contains constants finalized on addition;
482  ;; no need for additional finalization
483
484  (setf (class-file-access-flags class)
485        (map-flags (class-file-access-flags class)))
486  (setf (class-file-class class)
487        (pool-add-class (class-file-constants class)
488                        (class-file-class class)))
489  ;;  (finalize-interfaces)
490  (dolist (field (class-file-fields class))
491    (finalize-field field class))
492  (dolist (method (class-file-methods class))
493    (finalize-method method class))
494  ;; top-level attributes (no parent attributes to refer to)
495  (finalize-attributes (class-file-attributes class) nil class))
496
497(defun !write-class-file (class stream)
498  "Serializes `class' to `stream', after it has been finalized."
499
500  ;; header
501  (write-u4 #xCAFEBABE stream)
502  (write-u2 3 stream)
503  (write-u2 45 stream)
504
505   ;; constants pool
506  (write-constants (class-file-constants class) stream)
507  ;; flags
508  (write-u2  (class-file-access-flags class) stream)
509  ;; class name
510  (write-u2 (class-file-class class) stream)
511  ;; superclass
512  (write-u2 (class-file-superclass class) stream)
513
514  ;; interfaces
515  (write-u2 0 stream)
516
517  ;; fields
518  (write-u2 (length (class-file-fields class)) stream)
519  (dolist (field (class-file-fields class))
520    (!write-field field stream))
521
522  ;; methods
523  (write-u2 (length (class-file-methods class)) stream)
524  (dolist (method (class-file-methods class))
525    (!write-method method stream))
526
527  ;; attributes
528  (write-attributes (class-file-attributes class) stream))
529
530(defun write-constants (constants stream)
531  (write-u2 (pool-count constants) stream)
532  (dolist (entry (reverse (pool-entries-list constants)))
533    (let ((tag (constant-tag entry)))
534    (write-u1 tag stream)
535    (case tag
536      (1         ; UTF8
537       (write-utf8 (constant-utf8-value entry) stream))
538      ((3 4)     ; int
539       (write-u4 (constant-float/int-value entry) stream))
540      ((5 6)     ; long double
541       (write-u4 (logand (ash (constant-double/long-value entry) -32)
542                         #xFFFFffff) stream)
543       (write-u4 (logand (constant-double/long-value entry) #xFFFFffff) stream))
544      ((9 10 11) ; fieldref methodref InterfaceMethodref
545       (write-u2 (constant-member-ref-class-index entry) stream)
546       (write-u2 (constant-member-ref-name/type-index entry) stream))
547      (12        ; nameAndType
548       (write-u2 (constant-name/type-name-index entry) stream)
549       (write-u2 (constant-name/type-descriptor-index entry) stream))
550      (7         ; class
551       (write-u2 (constant-class-name-index entry) stream))
552      (8         ; string
553       (write-u2 (constant-string-value-index entry) stream))
554      (t
555       (error "write-constant-pool-entry unhandled tag ~D~%" tag))))))
556
557#|
558
559ABCL doesn't use interfaces, so don't implement it here at this time
560
561(defstruct interface)
562
563|#
564
565
566(defparameter +access-flags-map+
567  '((:public       #x0001)
568    (:private      #x0002)
569    (:protected    #x0004)
570    (:static       #x0008)
571    (:final        #x0010)
572    (:volatile     #x0040)
573    (:synchronized #x0020)
574    (:transient    #x0080)
575    (:native       #x0100)
576    (:abstract     #x0400)
577    (:strict       #x0800)))
578
579(defun map-flags (flags)
580  "Calculates the bitmap of the flags from a list of symbols."
581  (reduce #'(lambda (y x)
582              (logior (or (when (member (car x) flags)
583                            (second x))
584                          0) y))
585          +access-flags-map+
586          :initial-value 0))
587
588(defstruct (field (:constructor %make-field))
589  access-flags
590  name
591  descriptor
592  attributes)
593
594(defun make-field (name type &key (flags '(:public)))
595  (%make-field :access-flags flags
596               :name name
597               :descriptor type))
598
599(defun field-add-attribute (field attribute)
600  (push attribute (field-attributes field)))
601
602(defun field-attribute (field name)
603  (find name (field-attributes field)
604        :test #'string= :key #'attribute-name))
605
606(defun finalize-field (field class)
607  (let ((pool (class-file-constants class)))
608    (setf (field-access-flags field)
609          (map-flags (field-access-flags field))
610          (field-descriptor field)
611          (pool-add-utf8 pool (internal-field-type (field-descriptor field)))
612          (field-name field)
613          (pool-add-utf8 pool (field-name field))))
614  (finalize-attributes (field-attributes field) nil class))
615
616(defun !write-field (field stream)
617  (write-u2 (field-access-flags field) stream)
618  (write-u2 (field-name field) stream)
619  (write-u2 (field-descriptor field) stream)
620  (write-attributes (field-attributes field) stream))
621
622
623(defstruct (method (:constructor %!make-method))
624  access-flags
625  name
626  descriptor
627  attributes)
628
629
630(defun map-method-name (name)
631  "Methods should be identified by strings containing their names, or,
632be one of two keyword identifiers to identify special methods:
633
634 * :class-constructor
635 * :constructor
636"
637  (cond
638    ((eq name :class-constructor)
639     "<clinit>")
640    ((eq name :constructor)
641     "<init>")
642    (t name)))
643
644(defun !make-method (name return args &key (flags '(:public)))
645  (%make-method :descriptor (cons return args)
646                :access-flags flags
647                :name name))
648
649(defun method-add-attribute (method attribute)
650  (push attribute (method-attributes method)))
651
652(defun method-add-code (method)
653  "Creates an (empty) 'Code' attribute for the method."
654  (method-add-attribute
655   (make-code-attribute (+ (length (cdr (method-descriptor method)))
656                           (if (member :static (method-access-flags method))
657                               0 1))))) ;; 1 == implicit 'this'
658
659(defun method-attribute (method name)
660  (find name (method-attributes method)
661        :test #'string= :key #'attribute-name))
662
663
664(defun finalize-method (method class)
665  (let ((pool (class-file-constants class)))
666    (setf (method-access-flags method)
667          (map-flags (method-access-flags method))
668          (method-descriptor method)
669          (pool-add-utf8 pool (apply #'descriptor (method-descriptor method)))
670          (method-name method)
671          (pool-add-utf8 pool (map-method-name (method-name method)))))
672  (finalize-attributes (method-attributes method) nil class))
673
674
675(defun !write-method (method stream)
676  (write-u2 (method-access-flags method) stream)
677  (write-u2 (method-name method) stream)
678  (write-u2 (method-descriptor method) stream)
679  (write-attributes (method-attributes method) stream))
680
681(defstruct attribute
682  name
683
684  ;; not in the class file:
685  finalizer  ;; function of 3 arguments: the attribute, parent and class-file
686  writer     ;; function of 2 arguments: the attribute and the output stream
687  )
688
689(defun finalize-attributes (attributes att class)
690  (dolist (attribute attributes)
691    ;; assure header: make sure 'name' is in the pool
692    (setf (attribute-name attribute)
693          (pool-add-string (class-file-constants class)
694                           (attribute-name attribute)))
695    ;; we're saving "root" attributes: attributes which have no parent
696    (funcall (attribute-finalizer attribute) attribute att class)))
697
698(defun write-attributes (attributes stream)
699  (write-u2 (length attributes) stream)
700  (dolist (attribute attributes)
701    (write-u2 (attribute-name attribute) stream)
702    ;; set up a bulk catcher for (UNSIGNED-BYTE 8)
703    ;; since we need to know the attribute length (excluding the header)
704    (let ((local-stream (sys::%make-byte-array-output-stream)))
705      (funcall (attribute-writer attribute) attribute local-stream)
706      (let ((array (sys::%get-output-stream-array local-stream)))
707        (write-u2 (length array) stream)
708        (write-sequence array stream)))))
709
710
711
712(defstruct (code-attribute (:conc-name code-)
713                           (:include attribute
714                                     (name "Code")
715                                     (finalizer #'!finalize-code)
716                                     (writer #'!write-code))
717                           (:constructor %make-code-attribute))
718  max-stack
719  max-locals
720  code
721  attributes
722  ;; labels contains offsets into the code array after it's finalized
723  (labels (make-hash-table :test #'eq))
724
725  ;; fields not in the class file start here
726  current-local ;; used for handling nested WITH-CODE-TO-METHOD blocks
727  )
728
729
730(defun code-label-offset (code label)
731  (gethash label (code-labels code)))
732
733(defun (setf code-label-offset) (offset code label)
734  (setf (gethash label (code-labels code)) offset))
735
736(defun !finalize-code (code class)
737  (let ((c (coerce (resolve-instructions (code-code code)) 'vector)))
738    (setf (code-max-stack code) (analyze-stack c)
739          (code-code code) (code-bytes c)))
740  (finalize-attributes (code-attributes code) code class))
741
742(defun !write-code (code stream)
743  (write-u2 (code-max-stack code) stream)
744  (write-u2 (code-max-locals code) stream)
745  (let ((code-array (code-code code)))
746    (write-u4 (length code-array) stream)
747    (dotimes (i (length code-array))
748      (write-u1 (svref code-array i) stream)))
749  (write-attributes (code-attributes code) stream))
750
751(defun make-code-attribute (arg-count)
752  "Creates an empty 'Code' attribute for a method which takes
753`arg-count` parameters, including the implicit `this` parameter."
754  (%make-code-attribute :max-locals arg-count))
755
756(defun code-add-attribute (code attribute)
757  (push attribute (code-attributes code)))
758
759(defun code-attribute (code name)
760  (find name (code-attributes code)
761        :test #'string= :key #'attribute-name))
762
763
764
765(defvar *current-code-attribute*)
766
767(defun save-code-specials (code)
768  (setf (code-code code) *code*
769        (code-max-locals code) *registers-allocated*
770        (code-exception-handlers code) *handlers*
771        (code-current-local code) *register*))
772
773(defun restore-code-specials (code)
774  (setf *code* (code-code code)
775        *registers-allocated* (code-max-locals code)
776        *register* (code-current-local code)))
777
778(defmacro with-code-to-method ((method &key safe-nesting) &body body)
779  (let ((m (gensym))
780        (c (gensym)))
781    `(progn
782       ,@(when safe-nesting
783           `((when *current-code-attribute*
784               (save-code-specials *current-code-attribute*))))
785       (let* ((,m ,method)
786              (,c (method-attribute ,m "Code"))
787              (*code* (code-code ,c))
788              (*registers-allocated* (code-max-locals ,c))
789              (*register* (code-current-local ,c))
790              (*current-code-attribute* ,c))
791         ,@body
792         (setf (code-code ,c) *code*
793               (code-exception-handlers ,c) *handlers*
794               (code-max-locals ,c) *registers-allocated*))
795       ,@(when safe-nesting
796           `((when *current-code-attribute*
797               (restore-code-specials *current-code-attribute*)))))))
798
799(defstruct (exceptions-attribute (:constructor make-exceptions)
800                                 (:conc-name exceptions-)
801                                 (:include attribute
802                                           (name "Exceptions")
803                                           (finalizer #'finalize-exceptions)
804                                           (writer #'write-exceptions)))
805  exceptions)
806
807(defun finalize-exceptions (exceptions code class)
808  (dolist (exception (exceptions-exceptions exceptions))
809    ;; no need to finalize `catch-type': it's already the index required
810    (setf (exception-start-pc exception)
811          (code-label-offset code (exception-start-pc exception))
812          (exception-end-pc exception)
813          (code-label-offset code (exception-end-pc exception))
814          (exception-handler-pc exception)
815          (code-label-offset code (exception-handler-pc exception))
816          (exception-catch-type exception)
817          (pool-add-string (class-file-constants class)
818                           (exception-catch-type exception))))
819  ;;(finalize-attributes (exceptions-attributes exception) exceptions class)
820  )
821
822
823(defun write-exceptions (exceptions stream)
824  ; number of entries
825  (write-u2 (length (exceptions-exceptions exceptions)) stream)
826  (dolist (exception (exceptions-exceptions exceptions))
827    (write-u2 (exception-start-pc exception) stream)
828    (write-u2 (exception-end-pc exception) stream)
829    (write-u2 (exception-handler-pc exception) stream)
830    (write-u2 (exception-catch-type exception) stream)))
831
832(defun code-add-exception (code start end handler type)
833  (when (null (code-attribute code "Exceptions"))
834    (code-add-attribute code (make-exceptions)))
835  (push (make-exception :start-pc start
836                        :end-pc end
837                        :handler-pc handler
838                        :catch-type type)
839        (exceptions-exceptions (code-attribute code "Exceptions"))))
840
841(defstruct exception
842  start-pc    ;; label target
843  end-pc      ;; label target
844  handler-pc  ;; label target
845  catch-type  ;; a string for a specific type, or NIL for all
846  )
847
848(defstruct (source-file-attribute (:conc-name source-)
849                                  (:include attribute
850                                            (name "SourceFile")))
851  filename)
852
853(defstruct (line-numbers-attribute (:include attribute
854                                             (name "LineNumberTable")))
855  line-numbers)
856
857(defstruct line-number
858  start-pc
859  line)
860
861(defstruct (local-variables-attribute (:conc-name local-var-)
862                                      (:include attribute
863                                                (name "LocalVariableTable")))
864  locals)
865
866(defstruct (local-variable (:conc-name local-))
867  start-pc
868  length
869  name
870  descriptor
871  index)
872
873#|
874
875;; this is the minimal sequence we need to support:
876
877;;  create a class file structure
878;;  add methods
879;;  add code to the methods, switching from one method to the other
880;;  finalize the methods, one by one
881;;  write the class file
882
883to support the sequence above, we probably need to
884be able to
885
886- find methods by signature
887- find the method's code attribute
888- add code to the code attribute
889- finalize the code attribute contents (blocking it for further addition)
890-
891
892
893|#
894
Note: See TracBrowser for help on using the repository browser.