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

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

More pool management and serialization.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 28.7 KB
Line 
1;;; jvm-class-file.lisp
2;;;
3;;; Copyright (C) 2010 Erik Huelsmann
4;;; $Id: jvm-class-file.lisp 12777 2010-07-03 21:40:17Z 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  (case type
62    (:int        "I")
63    (:long       "J")
64    (:float      "F")
65    (:double     "D")
66    (:boolean    "Z")
67    (:char       "C")
68    (:byte       "B")
69    (:short      "S")
70    ((nil :void) "V")))
71
72
73#|
74
75The `class-name' facility helps to abstract from "this instruction takes
76a reference" and "this instruction takes a class name". We simply pass
77the class name around and the instructions themselves know which
78representation to use.
79
80|#
81
82(defstruct (class-name (:conc-name class-)
83                       (:constructor %make-class-name))
84  name-internal
85  ref
86  array-ref)
87
88(defun make-class-name (name)
89  (setf name (substitute #\/ #\. name))
90  (%make-class-name :name-internal name
91                    :ref (concatenate 'string "L" name ";")
92                    :array-ref (concatenate 'string "[L" name ";")))
93
94(defmacro define-class-name (symbol java-dotted-name &optional documentation)
95  `(defconstant ,symbol (make-class-name ,java-dotted-name)
96     ,documentation))
97
98(define-class-name +!java-object+ "java.lang.Object")
99(define-class-name +!java-string+ "java.lang.String")
100(define-class-name +!lisp-object+ "org.armedbear.lisp.LispObject")
101(define-class-name +!lisp-simple-string+ "org.armedbear.lisp.SimpleString")
102(define-class-name +!lisp+ "org.armedbear.lisp.Lisp")
103(define-class-name +!lisp-nil+ "org.armedbear.lisp.Nil")
104(define-class-name +!lisp-class+ "org.armedbear.lisp.LispClass")
105(define-class-name +!lisp-symbol+ "org.armedbear.lisp.Symbol")
106(define-class-name +!lisp-thread+ "org.armedbear.lisp.LispThread")
107(define-class-name +!lisp-closure-binding+ "org.armedbear.lisp.ClosureBinding")
108(define-class-name +!lisp-integer+ "org.armedbear.lisp.Integer")
109(define-class-name +!lisp-fixnum+ "org.armedbear.lisp.Fixnum")
110(define-class-name +!lisp-bignum+ "org.armedbear.lisp.Bignum")
111(define-class-name +!lisp-single-float+ "org.armedbear.lisp.SingleFloat")
112(define-class-name +!lisp-double-float+ "org.armedbear.lisp.DoubleFloat")
113(define-class-name +!lisp-cons+ "org.armedbear.lisp.Cons")
114(define-class-name +!lisp-load+ "org.armedbear.lisp.Load")
115(define-class-name +!lisp-character+ "org.armedbear.lisp.Character")
116(define-class-name +!lisp-simple-vector+ "org.armedbear.lisp.SimpleVector")
117(define-class-name +!lisp-abstract-string+ "org.armedbear.lisp.AbstractString")
118(define-class-name +!lisp-abstract-vector+ "org.armedbear.lisp.AbstractVector")
119(define-class-name +!lisp-abstract-bit-vector+
120    "org.armedbear.lisp.AbstractBitVector")
121(define-class-name +!lisp-environment+ "org.armedbear.lisp.Environment")
122(define-class-name +!lisp-special-binding+ "org.armedbear.lisp.SpecialBinding")
123(define-class-name +!lisp-special-binding-mark+
124    "org.armedbear.lisp.SpecialBindingMark")
125(define-class-name +!lisp-throw+ "org.armedbear.lisp.Throw")
126(define-class-name +!lisp-return+ "org.armedbear.lisp.Return")
127(define-class-name +!lisp-go+ "org.armedbear.lisp.Go")
128(define-class-name +!lisp-primitive+ "org.armedbear.lisp.Primitive")
129(define-class-name +!lisp-compiled-closure+
130    "org.armedbear.lisp.CompiledClosure")
131(define-class-name +!lisp-eql-hash-table+ "org.armedbear.lisp.EqlHashTable")
132(define-class-name +!lisp-package+ "org.armedbear.lisp.Package")
133(define-class-name +!lisp-readtable+ "org.armedbear.lisp.Readtable")
134(define-class-name +!lisp-stream+ "org.armedbear.lisp.Stream")
135(define-class-name +!lisp-closure+ "org.armedbear.lisp.Closure")
136(define-class-name +!lisp-closure-parameter+
137    "org.armedbear.lisp.Closure$Parameter")
138(define-class-name +!fasl-loader+ "org.armedbear.lisp.FaslClassLoader")
139
140#|
141
142Lisp-side descriptor representation:
143
144 - list: a list starting with a method return value, followed by
145     the argument types
146 - keyword: the primitive type associated with that keyword
147 - class-name structure instance: the class-ref value
148
149The latter two can be converted to a Java representation using
150the `internal-field-ref' function, the former is to be fed to
151`descriptor'.
152
153|#
154
155(defun internal-field-type (field-type)
156  (if (keywordp field-type)
157      (map-primitive-type field-type)
158      (class-name-internal field-type)))
159
160(defun internal-field-ref (field-type)
161  (if (keywordp field-type)
162      (map-primitive-type field-type)
163      (class-ref field-type)))
164
165(defun descriptor (return-type &rest argument-types)
166  (format nil "(~{~A~}~A)" (mapcar #'internal-field-ref argument-types)
167          (internal-field-type return-type)))
168
169
170(defstruct pool
171  ;; `count' contains a reference to the last-used slot (0 being empty)
172  ;; "A constant pool entry is considered valid if it has
173  ;; an index greater than 0 (zero) and less than pool-count"
174  (count 0)
175  entries-list
176  ;; the entries hash stores raw values, except in case of string and
177  ;; utf8, because both are string values
178  (entries (make-hash-table :test #'equal :size 2048 :rehash-size 2.0)))
179
180(defstruct constant
181  tag
182  index)
183
184(defparameter +constant-type-map+
185  '((:class          7 1)
186    (:field-ref      9 1)
187    (:method-ref    10 1)
188    ;; (:interface-method-ref 11)
189    (:string         8 1)
190    (:integer        3 1)
191    (:float          4 1)
192    (:long           5 2)
193    (:double         6 2)
194    (:name-and-type 12 1)
195    (:utf8           1 1)))
196
197(defstruct (constant-class (:constructor make-constant-class (index name-index))
198                           (:include constant
199                                     (tag 7)))
200  name-index)
201
202(defstruct (constant-member-ref (:constructor
203                                 %make-constant-member-ref
204                                     (tag index class-index name/type-index))
205                                (:include constant))
206  class-index
207  name/type-index)
208
209(declaim (inline make-constant-field-ref make-constant-method-ref
210                 make-constant-interface-method-ref))
211(defun make-constant-field-ref (index class-index name/type-index)
212  (%make-constant-member-ref 9 index class-index name/type-index))
213
214(defun make-constant-method-ref (index class-index name/type-index)
215  (%make-constant-member-ref 10 index class-index name/type-index))
216
217(defun make-constant-interface-method-ref (index class-index name/type-index)
218  (%make-constant-member-ref 11 index class-index name/type-index))
219
220(defstruct (constant-string (:constructor
221                             make-constant-string (index value-index))
222                            (:include constant
223                                      (tag 8)))
224  value-index) ;;; #### is this the value or the value index???
225
226(defstruct (constant-float/int (:constructor
227                                %make-constant-float/int (tag index value))
228                               (:include constant))
229  value)
230
231(declaim (inline make-constant-float make-constant-int))
232(defun make-constant-float (index value)
233  (%make-constant-float/int 4 index value))
234
235(defun make-constant-int (index value)
236  (%make-constant-float/int 3 index value))
237
238(defstruct (constant-double/long (:constructor
239                                  %make-constant-double/long (tag index value))
240                                 (:include constant))
241  value)
242
243(declaim (inline make-constant-double make-constant-float))
244(defun make-constant-double (index value)
245  (%make-constant-double/long 6 index value))
246
247(defun make-constant-long (index value)
248  (%make-constant-double/long 5 index value))
249
250(defstruct (constant-name/type (:include constant
251                                         (tag 12)))
252  name-index
253  descriptor-index)
254
255(defstruct (constant-utf8 (:constructor make-constant-utf8 (index value))
256                          (:include constant
257                                    (tag 11)))
258  value)
259
260
261(defun pool-add-class (pool class)
262  ;; ### do we make class a string or class-name structure?
263  (let ((entry (gethash class (pool-entries pool))))
264    (unless entry
265      (setf entry
266            (make-constant-class (incf (pool-count pool))
267                                 (pool-add-utf8 pool
268                                                (class-name-internal class)))
269            (gethash class (pool-entries pool)) entry)
270      (push entry (pool-entries-list pool)))
271    (constant-index entry)))
272
273(defun pool-add-field-ref (pool class name type)
274  (let ((entry (gethash (acons name type class) (pool-entries pool))))
275    (unless entry
276      (setf entry (make-constant-field-ref (incf (pool-count pool))
277                                           (pool-add-class pool class)
278                                           (pool-add-name/type pool name type))
279            (gethash (acons name type class) (pool-entries pool)) entry)
280      (push entry (pool-entries-list pool)))
281    (constant-index entry)))
282
283(defun pool-add-method-ref (pool class name type)
284  (let ((entry (gethash (acons name type class) (pool-entries pool))))
285    (unless entry
286      (setf entry (make-constant-method-ref (incf (pool-count pool))
287                                            (pool-add-class pool class)
288                                            (pool-add-name/type pool name type))
289            (gethash (acons name type class) (pool-entries pool)) entry)
290      (push entry (pool-entries-list pool)))
291    (constant-index entry)))
292
293(defun pool-add-interface-method-ref (pool class name type)
294  (let ((entry (gethash (acons name type class) (pool-entries pool))))
295    (unless entry
296      (setf entry
297            (make-constant-interface-method-ref (incf (pool-count pool))
298                                                (pool-add-class pool class)
299                                                (pool-add-name/type pool
300                                                                    name type))
301            (gethash (acons name type class) (pool-entries pool)) entry)
302      (push entry (pool-entries-list pool)))
303    (constant-index entry)))
304
305(defun pool-add-string (pool string)
306  (let ((entry (gethash (cons 8 string) ;; 8 == string-tag
307                        (pool-entries pool))))
308    (unless entry
309      (setf entry (make-constant-string (incf (pool-count pool))
310                                        (pool-add-utf8 pool string))
311            (gethash (cons 8 string) (pool-entries pool)) entry)
312      (push entry (pool-entries-list pool)))
313    (constant-index entry)))
314
315(defun pool-add-int (pool int)
316  (let ((entry (gethash (cons 3 int) (pool-entries pool))))
317    (unless entry
318      (setf entry (make-constant-int (incf (pool-count pool)) int)
319            (gethash (cons 3 int) (pool-entries pool)) entry)
320      (push entry (pool-entries-list pool)))
321    (constant-index entry)))
322
323(defun pool-add-float (pool float)
324  (let ((entry (gethash (cons 4 float) (pool-entries pool))))
325    (unless entry
326      (setf entry (make-constant-float (incf (pool-count pool)) float)
327            (gethash (cons 4 float) (pool-entries pool)) entry)
328      (push entry (pool-entries-list pool)))
329    (constant-index entry)))
330
331(defun pool-add-long (pool long)
332  (let ((entry (gethash (cons 5 long) (pool-entries pool))))
333    (unless entry
334      (setf entry (make-constant-long (incf (pool-count pool)) long)
335            (gethash (cons 5 long) (pool-entries pool)) entry)
336      (push entry (pool-entries-list pool))
337      (incf (pool-count pool))) ;; double index increase; long takes 2 slots
338    (constant-index entry)))
339
340(defun pool-add-double (pool double)
341  (let ((entry (gethash (cons 6 double) (pool-entries pool))))
342    (unless entry
343      (setf entry (make-constant-double (incf (pool-count pool)) double)
344            (gethash (cons 6 double) (pool-entries pool)) entry)
345      (push entry (pool-entries-list pool))
346      (incf (pool-count pool))) ;; double index increase; 'double' takes 2 slots
347    (constant-index entry)))
348
349(defun pool-add-name/type (pool name type)
350  (let ((entry (gethash (cons name type) (pool-entries pool)))
351        (internal-type (if (listp type)
352                           (apply #'descriptor type)
353                           (internal-field-ref type))))
354    (unless entry
355      (setf entry (make-constant-name/type (incf (pool-count pool))
356                                           (pool-add-utf8 pool name)
357                                           (pool-add-utf8 pool internal-type))
358            (gethash (cons name type) (pool-entries pool)) entry)
359      (push entry (pool-entries-list pool)))
360    (constant-index entry)))
361
362(defun pool-add-utf8 (pool utf8-as-string)
363  (let ((entry (gethash (cons 11 utf8-as-string) ;; 11 == utf8
364                        (pool-entries pool))))
365    (unless entry
366      (setf entry (make-constant-utf8 (incf (pool-count pool)) utf8-as-string)
367            (gethash (cons 11 utf8-as-string) (pool-entries pool)) entry)
368      (push entry (pool-entries-list pool)))
369    (constant-index entry)))
370
371(defstruct (class-file (:constructor %make-class-file))
372  constants
373  access-flags
374  class
375  superclass
376  ;; interfaces
377  fields
378  methods
379  attributes
380  )
381
382(defun class-add-field (class field)
383  (push field (class-file-fields class)))
384
385(defun class-field (class name)
386  (find name (class-file-fields class)
387        :test #'string= :key #'field-name))
388
389(defun class-add-method (class method)
390  (push method (class-file-methods class)))
391
392(defun class-methods-by-name (class name)
393  (remove (map-method-name name) (class-file-methods class)
394          :test-not #'string= :key #'method-name))
395
396(defun class-method (class descriptor)
397  (find descriptor (class-file-methods class)
398        :test #'string= :key #'method-name))
399
400
401(defun finalize-class-file (class)
402
403  ;; constant pool contains constants finalized on addition;
404  ;; no need for additional finalization
405
406  (setf (class-file-access-flags class)
407        (map-flags (class-file-access-flags class)))
408  (setf (class-file-class-name class)
409        (pool-add-class (class-name-internal (class-file-class-name class))))
410  ;;  (finalize-interfaces)
411  (dolist (field (class-file-fields class))
412    (finalize-field field class))
413  (dolist (method (class-file-methods class))
414    (finalize-method method class))
415  ;; top-level attributes (no parent attributes to refer to)
416  (finalize-attributes (class-file-attributes class) nil class)
417
418)
419
420(defun !write-class-file (class stream)
421  ;; all components need to finalize themselves:
422  ;;  the constant pool needs to be complete before we start
423  ;;  writing our output.
424
425  ;; header
426  (write-u4 #xCAFEBABE stream)
427  (write-u2 3 stream)
428  (write-u2 45 stream)
429
430   ;; constants pool
431  (write-constants (class-file-constants class) stream)
432  ;; flags
433  (write-u2  (class-file-access-flags class) stream)
434  ;; class name
435  (write-u2 (class-file-class class) stream)
436  ;; superclass
437  (write-u2 (class-file-superclass class) stream)
438
439  ;; interfaces
440  (write-u2 0 stream)
441
442  ;; fields
443  (write-u2 (length (class-file-fields class)) stream)
444  (dolist (field (class-file-fields class))
445    (!write-field field stream))
446
447  ;; methods
448  (write-u2 (length (class-file-methods class)) stream)
449  (dolist (method (class-file-methods class))
450    (!write-method method stream))
451
452  ;; attributes
453  (write-attributes (class-file-attributes class) stream))
454
455(defun write-constants (constants stream)
456  (write-u2 (pool-count constants) stream)
457  (dolist (entry (reverse (pool-entries-list constants)))
458    (let ((tag (constant-tag entry)))
459    (write-u1 tag stream)
460    (case tag
461      (1 ; UTF8
462       (write-utf8 (constant-utf8-value entry) stream))
463      ((3 4) ; int
464       (write-u4 (constant-float/int-value entry) stream))
465      ((5 6) ; long double
466       (write-u4 (logand (ash (constant-double/long-value entry) -32)
467                         #xFFFFffff) stream)
468       (write-u4 (logand (constant-double/long-value entry) #xFFFFffff) stream))
469      ((9 10 11) ; fieldref methodref InterfaceMethodref
470       (write-u2 (constant-member-ref-class-index entry) stream)
471       (write-u2 (constant-member-ref-name/type-index entry) stream))
472      (12 ; nameAndType
473       (write-u2 (constant-name/type-name-index entry) stream)
474       (write-u2 (constant-name/type-descriptor-index entry) stream))
475      (7  ; class
476       (write-u2 (constant-class-name-index entry) stream))
477      (8  ; string
478       (write-u2 (constant-string-value-index entry) stream))
479      (t
480       (error "write-constant-pool-entry unhandled tag ~D~%" tag))))))
481
482#|
483
484ABCL doesn't use interfaces, so don't implement it here at this time
485
486(defstruct interface)
487
488|#
489
490
491(defparameter +access-flags-map+
492  '((:public       #x0001)
493    (:private      #x0002)
494    (:protected    #x0004)
495    (:static       #x0008)
496    (:final        #x0010)
497    (:volatile     #x0040)
498    (:synchronized #x0020)
499    (:transient    #x0080)
500    (:native       #x0100)
501    (:abstract     #x0400)
502    (:strict       #x0800)))
503
504(defun map-flags (flags)
505  (reduce #'(lambda (x y)
506              (logior (or (when (member (car x) flags)
507                            (second x))
508                          0) y)
509              (logior (or )))
510          :initial-value 0))
511
512(defstruct (field (:constructor %make-field))
513  access-flags
514  name
515  descriptor
516  attributes
517  )
518
519(defun make-field (name type &key (flags '(:public)))
520  (%make-field :access-flags flags
521               :name name
522               :descriptor type))
523
524(defun add-field-attribute (field attribute)
525  (push attribute (field-attributes field)))
526
527
528(defun finalize-field (field class)
529  (let ((pool (class-file-constants class)))
530    (setf (field-access-flags field)
531          (map-flags (field-access-flags field))
532          (field-descriptor field)
533          (pool-add-utf8 pool (internal-field-type (field-descriptor field)))
534          (field-name field)
535          (pool-add-utf8 pool (field-name field))))
536  (finalize-attributes (field-attributes field) nil class))
537
538(defun !write-field (field stream)
539  (write-u2 (field-access-flags field) stream)
540  (write-u2 (field-name field) stream)
541  (write-u2 (field-descriptor field) stream)
542  (write-attributes (field-attributes field) stream))
543
544
545(defstruct (method (:constructor %!make-method))
546  access-flags
547  name
548  descriptor
549  attributes
550  arg-count ;; not in the class file,
551            ;; but required for setting up CODE attribute
552  )
553
554
555(defun map-method-name (name)
556  (cond
557    ((eq name :class-constructor)
558     "<clinit>")
559    ((eq name :constructor)
560     "<init>")
561    (t name)))
562
563(defun !make-method (name return args &key (flags '(:public)))
564  (%make-method :descriptor (cons return args)
565                :access-flags flags
566                :name name
567                :arg-count (if (member :static flags)
568                               (length args)
569                               (1+ (length args))))) ;; implicit 'this'
570
571(defun method-add-attribute (method attribute)
572  (push attribute (method-attributes method)))
573
574(defun method-attribute (method name)
575  (find name (method-attributes method)
576        :test #'string= :key #'attribute-name))
577
578
579(defun finalize-method (method class)
580  (let ((pool (class-file-constants class)))
581    (setf (method-access-flags method)
582          (map-flags (method-access-flags method))
583          (method-descriptor method)
584          (pool-add-utf8 pool (apply #'descriptor (method-descriptor method)))
585          (method-name method)
586          (pool-add-utf8 pool (map-method-name (method-name method)))))
587  (finalize-attributes (method-attributes method) nil class))
588
589
590(defun !write-method (method stream)
591  (write-u2 (method-access-flags method) stream)
592  (write-u2 (method-name method) stream)
593  (write-u2 (method-descriptor method) stream)
594  (write-attributes (method-attributes method) stream))
595
596(defstruct attribute
597  name
598
599  ;; not in the class file:
600  finalizer  ;; function of 3 arguments: the attribute, parent and class-file
601  writer     ;; function of 2 arguments: the attribute and the output stream
602  )
603
604(defun finalize-attributes (attributes att class)
605  (dolist (attribute attributes)
606    ;; assure header: make sure 'name' is in the pool
607    (setf (attribute-name attribute)
608          (pool-add-string (class-file-constants class)
609                           (attribute-name attribute)))
610    ;; we're saving "root" attributes: attributes which have no parent
611    (funcall (attribute-finalizer attribute) attribute att class)))
612
613(defun write-attributes (attributes stream)
614  (write-u2 (length attributes) stream)
615  (dolist (attribute attributes)
616    (write-u2 (attribute-name attribute) stream)
617    ;; set up a bulk catcher for (UNSIGNED-BYTE 8)
618    ;; since we need to know the attribute length (excluding the header)
619    (let ((local-stream (sys::%make-byte-array-output-stream)))
620      (funcall (attribute-writer attribute) attribute local-stream)
621      (let ((array (sys::%get-output-stream-array local-stream)))
622        (write-u2 (length array) stream)
623        (write-sequence array stream)))))
624
625
626
627(defstruct (code-attribute (:conc-name code-)
628                           (:include attribute
629                                     (name "Code")
630                                     (finalizer #'!finalize-code)
631                                     (writer #'!write-code))
632                           (:constructor %make-code-attribute))
633  max-stack
634  max-locals
635  code
636  attributes
637  ;; labels contains offsets into the code array after it's finalized
638  (labels (make-hash-table :test #'eq))
639
640  ;; fields not in the class file start here
641  current-local ;; used for handling nested WITH-CODE-TO-METHOD blocks
642  )
643
644
645(defun code-label-offset (code label)
646  (gethash label (code-labels code)))
647
648(defun (setf code-label-offset) (offset code label)
649  (setf (gethash label (code-labels code)) offset))
650
651(defun !finalize-code (code class)
652  (let ((c (coerce (resolve-instructions (code-code code)) 'vector)))
653    (setf (code-max-stack code) (analyze-stack c)
654          (code-code code) (code-bytes c)))
655  (finalize-attributes (code-attributes code) code class))
656
657(defun !write-code (code stream)
658  (write-u2 (code-max-stack code) stream)
659  (write-u2 (code-max-locals code) stream)
660  (let ((code-array (code-code code)))
661    (write-u4 (length code-array) stream)
662    (dotimes (i (length code-array))
663      (write-u1 (svref code-array i) stream)))
664  (write-attributes (code-attributes code) stream))
665
666(defun make-code-attribute (method)
667  (%make-code-attribute :max-locals (method-arg-count method)))
668
669(defun code-add-attribute (code attribute)
670  (push attribute (code-attributes code)))
671
672(defun code-attribute (code name)
673  (find name (code-attributes code)
674        :test #'string= :key #'attribute-name))
675
676
677
678(defvar *current-code-attribute*)
679
680(defun save-code-specials (code)
681  (setf (code-code code) *code*
682        (code-max-locals code) *registers-allocated*
683        (code-exception-handlers code) *handlers*
684        (code-current-local code) *register*))
685
686(defun restore-code-specials (code)
687  (setf *code* (code-code code)
688        *registers-allocated* (code-max-locals code)
689        *register* (code-current-local code)))
690
691(defmacro with-code-to-method ((method &key safe-nesting) &body body)
692  (let ((m (gensym))
693        (c (gensym)))
694    `(progn
695       ,@(when safe-nesting
696           `((when *current-code-attribute*
697               (save-code-specials *current-code-attribute*))))
698       (let* ((,m ,method)
699              (,c (method-attribute ,m "Code"))
700              (*code* (code-code ,c))
701              (*registers-allocated* (code-max-locals ,c))
702              (*register* (code-current-local ,c))
703              (*current-code-attribute* ,c))
704         ,@body
705         (setf (code-code ,c) *code*
706               (code-exception-handlers ,c) *handlers*
707               (code-max-locals ,c) *registers-allocated*))
708       ,@(when safe-nesting
709           `((when *current-code-attribute*
710               (restore-code-specials *current-code-attribute*)))))))
711
712(defstruct (exceptions-attribute (:constructor make-exceptions)
713                                 (:conc-name exceptions-)
714                                 (:include attribute
715                                           (name "Exceptions")
716                                           (finalizer #'finalize-exceptions)
717                                           (writer #'write-exceptions)))
718  exceptions)
719
720(defun finalize-exceptions (exceptions code class)
721  (dolist (exception (exceptions-exceptions exceptions))
722    ;; no need to finalize `catch-type': it's already the index required
723    (setf (exception-start-pc exception)
724          (code-label-offset code (exception-start-pc exception))
725          (exception-end-pc exception)
726          (code-label-offset code (exception-end-pc exception))
727          (exception-handler-pc exception)
728          (code-label-offset code (exception-handler-pc exception))
729          (exception-catch-type exception)
730          (pool-add-string (class-file-constants class)
731                           (exception-catch-type exception))))
732  ;;(finalize-attributes (exceptions-attributes exception) exceptions class)
733  )
734
735
736(defun write-exceptions (exceptions stream)
737  ; number of entries
738  (write-u2 (length (exceptions-exceptions exceptions)) stream)
739  (dolist (exception (exceptions-exceptions exceptions))
740    (write-u2 (exception-start-pc exception) stream)
741    (write-u2 (exception-end-pc exception) stream)
742    (write-u2 (exception-handler-pc exception) stream)
743    (write-u2 (exception-catch-type exception) stream)))
744
745(defun code-add-exception (code start end handler type)
746  (when (null (code-attribute code "Exceptions"))
747    (code-add-attribute code (make-exceptions)))
748  (push (make-exception :start-pc start
749                        :end-pc end
750                        :handler-pc handler
751                        :catch-type type)
752        (exceptions-exceptions (code-attribute code "Exceptions"))))
753
754(defstruct exception
755  start-pc    ;; label target
756  end-pc      ;; label target
757  handler-pc  ;; label target
758  catch-type  ;; a string for a specific type, or NIL for all
759  )
760
761(defstruct (source-file-attribute (:conc-name source-)
762                                  (:include attribute
763                                            (name "SourceFile")))
764  filename)
765
766(defstruct (line-numbers-attribute (:include attribute
767                                             (name "LineNumberTable")))
768  line-numbers)
769
770(defstruct line-number
771  start-pc
772  line)
773
774(defstruct (local-variables-attribute (:conc-name local-var-)
775                                      (:include attribute
776                                                (name "LocalVariableTable")))
777  locals)
778
779(defstruct (local-variable (:conc-name local-))
780  start-pc
781  length
782  name
783  descriptor
784  index)
785
786#|
787
788;; this is the minimal sequence we need to support:
789
790;;  create a class file structure
791;;  add methods
792;;  add code to the methods, switching from one method to the other
793;;  finalize the methods, one by one
794;;  write the class file
795
796to support the sequence above, we probably need to
797be able to
798
799- find methods by signature
800- find the method's code attribute
801- add code to the code attribute
802- finalize the code attribute contents (blocking it for further addition)
803-
804
805
806|#
807
Note: See TracBrowser for help on using the repository browser.