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

Last change on this file since 12789 was 12789, checked in by ehuelsmann, 13 years ago

More CLASS-NAME integration.

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