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

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

Lots of fixes from writing tests. Most notable the correction of
my perception that the exceptions table was stored as an attribute
of the "Code" attribute. It's not: it's part of said attribute.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 35.6 KB
Line 
1;;; jvm-class-file.lisp
2;;;
3;;; Copyright (C) 2010 Erik Huelsmann
4;;; $Id: jvm-class-file.lisp 12832 2010-07-29 18:27:10Z 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.LispInteger")
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.LispCharacter")
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-ref return-type)))
184
185
186(defstruct pool
187  ;; `index' contains the index of the last allocated slot (0 == 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  (index 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 1)))
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      (let ((utf8 (pool-add-utf8 pool (class-name-internal class))))
298        (setf entry
299              (make-constant-class (incf (pool-index pool)) utf8)
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      (let ((c (pool-add-class pool class))
314            (n/t (pool-add-name/type pool name type)))
315        (setf entry (make-constant-field-ref (incf (pool-index pool)) c n/t)
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      (let ((c (pool-add-class pool class))
329            (n/t (pool-add-name/type pool name type)))
330        (setf entry (make-constant-method-ref (incf (pool-index pool)) c n/t)
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      (let ((c (pool-add-class pool class))
343            (n/t (pool-add-name/type pool name type)))
344        (setf entry
345            (make-constant-interface-method-ref (incf (pool-index pool)) c n/t)
346            (gethash (acons name type class) (pool-entries pool)) entry))
347      (push entry (pool-entries-list pool)))
348    (constant-index entry)))
349
350(defun pool-add-string (pool string)
351  "Returns the index of the constant-pool item denoting the string."
352  (let ((entry (gethash (cons 8 string) ;; 8 == string-tag
353                        (pool-entries pool))))
354    (unless entry
355      (let ((utf8 (pool-add-utf8 pool string)))
356        (setf entry (make-constant-string (incf (pool-index pool)) utf8)
357              (gethash (cons 8 string) (pool-entries pool)) entry))
358      (push entry (pool-entries-list pool)))
359    (constant-index entry)))
360
361(defun pool-add-int (pool int)
362  "Returns the index of the constant-pool item denoting the int."
363  (let ((entry (gethash (cons 3 int) (pool-entries pool))))
364    (unless entry
365      (setf entry (make-constant-int (incf (pool-index pool)) int)
366            (gethash (cons 3 int) (pool-entries pool)) entry)
367      (push entry (pool-entries-list pool)))
368    (constant-index entry)))
369
370(defun pool-add-float (pool float)
371  "Returns the index of the constant-pool item denoting the float."
372  (let ((entry (gethash (cons 4 float) (pool-entries pool))))
373    (unless entry
374      (setf entry (make-constant-float (incf (pool-index pool)) float)
375            (gethash (cons 4 float) (pool-entries pool)) entry)
376      (push entry (pool-entries-list pool)))
377    (constant-index entry)))
378
379(defun pool-add-long (pool long)
380  "Returns the index of the constant-pool item denoting the long."
381  (let ((entry (gethash (cons 5 long) (pool-entries pool))))
382    (unless entry
383      (setf entry (make-constant-long (incf (pool-index pool)) long)
384            (gethash (cons 5 long) (pool-entries pool)) entry)
385      (push entry (pool-entries-list pool))
386      (incf (pool-index pool))) ;; double index increase; long takes 2 slots
387    (constant-index entry)))
388
389(defun pool-add-double (pool double)
390  "Returns the index of the constant-pool item denoting the double."
391  (let ((entry (gethash (cons 6 double) (pool-entries pool))))
392    (unless entry
393      (setf entry (make-constant-double (incf (pool-index pool)) double)
394            (gethash (cons 6 double) (pool-entries pool)) entry)
395      (push entry (pool-entries-list pool))
396      (incf (pool-index pool))) ;; double index increase; 'double' takes 2 slots
397    (constant-index entry)))
398
399(defun pool-add-name/type (pool name type)
400  "Returns the index of the constant-pool item denoting
401the name/type identifier."
402  (let ((entry (gethash (cons name type) (pool-entries pool)))
403        (internal-type (if (listp type)
404                           (apply #'descriptor type)
405                           (internal-field-ref type))))
406    (unless entry
407      (let ((n (pool-add-utf8 pool name))
408            (i-t (pool-add-utf8 pool internal-type)))
409        (setf entry (make-constant-name/type (incf (pool-index pool)) n i-t)
410              (gethash (cons name type) (pool-entries pool)) entry))
411      (push entry (pool-entries-list pool)))
412    (constant-index entry)))
413
414(defun pool-add-utf8 (pool utf8-as-string)
415  "Returns the index of the textual value that will be stored in the
416class file as UTF-8 encoded data."
417  (let ((entry (gethash (cons 11 utf8-as-string) ;; 11 == utf8
418                        (pool-entries pool))))
419    (unless entry
420      (setf entry (make-constant-utf8 (incf (pool-index pool)) utf8-as-string)
421            (gethash (cons 11 utf8-as-string) (pool-entries pool)) entry)
422      (push entry (pool-entries-list pool)))
423    (constant-index entry)))
424
425(defstruct (class-file (:constructor
426                        !make-class-file (class superclass access-flags)))
427  (constants (make-pool))
428  access-flags
429  class
430  superclass
431  ;; interfaces
432  fields
433  methods
434  attributes)
435
436(defun class-add-field (class field)
437  "Adds a `field' created by `make-field'."
438  (push field (class-file-fields class)))
439
440(defun class-field (class name)
441  "Finds a field by name." ;; ### strictly speaking, a field is uniquely
442  ;; identified by its name and type, not by the name alone.
443  (find name (class-file-fields class)
444        :test #'string= :key #'field-name))
445
446(defun class-add-method (class method)
447  "Adds a `method' to `class'; the method must have been created using
448`make-method'."
449  (push method (class-file-methods class)))
450
451(defun class-methods-by-name (class name)
452  "Returns all methods which have `name'."
453  (remove name (class-file-methods class)
454          :test-not #'string= :key #'method-name))
455
456(defun class-method (class name return &rest args)
457  "Return the method which is (uniquely) identified by its name AND descriptor."
458  (let ((return-and-args (cons return args)))
459    (find-if #'(lambda (c)
460                 (and (string= (method-name c) name)
461                      (equal (method-descriptor c) return-and-args)))
462             (class-file-methods class))))
463
464(defun class-add-attribute (class attribute)
465  "Adds `attribute' to the class; attributes must be instances of
466structure classes which include the `attribute' structure class."
467  (push attribute (class-file-attributes class)))
468
469(defun class-attribute (class name)
470  "Returns the attribute which is named `name'."
471  (find name (class-file-attributes class)
472        :test #'string= :key #'attribute-name))
473
474
475(defun finalize-class-file (class)
476  "Transforms the representation of the class-file from one
477which allows easy modification to one which works best for serialization.
478
479The class can't be modified after finalization."
480
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-superclass class)
487        (pool-add-class (class-file-constants class)
488                        (class-file-superclass class))
489        (class-file-class class)
490        (pool-add-class (class-file-constants class)
491                        (class-file-class class)))
492  ;;  (finalize-interfaces)
493  (dolist (field (class-file-fields class))
494    (finalize-field field class))
495  (dolist (method (class-file-methods class))
496    (finalize-method method class))
497  ;; top-level attributes (no parent attributes to refer to)
498  (finalize-attributes (class-file-attributes class) nil class))
499
500(defun !write-class-file (class stream)
501  "Serializes `class' to `stream', after it has been finalized."
502
503  ;; header
504  (write-u4 #xCAFEBABE stream)
505  (write-u2 3 stream)
506  (write-u2 45 stream)
507
508   ;; constants pool
509  (write-constants (class-file-constants class) stream)
510  ;; flags
511  (write-u2  (class-file-access-flags class) stream)
512  ;; class name
513
514  (write-u2 (class-file-class class) stream)
515  ;; superclass
516  (write-u2 (class-file-superclass class) stream)
517
518  ;; interfaces
519  (write-u2 0 stream)
520
521  ;; fields
522  (write-u2 (length (class-file-fields class)) stream)
523  (dolist (field (class-file-fields class))
524    (!write-field field stream))
525
526  ;; methods
527  (write-u2 (length (class-file-methods class)) stream)
528  (dolist (method (class-file-methods class))
529    (!write-method method stream))
530
531  ;; attributes
532  (write-attributes (class-file-attributes class) stream))
533
534
535(defvar *jvm-class-debug-pool* nil
536  "When bound to a non-NIL value, enables output to *standard-output*
537to allow debugging output of the constant section of the class file.")
538
539(defun write-constants (constants stream)
540  "Writes the constant section given in `constants' to the class file `stream'."
541  (let ((pool-index 0))
542    (write-u2 (1+ (pool-index constants)) stream)
543    (when *jvm-class-debug-pool*
544      (sys::%format t "pool count ~A~%" (pool-index constants)))
545    (dolist (entry (reverse (pool-entries-list constants)))
546      (incf pool-index)
547      (let ((tag (constant-tag entry)))
548        (when *jvm-class-debug-pool*
549          (print-constant entry t))
550        (write-u1 tag stream)
551        (case tag
552          (1                            ; UTF8
553           (write-utf8 (constant-utf8-value entry) stream))
554          ((3 4)                        ; float int
555           (write-u4 (constant-float/int-value entry) stream))
556          ((5 6)                        ; long double
557           (write-u4 (logand (ash (constant-double/long-value entry) -32)
558                             #xFFFFffff) stream)
559           (write-u4 (logand (constant-double/long-value entry) #xFFFFffff)
560                     stream))
561          ((9 10 11)           ; fieldref methodref InterfaceMethodref
562           (write-u2 (constant-member-ref-class-index entry) stream)
563           (write-u2 (constant-member-ref-name/type-index entry) stream))
564          (12                           ; nameAndType
565           (write-u2 (constant-name/type-name-index entry) stream)
566           (write-u2 (constant-name/type-descriptor-index entry) stream))
567          (7                            ; class
568           (write-u2 (constant-class-name-index entry) stream))
569          (8                            ; string
570           (write-u2 (constant-string-value-index entry) stream))
571          (t
572           (error "write-constant-pool-entry unhandled tag ~D~%" tag)))))))
573
574
575(defun print-constant (entry stream)
576  "Debugging helper to print the content of a constant-pool entry."
577  (let ((tag (constant-tag entry))
578        (index (constant-index entry)))
579    (sys::%format stream "pool element ~a, tag ~a, " index tag)
580    (case tag
581      (1     (sys::%format t "utf8: ~a~%" (constant-utf8-value entry)))
582      ((3 4) (sys::%format t "f/i: ~a~%" (constant-float/int-value entry)))
583      ((5 6) (sys::%format t "d/l: ~a~%" (constant-double/long-value entry)))
584      ((9 10 11) (sys::%format t "ref: ~a,~a~%"
585                               (constant-member-ref-class-index entry)
586                               (constant-member-ref-name/type-index entry)))
587      (12 (sys::%format t "n/t: ~a,~a~%"
588                        (constant-name/type-name-index entry)
589                        (constant-name/type-descriptor-index entry)))
590      (7 (sys::%format t "cls: ~a~%" (constant-class-name-index entry)))
591      (8 (sys::%format t "str: ~a~%" (constant-string-value-index entry))))))
592
593
594#|
595
596ABCL doesn't use interfaces, so don't implement it here at this time
597
598(defstruct interface)
599
600|#
601
602
603(defparameter +access-flags-map+
604  '((:public       #x0001)
605    (:private      #x0002)
606    (:protected    #x0004)
607    (:static       #x0008)
608    (:final        #x0010)
609    (:volatile     #x0040)
610    (:synchronized #x0020)
611    (:transient    #x0080)
612    (:native       #x0100)
613    (:abstract     #x0400)
614    (:strict       #x0800))
615  "List of keyword symbols used for human readable representation of (access)
616flags and their binary values.")
617
618(defun map-flags (flags)
619  "Calculates the bitmap of the flags from a list of symbols."
620  (reduce #'(lambda (y x)
621              (logior (or (when (member (car x) flags)
622                            (second x))
623                          0) y))
624          +access-flags-map+
625          :initial-value 0))
626
627(defstruct (field (:constructor %make-field))
628  ""
629  access-flags
630  name
631  descriptor
632  attributes)
633
634(defun make-field (name type &key (flags '(:public)))
635 
636  (%make-field :access-flags flags
637               :name name
638               :descriptor type))
639
640(defun field-add-attribute (field attribute)
641  (push attribute (field-attributes field)))
642
643(defun field-attribute (field name)
644  (find name (field-attributes field)
645        :test #'string= :key #'attribute-name))
646
647(defun finalize-field (field class)
648  (let ((pool (class-file-constants class)))
649    (setf (field-access-flags field)
650          (map-flags (field-access-flags field))
651          (field-descriptor field)
652          (pool-add-utf8 pool (internal-field-type (field-descriptor field)))
653          (field-name field)
654          (pool-add-utf8 pool (field-name field))))
655  (finalize-attributes (field-attributes field) nil class))
656
657(defun !write-field (field stream)
658  (write-u2 (field-access-flags field) stream)
659  (write-u2 (field-name field) stream)
660  (write-u2 (field-descriptor field) stream)
661  (write-attributes (field-attributes field) stream))
662
663
664(defstruct (method (:constructor %!make-method))
665  access-flags
666  name
667  descriptor
668  attributes)
669
670
671(defun map-method-name (name)
672  "Methods should be identified by strings containing their names, or,
673be one of two keyword identifiers to identify special methods:
674
675 * :class-constructor
676 * :constructor
677"
678  (cond
679    ((eq name :class-constructor)
680     "<clinit>")
681    ((eq name :constructor)
682     "<init>")
683    (t name)))
684
685(defun !make-method (name return args &key (flags '(:public)))
686  (%!make-method :descriptor (cons return args)
687                :access-flags flags
688                :name name))
689
690(defun method-add-attribute (method attribute)
691  "Add `attribute' to the list of attributes of `method',
692returning `attribute'."
693  (push attribute (method-attributes method))
694  attribute)
695
696(defun method-add-code (method)
697  "Creates an (empty) 'Code' attribute for the method,
698returning the created attribute."
699  (method-add-attribute
700   method
701   (make-code-attribute (+ (length (cdr (method-descriptor method)))
702                           (if (member :static (method-access-flags method))
703                               0 1))))) ;; 1 == implicit 'this'
704
705(defun method-ensure-code (method)
706  "Ensures the existence of a 'Code' attribute for the method,
707returning the attribute."
708  (let ((code (method-attribute method "Code")))
709    (if (null code)
710        (method-add-code method)
711        code)))
712
713(defun method-attribute (method name)
714  (find name (method-attributes method)
715        :test #'string= :key #'attribute-name))
716
717
718(defun finalize-method (method class)
719  (let ((pool (class-file-constants class)))
720    (setf (method-access-flags method)
721          (map-flags (method-access-flags method))
722          (method-descriptor method)
723          (pool-add-utf8 pool (apply #'descriptor (method-descriptor method)))
724          (method-name method)
725          (pool-add-utf8 pool (map-method-name (method-name method)))))
726  (finalize-attributes (method-attributes method) nil class))
727
728
729(defun !write-method (method stream)
730  (write-u2 (method-access-flags method) stream)
731  (write-u2 (method-name method) stream)
732  (sys::%format t "method-name: ~a~%" (method-name method))
733  (write-u2 (method-descriptor method) stream)
734  (write-attributes (method-attributes method) stream))
735
736(defstruct attribute
737  name
738
739  ;; not in the class file:
740  finalizer  ;; function of 3 arguments: the attribute, parent and class-file
741  writer     ;; function of 2 arguments: the attribute and the output stream
742  )
743
744(defun finalize-attributes (attributes att class)
745  (dolist (attribute attributes)
746    ;; assure header: make sure 'name' is in the pool
747    (setf (attribute-name attribute)
748          (pool-add-utf8 (class-file-constants class)
749                         (attribute-name attribute)))
750    ;; we're saving "root" attributes: attributes which have no parent
751    (funcall (attribute-finalizer attribute) attribute att class)))
752
753(defun write-attributes (attributes stream)
754  (write-u2 (length attributes) stream)
755  (dolist (attribute attributes)
756    (write-u2 (attribute-name attribute) stream)
757    ;; set up a bulk catcher for (UNSIGNED-BYTE 8)
758    ;; since we need to know the attribute length (excluding the header)
759    (let ((local-stream (sys::%make-byte-array-output-stream)))
760      (funcall (attribute-writer attribute) attribute local-stream)
761      (let ((array (sys::%get-output-stream-array local-stream)))
762        (write-u4 (length array) stream)
763        (write-sequence array stream)))))
764
765
766
767(defstruct (code-attribute (:conc-name code-)
768                           (:include attribute
769                                     (name "Code")
770                                     (finalizer #'!finalize-code)
771                                     (writer #'!write-code))
772                           (:constructor %make-code-attribute))
773  max-stack
774  max-locals
775  code
776  exception-handlers
777  attributes
778
779  ;; fields not in the class file start here
780
781  ;; labels contains offsets into the code array after it's finalized
782  labels ;; an alist
783
784  current-local) ;; used for handling nested WITH-CODE-TO-METHOD blocks
785
786
787
788(defun code-label-offset (code label)
789  (cdr (assoc label (code-labels code))))
790
791(defun (setf code-label-offset) (offset code label)
792  (setf (code-labels code)
793        (acons label offset (code-labels code))))
794
795
796
797(defun !finalize-code (code parent class)
798  (declare (ignore parent))
799  (let ((c (resolve-instructions (coerce (reverse (code-code code)) 'vector))))
800    (setf (code-max-stack code) (analyze-stack c))
801    (multiple-value-bind
802          (c labels)
803        (code-bytes c)
804      (setf (code-code code) c
805            (code-labels code) labels)))
806
807  (dolist (exception (code-exception-handlers code))
808    (setf (exception-start-pc exception)
809          (code-label-offset code (exception-start-pc exception))
810          (exception-end-pc exception)
811          (code-label-offset code (exception-end-pc exception))
812          (exception-handler-pc exception)
813          (code-label-offset code (exception-handler-pc exception))
814          (exception-catch-type exception)
815          (if (null (exception-catch-type exception))
816              0  ;; generic 'catch all' class index number
817              (pool-add-class (class-file-constants class)
818                              (exception-catch-type exception)))))
819
820  (finalize-attributes (code-attributes code) code class))
821
822(defun !write-code (code stream)
823  (sys::%format t "max-stack: ~a~%" (code-max-stack code))
824  (write-u2 (code-max-stack code) stream)
825  (sys::%format t "max-locals: ~a~%" (code-max-locals code))
826  (write-u2 (code-max-locals code) stream)
827  (let ((code-array (code-code code)))
828    (sys::%format t "length: ~a~%" (length code-array))
829    (write-u4 (length code-array) stream)
830    (dotimes (i (length code-array))
831      (write-u1 (svref code-array i) stream)))
832
833  (write-u2 (length (code-exception-handlers code)) stream)
834  (dolist (exception (reverse (code-exception-handlers code)))
835    (sys::%format t "start-pc: ~a~%" (exception-start-pc exception))
836    (write-u2 (exception-start-pc exception) stream)
837    (sys::%format t "end-pc: ~a~%" (exception-end-pc exception))
838    (write-u2 (exception-end-pc exception) stream)
839    (sys::%format t "handler-pc: ~a~%" (exception-handler-pc exception))
840    (write-u2 (exception-handler-pc exception) stream)
841    (write-u2 (exception-catch-type exception) stream))
842
843  (write-attributes (code-attributes code) stream))
844
845(defun make-code-attribute (arg-count)
846  "Creates an empty 'Code' attribute for a method which takes
847`arg-count` parameters, including the implicit `this` parameter."
848  (%make-code-attribute :max-locals arg-count))
849
850(defun code-add-attribute (code attribute)
851  "Adds `attribute' to `code', returning `attribute'."
852  (push attribute (code-attributes code))
853  attribute)
854
855(defun code-attribute (code name)
856  (find name (code-attributes code)
857        :test #'string= :key #'attribute-name))
858
859
860(defun code-add-exception-handler (code start end handler type)
861  (push (make-exception :start-pc start
862                        :end-pc end
863                        :handler-pc handler
864                        :catch-type type)
865        (code-exception-handlers code)))
866
867(defun add-exception-handler (start end handler type)
868  (code-add-exception-handler *current-code-attribute* start end handler type))
869
870(defstruct exception
871  start-pc    ;; label target
872  end-pc      ;; label target
873  handler-pc  ;; label target
874  catch-type  ;; a string for a specific type, or NIL for all
875  )
876
877
878(defvar *current-code-attribute*)
879
880(defun save-code-specials (code)
881  (setf (code-code code) *code*
882        (code-max-locals code) *registers-allocated*
883;;        (code-exception-handlers code) *handlers*
884        (code-current-local code) *register*))
885
886(defun restore-code-specials (code)
887  (setf *code* (code-code code)
888;;        *handlers* (code-exception-handlers code)
889        *registers-allocated* (code-max-locals code)
890        *register* (code-current-local code)))
891
892(defmacro with-code-to-method ((method &key safe-nesting) &body body)
893  (let ((m (gensym))
894        (c (gensym)))
895    `(progn
896       ,@(when safe-nesting
897           `((when *current-code-attribute*
898               (save-code-specials *current-code-attribute*))))
899       (let* ((,m ,method)
900              (,c (method-ensure-code method))
901              (*code* (code-code ,c))
902              (*registers-allocated* (code-max-locals ,c))
903              (*register* (code-current-local ,c))
904              (*current-code-attribute* ,c))
905         ,@body
906         (setf (code-code ,c) *code*
907;;               (code-exception-handlers ,c) *handlers*
908               (code-max-locals ,c) *registers-allocated*))
909       ,@(when safe-nesting
910           `((when *current-code-attribute*
911               (restore-code-specials *current-code-attribute*)))))))
912
913
914(defstruct (source-file-attribute (:conc-name source-)
915                                  (:include attribute
916                                            (name "SourceFile")))
917  filename)
918
919(defstruct (line-numbers-attribute (:include attribute
920                                             (name "LineNumberTable")))
921  line-numbers)
922
923(defstruct line-number
924  start-pc
925  line)
926
927(defstruct (local-variables-attribute (:conc-name local-var-)
928                                      (:include attribute
929                                                (name "LocalVariableTable")))
930  locals)
931
932(defstruct (local-variable (:conc-name local-))
933  start-pc
934  length
935  name
936  descriptor
937  index)
938
939#|
940
941;; this is the minimal sequence we need to support:
942
943;;  create a class file structure
944;;  add methods
945;;  add code to the methods, switching from one method to the other
946;;  finalize the methods, one by one
947;;  write the class file
948
949to support the sequence above, we probably need to
950be able to
951
952- find methods by signature
953- find the method's code attribute
954- add code to the code attribute
955- finalize the code attribute contents (blocking it for further addition)
956-
957
958
959|#
960
Note: See TracBrowser for help on using the repository browser.