source: trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp @ 15596

Last change on this file since 15596 was 15596, checked in by Mark Evenson, 4 months ago
  • Fixes the issue with the compile & loading of Fricas0 system (Github
    • Now the file compiler will always try to compile the form and it will only fallback to the interpreted form when the bytecode error is actually raised
  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 69.4 KB
Line 
1;;; jvm-class-file.lisp
2;;;
3;;; Copyright (C) 2010 Erik Huelsmann
4;;; $Id: jvm-class-file.lisp 15596 2022-11-26 08:35:27Z mevenson $
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(require '#:compiler-types)
34
35#|
36
37The general design of the class-file writer is to have generic
38- human readable - representations of the class being generated
39during the construction and manipulation phases.
40
41After completing the creation/manipulation of the class, all its
42components will be finalized. This process translates readable
43(e.g. string) representations to indices to be stored on disc.
44
45The only thing to be done after finalization is sending the
46output to a stream ("writing").
47
48
49Finalization happens highest-level first. As an example, take a
50method with exception handlers. The exception handlers are stored
51as attributes in the class file structure. They are children of the
52method's Code attribute. In this example, the body of the Code
53attribute (the higher level) gets finalized before the attributes.
54The reason to do so is that the exceptions need to refer to labels
55(offsets) in the Code segment.
56
57
58|#
59
60
61(defun map-primitive-type (type)
62  "Maps a symbolic primitive type name to its Java string representation."
63  (case type
64    (:int        "I")
65    (:long       "J")
66    (:float      "F")
67    (:double     "D")
68    (:boolean    "Z")
69    (:char       "C")
70    (:byte       "B")
71    (:short      "S")
72    ((nil :void) "V")))
73
74(defun pretty-class (type &optional (default-package ""))
75  (let* ((p-len (1+ (length default-package)))
76         (len (length type))
77         (cnt (when (< p-len len)
78                (count #\/ type :start p-len)))
79         (type (if (and cnt (= 0 cnt))
80                   (subseq type p-len len)
81                   (substitute #\. #\/ type))))
82    type))
83
84(defun pretty-type (type &optional (default-package ""))
85  (cond
86    ((eql #\I type) "int")
87    ((eql #\J type) "long")
88    ((eql #\F type) "float")
89    ((eql #\D type) "double")
90    ((eql #\Z type) "boolean")
91    ((eql #\C type) "char")
92    ((eql #\B type) "byte")
93    ((eql #\S type) "short")
94    ((eql #\V type) "void")
95    ((stringp type)
96     (pretty-class (subseq type 1 (1- (length type))) default-package))))
97
98#|
99
100The `class-name' facility helps to abstract from "this instruction takes
101a reference" and "this instruction takes a class name". We simply pass
102the class name around and the instructions themselves know which
103representation to use.
104
105|#
106
107(defstruct (jvm-class-name (:conc-name class-)
108                           (:constructor %make-jvm-class-name)
109                           (:print-object %print-jvm-class-name))
110  "Used for class identification.
111
112The caller should instantiate only one `class-name' per class, as they are
113used as class identifiers and compared using EQ.
114
115Some instructions need a class argument, others need a reference identifier.
116This class is used to abstract from the difference."
117  name-internal
118  ref
119  array-class ;; cached array class reference
120  ;; keeping a reference to the associated array class allows class
121  ;; name comparisons to be EQ: all classes should exist only once,
122  )
123
124(defun %print-jvm-class-name (name stream)
125  (print-unreadable-object (name stream :type t)
126    (write-string (class-name-internal name) stream)))
127
128(defun make-jvm-class-name (name)
129  "Creates a `class-name' structure for the class or interface `name'.
130
131`name' should be specified using Java representation, which is converted
132to 'internal' (JVM) representation by this function."
133  (setf name (substitute #\/ #\. name))
134  (%make-jvm-class-name :name-internal name
135                        :ref (concatenate 'string "L" name ";")))
136
137(defun class-array (class-name)
138  "Returns a class-name representing an array of `class-name'.
139For multi-dimensional arrays, call this function multiple times, using
140its own result.
141
142This function can be called multiple times on the same `class-name' without
143violating the 'only one instance' requirement: the returned value is cached
144and used on successive calls."
145  (unless (class-array-class class-name)
146    ;; Alessio Stalla found by dumping a class file that the JVM uses
147    ;; the same representation (ie '[L<class-name>;') in CHECKCAST as
148    ;; it does in field references, meaning the class name and class ref
149    ;; are identified by the same string
150    (let ((name-and-ref (concatenate 'string "[" (class-ref class-name))))
151      (setf (class-array-class class-name)
152            (%make-jvm-class-name :name-internal name-and-ref
153                                  :ref name-and-ref))))
154  (class-array-class class-name))
155
156(defmacro define-class-name (symbol java-dotted-name &optional documentation)
157  "Convenience macro to define constants for `class-name' structures,
158initialized from the `java-dotted-name'."
159  `(defconstant ,symbol (make-jvm-class-name ,java-dotted-name)
160     ,documentation))
161
162(define-class-name +java-class+ "java.lang.Class")
163(define-class-name +java-object+ "java.lang.Object")
164(define-class-name +java-string+ "java.lang.String")
165(define-class-name +java-system+ "java.lang.System")
166(define-class-name +java-stack-overflow+ "java.lang.StackOverflowError")
167(define-class-name +java-out-of-memory+ "java.lang.OutOfMemoryError")
168(define-class-name +java-io-input-stream+ "java.io.InputStream")
169(define-class-name +java-util-collection+ "java.util.Collection")
170(define-class-name +lisp-object+ "org.armedbear.lisp.LispObject")
171(defconstant +lisp-object-array+ (class-array +lisp-object+))
172(define-class-name +lisp-simple-string+ "org.armedbear.lisp.SimpleString")
173(define-class-name +lisp+ "org.armedbear.lisp.Lisp")
174(define-class-name +lisp-nil+ "org.armedbear.lisp.Nil")
175(define-class-name +lisp-class+ "org.armedbear.lisp.LispClass")
176(define-class-name +lisp-symbol+ "org.armedbear.lisp.Symbol")
177(define-class-name +lisp-thread+ "org.armedbear.lisp.LispThread")
178(define-class-name +lisp-closure-binding+ "org.armedbear.lisp.ClosureBinding")
179(defconstant +closure-binding-array+ (class-array +lisp-closure-binding+))
180(define-class-name +lisp-integer+ "org.armedbear.lisp.LispInteger")
181(define-class-name +lisp-fixnum+ "org.armedbear.lisp.Fixnum")
182(defconstant +lisp-fixnum-array+ (class-array +lisp-fixnum+))
183(define-class-name +lisp-bignum+ "org.armedbear.lisp.Bignum")
184(define-class-name +lisp-single-float+ "org.armedbear.lisp.SingleFloat")
185(define-class-name +lisp-double-float+ "org.armedbear.lisp.DoubleFloat")
186(define-class-name +lisp-cons+ "org.armedbear.lisp.Cons")
187(define-class-name +lisp-load+ "org.armedbear.lisp.Load")
188(define-class-name +lisp-character+ "org.armedbear.lisp.LispCharacter")
189(defconstant +lisp-character-array+ (class-array +lisp-character+))
190(define-class-name +lisp-structure-object+ "org.armedbear.lisp.StructureObject")
191(define-class-name +lisp-simple-vector+ "org.armedbear.lisp.SimpleVector")
192(define-class-name +lisp-abstract-string+ "org.armedbear.lisp.AbstractString")
193(define-class-name +lisp-abstract-vector+ "org.armedbear.lisp.AbstractVector")
194(define-class-name +lisp-abstract-bit-vector+
195    "org.armedbear.lisp.AbstractBitVector")
196(define-class-name +lisp-environment+ "org.armedbear.lisp.Environment")
197(define-class-name +lisp-special-binding+ "org.armedbear.lisp.SpecialBinding")
198(define-class-name +lisp-special-bindings-mark+
199    "org.armedbear.lisp.SpecialBindingsMark")
200(define-class-name +lisp-throw+ "org.armedbear.lisp.Throw")
201(define-class-name +lisp-return+ "org.armedbear.lisp.Return")
202(define-class-name +lisp-go+ "org.armedbear.lisp.Go")
203(define-class-name +lisp-primitive+ "org.armedbear.lisp.Primitive")
204(define-class-name +lisp-compiled-primitive+
205    "org.armedbear.lisp.CompiledPrimitive")
206(define-class-name +lisp-eql-hash-table+ "org.armedbear.lisp.EqlHashTable")
207(define-class-name +lisp-hash-table+ "org.armedbear.lisp.HashTable")
208(define-class-name +lisp-package+ "org.armedbear.lisp.Package")
209(define-class-name +lisp-readtable+ "org.armedbear.lisp.Readtable")
210(define-class-name +lisp-stream+ "org.armedbear.lisp.Stream")
211(define-class-name +lisp-operator+ "org.armedbear.lisp.Operator")
212(define-class-name +lisp-closure+ "org.armedbear.lisp.Closure")
213(define-class-name +lisp-compiled-closure+ "org.armedbear.lisp.CompiledClosure")
214(define-class-name +argument-list-processor+
215    "org.armedbear.lisp.ArgumentListProcessor")
216(define-class-name +alp-required-parameter+
217    "org.armedbear.lisp.ArgumentListProcessor$RequiredParam")
218(define-class-name +alp-optional-parameter+
219    "org.armedbear.lisp.ArgumentListProcessor$OptionalParam")
220(define-class-name +alp-keyword-parameter+
221    "org.armedbear.lisp.ArgumentListProcessor$KeywordParam")
222
223#|
224
225Lisp-side descriptor representation:
226
227 - list: a list starting with a method return value, followed by
228     the argument types
229 - keyword: the primitive type associated with that keyword
230 - class-name structure instance: the class-ref value
231
232The latter two can be converted to a Java representation using
233the `internal-field-ref' function, the former is to be fed to
234`descriptor'.
235
236|#
237
238(defun internal-field-type (field-type)
239  "Returns a string containing the JVM-internal representation
240of `field-type', which should either be a symbol identifying a primitive
241type, or a `class-name' structure identifying a class or interface."
242  (if (symbolp field-type)
243      (map-primitive-type field-type)
244      (class-name-internal field-type)))
245
246(defun internal-field-ref (field-type)
247  "Returns a string containing the JVM-internal representation of a reference
248to `field-type', which should either be a symbol identifying a primitive
249type, or a `class-name' structure identifying a class or interface."
250  (if (symbolp field-type)
251      (map-primitive-type field-type)
252      (class-ref field-type)))
253
254(defun descriptor (return-type &rest argument-types)
255  "Returns a string describing the `return-type' and `argument-types'
256in JVM-internal representation."
257  (let* ((arg-strings (mapcar #'internal-field-ref argument-types))
258         (ret-string (internal-field-ref return-type))
259         (size (+ 2 (reduce #'+ arg-strings
260                            :key #'length
261                            :initial-value (length ret-string))))
262         (str (make-array size :fill-pointer 0 :element-type 'character)))
263    (with-output-to-string (s str)
264      (princ #\( s)
265      (dolist (arg-string arg-strings)
266        (princ arg-string s))
267      (princ #\) s)
268      (princ ret-string s))
269    str)
270;;  (format nil "(~{~A~})~A"
271;;          (internal-field-ref return-type))
272  )
273
274(defun descriptor-stack-effect (return-type &rest argument-types)
275  "Returns the effect on the stack position of the `argument-types' and
276`return-type' of a method call.
277
278If the method consumes an implicit `this' argument, this function does not
279take that effect into account."
280  (flet ((type-stack-effect (arg)
281           (case arg
282             ((:long :double) 2)
283             ((nil :void) 0)
284             (otherwise 1))))
285    (+ (reduce #'- argument-types
286               :key #'type-stack-effect
287               :initial-value 0)
288       (type-stack-effect return-type))))
289
290
291(defstruct pool
292  ;; `index' contains the index of the last allocated slot (0 == empty)
293  ;; "A constant pool entry is considered valid if it has
294  ;; an index greater than 0 (zero) and less than pool-count"
295  (index 0)
296  entries-list
297  ;; the entries hash stores raw values, except in case of string and
298  ;; utf8, because both are string values in which case a two-element
299  ;; list - containing the tag and the value - is used
300  (entries (make-hash-table :test #'equal :size 2048 :rehash-size 2.0)))
301
302(defun matching-index-p (entry index)
303  (eql (constant-index entry) index))
304
305(defun find-pool-entry (pool item &key (test #'matching-index-p))
306  (find-if (lambda (x)
307             (funcall test x item))
308           (pool-entries-list pool)))
309
310
311(defstruct constant
312  "Structure to be included in all constant sub-types."
313  tag
314  index)
315
316(defgeneric print-pool-constant (pool entry stream &key &allow-other-keys)
317  (:method (pool (entry t) stream &key)
318    (print-object entry stream)))
319
320(defmethod print-pool-constant :around (pool entry stream &key recursive)
321  (cond
322    ((and (null *print-readably*)
323          (null *print-escape*)
324          (null recursive))
325     (princ #\# stream)
326     (princ (constant-index entry) stream)
327     (princ #\Space stream)
328     (princ #\< stream)
329     (call-next-method)
330     (princ #\> stream))
331    (t
332     (call-next-method))))
333
334(defparameter +constant-type-map+
335  '((:class          7 1)
336    (:field-ref      9 1)
337    (:method-ref    10 1)
338    ;; (:interface-method-ref 11)
339    (:string         8 1)
340    (:integer        3 1)
341    (:float          4 1)
342    (:long           5 2)
343    (:double         6 2)
344    (:name-and-type 12 1)
345    (:utf8           1 1)))
346
347(defstruct (constant-class (:constructor make-constant-class (index name-index))
348                           (:include constant
349                                     (tag 7)))
350  "Structure holding information on a 'class' type item in the constant pool."
351  name-index)
352
353(defmethod print-pool-constant (pool (entry constant-class) stream
354                                &key recursive package)
355  (cond
356    ((and (null *print-escape*)
357          (null *print-readably*))
358     ;; human readable
359     (unless recursive
360       (princ "Class " stream))
361     (princ
362      (pretty-class (constant-utf8-value
363                     (find-pool-entry pool
364                                      (constant-class-name-index entry)))
365                    package)
366      stream))
367    (t
368     ;; READable
369     (call-next-method))))
370
371(defstruct (constant-member-ref (:constructor
372                                 %make-constant-member-ref
373                                     (tag index class-index name/type-index))
374                                (:include constant))
375  "Structure holding information on a member reference type item
376(a field, method or interface method reference) in the constant pool."
377  class-index
378  name/type-index)
379
380(defmethod print-pool-constant (pool (entry constant-member-ref) stream
381                                &key recursive package)
382  (cond
383    ((and (null *print-escape*)
384          (null *print-readably*))
385     ;; human readable
386     (unless recursive
387       (princ (case (constant-member-ref-tag entry)
388                (9 "Field ")
389                (10 "Method ")
390                (11 "Interface method "))
391              stream))
392     (let ((name-prefix
393            (with-output-to-string (s)
394              (print-pool-constant pool
395                          (find-pool-entry pool
396                                           (constant-member-ref-class-index entry))
397                          s
398                          :recursive t
399                          :package package)
400              (princ #\. s))))
401       (print-pool-constant pool
402                            (find-pool-entry pool
403                                             (constant-member-ref-name/type-index entry))
404                            stream
405                            :name-prefix name-prefix
406                            :recursive t
407                            :package package)))
408    (t
409     ;; READable
410     (call-next-method))))
411
412
413(declaim (inline make-constant-field-ref make-constant-method-ref
414                 make-constant-interface-method-ref))
415(defun make-constant-field-ref (index class-index name/type-index)
416  "Creates a `constant-member-ref' instance containing a field reference."
417  (%make-constant-member-ref 9 index class-index name/type-index))
418
419(defun make-constant-method-ref (index class-index name/type-index)
420  "Creates a `constant-member-ref' instance containing a method reference."
421  (%make-constant-member-ref 10 index class-index name/type-index))
422
423(defun make-constant-interface-method-ref (index class-index name/type-index)
424  "Creates a `constant-member-ref' instance containing an
425interface-method reference."
426  (%make-constant-member-ref 11 index class-index name/type-index))
427
428(defstruct (constant-string (:constructor
429                             make-constant-string (index value-index))
430                            (:include constant
431                                      (tag 8)))
432  "Structure holding information on a 'string' type item in the constant pool."
433  value-index)
434
435
436(defmethod print-pool-constant (pool (entry constant-string) stream
437                                &key recursive)
438  (cond
439    ((and (null *print-readably*)
440          (null *print-escape*))
441     (unless recursive
442       (princ "String " stream))
443     (princ #\" stream)
444     (print-pool-constant pool
445                          (find-pool-entry pool
446                                           (constant-string-value-index entry))
447                          stream
448                          :recursive t)
449     (princ #\" stream))
450    (t
451     (call-next-method))))
452
453(defstruct (constant-float/int (:constructor
454                                %make-constant-float/int (tag index value))
455                               (:include constant))
456  "Structure holding information on a 'float' or 'integer' type item
457in the constant pool."
458  value)
459
460(defmethod print-pool-constant (pool (entry constant-float/int) stream
461                                &key recursive)
462  (cond
463    ((and (null *print-escape*)
464          (null *print-readably*))
465     (unless recursive
466       (princ (case (constant-tag entry)
467                (3 "int ")
468                (4 "float "))
469              stream))
470     (princ (constant-float/int-value entry) stream))
471    (t
472     (call-next-method))))
473
474(declaim (inline make-constant-float make-constant-int))
475(defun make-constant-float (index value)
476  "Creates a `constant-float/int' structure instance containing a float."
477  (%make-constant-float/int 4 index value))
478
479(defun make-constant-int (index value)
480  "Creates a `constant-float/int' structure instance containing an int."
481  (%make-constant-float/int 3 index value))
482
483(defstruct (constant-double/long (:constructor
484                                  %make-constant-double/long (tag index value))
485                                 (:include constant))
486  "Structure holding information on a 'double' or 'long' type item
487in the constant pool."
488  value)
489
490(defmethod print-pool-constant (pool (entry constant-double/long) stream
491                                &key recursive)
492  (cond
493    ((and (null *print-escape*)
494          (null *print-readably*))
495     (unless recursive
496       (princ (case (constant-tag entry)
497                (5 "long ")
498                (6 "double "))
499              stream))
500     (princ (constant-double/long-value entry) stream))
501    (t
502     (call-next-method))))
503
504(declaim (inline make-constant-double make-constant-float))
505(defun make-constant-double (index value)
506  "Creates a `constant-double/long' structure instance containing a double."
507  (%make-constant-double/long 6 index value))
508
509(defun make-constant-long (index value)
510  "Creates a `constant-double/long' structure instance containing a long."
511  (%make-constant-double/long 5 index value))
512
513(defstruct (constant-name/type (:constructor
514                                make-constant-name/type (index
515                                                         name-index
516                                                         descriptor-index))
517                               (:include constant
518                                         (tag 12)))
519  "Structure holding information on a 'name-and-type' type item in the
520constant pool; this type of element is used by 'member-ref' type items."
521  name-index
522  descriptor-index)
523
524(defun parse-descriptor (descriptor)
525  (let (arguments
526        method-descriptor-p
527        (index 0))
528    (when (eql (aref descriptor 0) #\()
529      ;; parse the arguments here...
530      (assert (find #\) descriptor))
531      (setf method-descriptor-p t)
532      (loop until (eql (aref descriptor index) #\))
533         do (incf index)
534         if (find (aref descriptor index) "IJFDZCBSV")
535         do (push (aref descriptor index) arguments)
536         if (eql (aref descriptor index) #\L)
537         do (loop for i upfrom index
538               until (eql (aref descriptor i) #\;)
539               finally (push (subseq descriptor index (1+ i))
540                             arguments)
541               finally (setf index i))
542         finally (incf index)))
543    (values (let ((return-value (subseq descriptor index)))
544              (if (= (length return-value) 1)
545                  (aref return-value 0)
546                  return-value))
547            (nreverse arguments)
548            method-descriptor-p)))
549
550(defmethod print-pool-constant (pool (entry constant-name/type) stream
551                                &key name-prefix package)
552  (cond
553    ((and (null *print-readably*)
554          (null *print-escape*))
555     (multiple-value-bind
556           (type arguments method-descriptor-p)
557         (let ((entry (find-pool-entry pool
558                            (constant-name/type-descriptor-index entry))))
559           (if (constant-utf8-p entry)
560               (parse-descriptor (constant-utf8-value entry))
561               (class-ref entry)))
562       (princ (pretty-type type package) stream)
563       (princ #\Space stream)
564       (when name-prefix
565         (princ name-prefix stream))
566       (print-pool-constant pool
567                            (find-pool-entry pool (constant-name/type-name-index entry))
568                            stream
569                            :recursive t)
570       (when method-descriptor-p
571         (format stream "(~{~A~^,~})" (mapcar (lambda (x)
572                                                (pretty-type x package))
573                                              arguments)))))
574    (t
575     (call-next-method))))
576
577(defstruct (constant-utf8 (:constructor make-constant-utf8 (index value))
578                          (:include constant
579                                    (tag 1)))
580  "Structure holding information on a 'utf8' type item in the constant pool;
581
582This type of item is used for text representation of identifiers
583and string contents."
584  value)
585
586
587(defun pool-add-class (pool class)
588  "Returns the index of the constant-pool class item for `class'.
589
590`class' must be an instance of `class-name' or a string (which will be converted
591to a `class-name')."
592  (let ((class (if (jvm-class-name-p class)
593                   class
594                   (make-jvm-class-name class))))
595    (let ((entry (gethash class (pool-entries pool))))
596      (unless entry
597        (let ((utf8 (pool-add-utf8 pool (class-name-internal class))))
598          (setf entry
599                (make-constant-class (incf (pool-index pool)) utf8)
600                (gethash class (pool-entries pool)) entry))
601        (push entry (pool-entries-list pool)))
602      (constant-index entry))))
603
604(defun pool-add-field-ref (pool class name type)
605  "Returns the index of the constant-pool item which denotes a reference
606to the `name' field of the `class', being of `type'.
607
608`class' should be an instance of `class-name'.
609`name' is a string.
610`type' is a field-type (see `internal-field-type')"
611  (let ((entry (gethash (acons name type class) (pool-entries pool))))
612    (unless entry
613      (let ((c (pool-add-class pool class))
614            (n/t (pool-add-name/type pool name type)))
615        (setf entry (make-constant-field-ref (incf (pool-index pool)) c n/t)
616            (gethash (acons name type class) (pool-entries pool)) entry))
617      (push entry (pool-entries-list pool)))
618    (constant-index entry)))
619
620(defun pool-add-method-ref (pool class name type)
621  "Returns the index of the constant-pool item which denotes a reference
622to the method with `name' in `class', which is of `type'.
623
624Here, `type' is a method descriptor, which defines the argument types
625and return type. `class' is an instance of `class-name'."
626  (let ((entry (gethash (acons name type class) (pool-entries pool))))
627    (unless entry
628      (let ((c (pool-add-class pool class))
629            (n/t (pool-add-name/type pool name type)))
630        (setf entry (make-constant-method-ref (incf (pool-index pool)) c n/t)
631              (gethash (acons name type class) (pool-entries pool)) entry))
632      (push entry (pool-entries-list pool)))
633    (constant-index entry)))
634
635(defun pool-add-interface-method-ref (pool class name type)
636  "Returns the index of the constant-pool item which denotes a reference to
637the method `name' in the interface `class', which is of `type'.
638
639See `pool-add-method-ref' for remarks."
640  (let ((entry (gethash (acons name type class) (pool-entries pool))))
641    (unless entry
642      (let ((c (pool-add-class pool class))
643            (n/t (pool-add-name/type pool name type)))
644        (setf entry
645            (make-constant-interface-method-ref (incf (pool-index pool)) c n/t)
646            (gethash (acons name type class) (pool-entries pool)) entry))
647      (push entry (pool-entries-list pool)))
648    (constant-index entry)))
649
650(defun pool-add-string (pool string)
651  "Returns the index of the constant-pool item denoting the string."
652  (let ((entry (gethash (cons 8 string) ;; 8 == string-tag
653                        (pool-entries pool))))
654    (unless entry
655      (let ((utf8 (pool-add-utf8 pool string)))
656        (setf entry (make-constant-string (incf (pool-index pool)) utf8)
657              (gethash (cons 8 string) (pool-entries pool)) entry))
658      (push entry (pool-entries-list pool)))
659    (constant-index entry)))
660
661(defun pool-add-int (pool int)
662  "Returns the index of the constant-pool item denoting the int."
663  (let ((entry (gethash (cons 3 int) (pool-entries pool))))
664    (unless entry
665      (setf entry (make-constant-int (incf (pool-index pool)) int)
666            (gethash (cons 3 int) (pool-entries pool)) entry)
667      (push entry (pool-entries-list pool)))
668    (constant-index entry)))
669
670(defun pool-add-float (pool float)
671  "Returns the index of the constant-pool item denoting the float."
672  (let ((entry (gethash (cons 4 float) (pool-entries pool))))
673    (unless entry
674      (setf entry (make-constant-float (incf (pool-index pool))
675                                       (sys::%float-bits float))
676            (gethash (cons 4 float) (pool-entries pool)) entry)
677      (push entry (pool-entries-list pool)))
678    (constant-index entry)))
679
680(defun pool-add-long (pool long)
681  "Returns the index of the constant-pool item denoting the long."
682  (let ((entry (gethash (cons 5 long) (pool-entries pool))))
683    (unless entry
684      (setf entry (make-constant-long (incf (pool-index pool)) long)
685            (gethash (cons 5 long) (pool-entries pool)) entry)
686      (push entry (pool-entries-list pool))
687      (incf (pool-index pool))) ;; double index increase; long takes 2 slots
688    (constant-index entry)))
689
690(defun pool-add-double (pool double)
691  "Returns the index of the constant-pool item denoting the double."
692  (let ((entry (gethash (cons 6 double) (pool-entries pool))))
693    (unless entry
694      (setf entry (make-constant-double (incf (pool-index pool))
695                                        (sys::%float-bits double))
696            (gethash (cons 6 double) (pool-entries pool)) entry)
697      (push entry (pool-entries-list pool))
698      (incf (pool-index pool))) ;; double index increase; 'double' takes 2 slots
699    (constant-index entry)))
700
701(defun pool-add-name/type (pool name type)
702  "Returns the index of the constant-pool item denoting
703the name/type identifier."
704  (let ((entry (gethash (cons name type) (pool-entries pool)))
705        (internal-type (if (listp type)
706                           (apply #'descriptor type)
707                           (internal-field-ref type))))
708    (unless entry
709      (let ((n (pool-add-utf8 pool name))
710            (i-t (pool-add-utf8 pool internal-type)))
711        (setf entry (make-constant-name/type (incf (pool-index pool)) n i-t)
712              (gethash (cons name type) (pool-entries pool)) entry))
713      (push entry (pool-entries-list pool)))
714    (constant-index entry)))
715
716(defun pool-add-utf8 (pool utf8-as-string)
717  "Returns the index of the textual value that will be stored in the
718class file as UTF-8 encoded data."
719  (let ((entry (gethash (cons 11 utf8-as-string) ;; 11 == utf8
720                        (pool-entries pool))))
721    (unless entry
722      (setf entry (make-constant-utf8 (incf (pool-index pool)) utf8-as-string)
723            (gethash (cons 11 utf8-as-string) (pool-entries pool)) entry)
724      (push entry (pool-entries-list pool)))
725    (constant-index entry)))
726
727(defstruct (class-file (:constructor
728                        make-class-file (class superclass access-flags)))
729  "Holds the components of a class file."
730  (constants (make-pool))
731  access-flags
732  class
733  superclass
734  interfaces
735  fields
736  methods
737  attributes)
738
739(defun make-class-interface-file (class)
740  "Create the components of a class file representing a public Java
741interface."
742  (make-class-file class +java-object+ '(:public :abstract :interface)))
743
744(defun class-add-field (class field)
745  "Adds a `field' created by `make-field'."
746  (push field (class-file-fields class)))
747
748(defun class-field (class name)
749  "Finds a field by name." ;; ### strictly speaking, a field is uniquely
750  ;; identified by its name and type, not by the name alone.
751  (find name (class-file-fields class)
752        :test #'string= :key #'field-name))
753
754(defun class-add-method (class method)
755  "Adds a `method' to `class'; the method must have been created using
756`make-jvm-method'."
757  (push method (class-file-methods class)))
758
759(defun class-methods-by-name (class name)
760  "Returns all methods which have `name'."
761  (remove (map-method-name name) (class-file-methods class)
762          :test-not #'string= :key #'method-name))
763
764(defun class-method (class name return &rest args)
765  "Return the method which is (uniquely) identified by its name AND descriptor."
766  (let ((return-and-args (cons return args))
767        (name (map-method-name name)))
768    (find-if #'(lambda (c)
769                 (and (string= (method-name c) name)
770                      (equal (method-descriptor c) return-and-args)))
771             (class-file-methods class))))
772
773(defun class-remove-method (class method)
774  (setf (class-file-methods class)
775        (remove method (class-file-methods class)))
776  method)
777
778(defun class-add-attribute (class attribute)
779  "Adds `attribute' to the class; attributes must be instances of
780structure classes which include the `attribute' structure class."
781  (push attribute (class-file-attributes class)))
782
783(defun class-add-superinterface (class interface)
784  "Adds the java-class-name contained in `interface' as a superinterface of the `class'.
785
786For a class that represents an object, the requirements in `interface'
787must then be implemented in the class.  For a class that represents an
788interface, the `interface' imposes additional requirements to the
789classes which implement this class."
790  (push interface (class-file-interfaces class)))
791
792(defun class-attribute (class name)
793  "Returns the attribute which is named `name'."
794  (find name (class-file-attributes class)
795        :test #'string= :key #'attribute-name))
796
797(defun finalize-interfaces (class)
798  "Finalize the interfaces for `class'.
799
800Interface finalization first ensures that all the classes referenced
801by the interfaces members exist in the pool.  Then, it destructively
802modfies the interfaces members with a list of the references to the
803corresponding pool indices."
804  (let ((interface-refs nil))
805    (dolist (interface (class-file-interfaces class))
806      (push
807       (pool-add-class (class-file-constants class)
808                       interface)
809       interface-refs))
810    (setf (class-file-interfaces class) interface-refs)))
811
812(defun finalize-class-file (class)
813  "Transforms the representation of the class-file from one
814which allows easy modification to one which works best for serialization.
815
816The class can't be modified after finalization."
817
818  ;; constant pool contains constants finalized on addition;
819  ;; no need for additional finalization
820
821  (setf (class-file-access-flags class)
822        (map-flags (class-file-access-flags class)))
823  (setf (class-file-superclass class)
824        (pool-add-class (class-file-constants class)
825                        (class-file-superclass class))
826        (class-file-class class)
827        (pool-add-class (class-file-constants class)
828                        (class-file-class class)))
829  (finalize-interfaces class)
830  (dolist (field (class-file-fields class))
831    (finalize-field field class))
832  (dolist (method (class-file-methods class))
833    (finalize-method method class))
834  ;; top-level attributes (no parent attributes to refer to)
835  (finalize-attributes (class-file-attributes class) nil class))
836
837
838(declaim (inline write-u1 write-u2 write-u4 write-s4))
839(defun write-u1 (n stream)
840  (declare (optimize speed))
841  (declare (type (unsigned-byte 8) n))
842  (declare (type stream stream))
843  (write-8-bits n stream))
844
845(defknown write-u2 (t t) t)
846(defun write-u2 (n stream)
847  (declare (optimize speed))
848  (declare (type (unsigned-byte 16) n))
849  (declare (type stream stream))
850  (write-8-bits (logand (ash n -8) #xFF) stream)
851  (write-8-bits (logand n #xFF) stream))
852
853(defknown write-u4 (integer stream) t)
854(defun write-u4 (n stream)
855  (declare (optimize speed))
856  (declare (type (unsigned-byte 32) n))
857  (write-u2 (logand (ash n -16) #xFFFF) stream)
858  (write-u2 (logand n #xFFFF) stream))
859
860(declaim (ftype (function (t t) t) write-s4))
861(defun write-s4 (n stream)
862  (declare (optimize speed))
863  (cond ((minusp n)
864         (write-u4 (1+ (logxor (- n) #xFFFFFFFF)) stream))
865        (t
866         (write-u4 n stream))))
867
868(declaim (ftype (function (t t t) t) write-ascii))
869(defun write-ascii (string length stream)
870  (declare (type string string))
871  (declare (type (unsigned-byte 16) length))
872  (declare (type stream stream))
873  (write-u2 length stream)
874  (dotimes (i length)
875    (declare (type (unsigned-byte 16) i))
876    (write-8-bits (char-code (char string i)) stream)))
877
878
879(declaim (ftype (function (t t) t) write-utf8))
880(defun write-utf8 (string stream)
881  (declare (optimize speed))
882  (declare (type string string))
883  (declare (type stream stream))
884  (let ((length (length string))
885        (must-convert nil))
886    (declare (type fixnum length))
887    (dotimes (i length)
888      (declare (type fixnum i))
889      (unless (< 0 (char-code (char string i)) #x80)
890        (setf must-convert t)
891        (return)))
892    (if must-convert
893        (let ((octets (make-array (* length 2)
894                                  :element-type '(unsigned-byte 8)
895                                  :adjustable t
896                                  :fill-pointer 0)))
897          (declare (type (vector (unsigned-byte 8)) octets))
898          (dotimes (i length)
899            (declare (type fixnum i))
900            (let* ((c (char string i))
901                   (n (char-code c)))
902              (cond ((zerop n)
903                     (vector-push-extend #xC0 octets)
904                     (vector-push-extend #x80 octets))
905                    ((< 0 n #x80)
906                     (vector-push-extend n octets))
907                    (t
908                     (let ((char-octets (char-to-utf8 c)))
909                       (dotimes (j (length char-octets))
910                         (declare (type fixnum j))
911                         (vector-push-extend (svref char-octets j) octets)))))))
912          (write-u2 (length octets) stream)
913          (dotimes (i (length octets))
914            (declare (type fixnum i))
915            (write-8-bits (aref octets i) stream)))
916        (write-ascii string length stream))))
917
918
919(defun write-class-file (class stream)
920  "Serializes `class' to `stream', after it has been finalized."
921
922  ;; header
923  (write-u4 #xCAFEBABE stream)
924  (write-u2 0 stream)
925  (write-u2 49 stream)  ;; our <clinit> methods use class literals
926  ;; which require a high enough class file format
927  ;; we used to have 45, but the LDC instruction doesn't support
928  ;; class literals in that version... (49 == Java 1.5)
929
930   ;; constants pool
931  (write-constants (class-file-constants class) stream)
932  ;; flags
933  (write-u2  (class-file-access-flags class) stream)
934
935  ;; class name
936  (write-u2 (class-file-class class) stream)
937
938  ;; superclass
939  (write-u2 (class-file-superclass class) stream)
940
941  ;; interfaces
942  (if (class-file-interfaces class)
943      (progn
944        (write-u2 (length (class-file-interfaces class)) stream)
945        (dolist (interface-ref (class-file-interfaces class))
946          (write-u2 interface-ref stream)))
947      (write-u2 0 stream))
948
949  ;; fields
950  (write-u2 (length (class-file-fields class)) stream)
951  (dolist (field (class-file-fields class))
952    (write-field field stream))
953
954  ;; methods
955  (write-u2 (length (class-file-methods class)) stream)
956  (dolist (method (class-file-methods class))
957    (write-method method stream))
958
959  ;; attributes
960  (write-attributes (class-file-attributes class) stream))
961
962
963(defvar *jvm-class-debug-pool* nil
964  "When bound to a non-NIL value, enables output to *standard-output*
965to allow debugging output of the constant section of the class file.")
966
967(defun write-constants (constants stream)
968  "Writes the constant section given in `constants' to the class file `stream'."
969  (let ((pool-index 0))
970    (write-u2 (1+ (pool-index constants)) stream)
971    (when *jvm-class-debug-pool*
972      (sys::%format t "pool count ~A~%" (pool-index constants)))
973    (dolist (entry (reverse (pool-entries-list constants)))
974      (incf pool-index)
975      (let ((tag (constant-tag entry)))
976        (when *jvm-class-debug-pool*
977          (print-entry entry t))
978        (write-u1 tag stream)
979        (case tag
980          (1                            ; UTF8
981           (write-utf8 (constant-utf8-value entry) stream))
982          ((3 4)                        ; float int
983           (write-u4 (constant-float/int-value entry) stream))
984          ((5 6)                        ; long double
985           (write-u4 (logand (ash (constant-double/long-value entry) -32)
986                             #xFFFFffff) stream)
987           (write-u4 (logand (constant-double/long-value entry) #xFFFFffff)
988                     stream))
989          ((9 10 11)           ; fieldref methodref InterfaceMethodref
990           (write-u2 (constant-member-ref-class-index entry) stream)
991           (write-u2 (constant-member-ref-name/type-index entry) stream))
992          (12                           ; nameAndType
993           (write-u2 (constant-name/type-name-index entry) stream)
994           (write-u2 (constant-name/type-descriptor-index entry) stream))
995          (7                            ; class
996           (write-u2 (constant-class-name-index entry) stream))
997          (8                            ; string
998           (write-u2 (constant-string-value-index entry) stream))
999          (t
1000           (error "write-constant-pool-entry unhandled tag ~D~%" tag)))))))
1001
1002
1003(defun print-entry (entry stream)
1004  "Debugging helper to print the content of a constant-pool entry."
1005  (let ((tag (constant-tag entry))
1006        (index (constant-index entry)))
1007    (sys::%format stream "pool element ~a, tag ~a, " index tag)
1008    (case tag
1009      (1     (sys::%format t "utf8: ~a~%" (constant-utf8-value entry)))
1010      ((3 4) (sys::%format t "f/i: ~a~%" (constant-float/int-value entry)))
1011      ((5 6) (sys::%format t "d/l: ~a~%" (constant-double/long-value entry)))
1012      ((9 10 11) (sys::%format t "ref: ~a,~a~%"
1013                               (constant-member-ref-class-index entry)
1014                               (constant-member-ref-name/type-index entry)))
1015      (12 (sys::%format t "n/t: ~a,~a~%"
1016                        (constant-name/type-name-index entry)
1017                        (constant-name/type-descriptor-index entry)))
1018      (7 (sys::%format t "cls: ~a~%" (constant-class-name-index entry)))
1019      (8 (sys::%format t "str: ~a~%" (constant-string-value-index entry))))))
1020
1021
1022(defmethod print-pool-constant (pool (entry constant-utf8) stream &key)
1023  (if (and (null *print-escape*)
1024           (null *print-readably*))
1025      (princ (constant-utf8-value entry) stream)
1026      (call-next-method)))
1027
1028
1029#|
1030
1031ABCL doesn't use interfaces, so don't implement it here at this time
1032
1033(defstruct interface)
1034
1035|#
1036
1037
1038(defparameter +access-flags-map+
1039  '((:public       #x0001)
1040    (:private      #x0002)
1041    (:protected    #x0004)
1042    (:static       #x0008)
1043    (:final        #x0010)
1044    (:volatile     #x0040)
1045    (:synchronized #x0020)
1046    (:transient    #x0080)
1047    (:native       #x0100)
1048    (:interface    #x0200)
1049    (:abstract     #x0400)
1050    (:strict       #x0800))
1051  "List of keyword symbols used for human readable representation of (access)
1052flags and their binary values.")
1053
1054(defun map-flags (flags)
1055  "Calculates the bitmap of the flags from a list of symbols."
1056  (reduce #'(lambda (y x)
1057              (logior (or (when (member (car x) flags)
1058                            (second x))
1059                          0) y))
1060          +access-flags-map+
1061          :initial-value 0))
1062
1063(defstruct (field (:constructor %make-field))
1064  "Holds information on the properties of fields in the class(-file)."
1065  access-flags
1066  name
1067  descriptor
1068  attributes)
1069
1070(defun make-field (name type &key (flags '(:public)))
1071  "Creates a field for addition to a class file."
1072  (%make-field :access-flags flags
1073               :name name
1074               :descriptor type))
1075
1076(defun field-add-attribute (field attribute)
1077  "Adds an attribute to a field."
1078  (push attribute (field-attributes field)))
1079
1080(defun field-attribute (field name)
1081  "Retrieves an attribute named `name' of `field'.
1082
1083Returns NIL if the attribute isn't found."
1084  (find name (field-attributes field)
1085        :test #'string= :key #'attribute-name))
1086
1087(defun finalize-field (field class)
1088  "Prepares `field' for serialization."
1089  (let ((pool (class-file-constants class)))
1090    (setf (field-access-flags field)
1091          (map-flags (field-access-flags field))
1092          (field-descriptor field)
1093          (pool-add-utf8 pool (internal-field-ref (field-descriptor field)))
1094          (field-name field)
1095          (pool-add-utf8 pool (field-name field))))
1096  (finalize-attributes (field-attributes field) nil class))
1097
1098(defun write-field (field stream)
1099  "Writes classfile representation of `field' to `stream'."
1100  (write-u2 (field-access-flags field) stream)
1101  (write-u2 (field-name field) stream)
1102  (write-u2 (field-descriptor field) stream)
1103  (write-attributes (field-attributes field) stream))
1104
1105
1106(defstruct (jvm-method (:constructor %make-jvm-method)
1107                       (:conc-name method-))
1108  "Holds information on the properties of methods in the class(-file)."
1109  access-flags
1110  name
1111  descriptor
1112  attributes)
1113
1114
1115(defun map-method-name (name)
1116  "Methods should be identified by strings containing their names, or,
1117be one of two keyword identifiers to identify special methods:
1118
1119 * :static-initializer
1120 * :constructor
1121"
1122  (cond
1123    ((eq name :static-initializer)
1124     "<clinit>")
1125    ((eq name :constructor)
1126     "<init>")
1127    (t name)))
1128
1129(defun make-jvm-method (name return args &key (flags '(:public)))
1130  "Creates a method for addition to a class file."
1131  (%make-jvm-method :descriptor (cons return args)
1132                    :access-flags flags
1133                    :name (map-method-name name)))
1134
1135(defun method-add-attribute (method attribute)
1136  "Add `attribute' to the list of attributes of `method',
1137returning `attribute'."
1138  (push attribute (method-attributes method))
1139  attribute)
1140
1141(defun method-add-code (method &optional (optimize t))
1142  "Creates an (empty) 'Code' attribute for the method,
1143returning the created attribute."
1144  (method-add-attribute
1145   method
1146   (make-code-attribute (+ (length (cdr (method-descriptor method)))
1147                           (if (member :static (method-access-flags method))
1148                               0 1)) ;; 1 == implicit 'this'
1149                        optimize)))
1150
1151(defun method-ensure-code (method &optional (optimize t))
1152  "Ensures the existence of a 'Code' attribute for the method,
1153returning the attribute."
1154  (let ((code (method-attribute method "Code")))
1155    (if (null code)
1156        (method-add-code method optimize)
1157        code)))
1158
1159(defun method-attribute (method name)
1160  "Returns the first attribute of `method' with `name'."
1161  (find name (method-attributes method)
1162        :test #'string= :key #'attribute-name))
1163
1164
1165(defun finalize-method (method class)
1166  "Prepares `method' for serialization."
1167  (let ((pool (class-file-constants class)))
1168    (setf (method-access-flags method)
1169          (map-flags (method-access-flags method))
1170          (method-descriptor method)
1171          (pool-add-utf8 pool (apply #'descriptor (method-descriptor method)))
1172          (method-name method)
1173          (pool-add-utf8 pool (method-name method))))
1174  (finalize-attributes (method-attributes method) nil class))
1175
1176
1177(defun write-method (method stream)
1178  "Write class file representation of `method' to `stream'."
1179  (write-u2 (method-access-flags method) stream)
1180  (write-u2 (method-name method) stream)
1181  ;;(sys::%format t "method-name: ~a~%" (method-name method))
1182  (write-u2 (method-descriptor method) stream)
1183  (write-attributes (method-attributes method) stream))
1184
1185(defstruct attribute
1186  "Parent attribute structure to be included into other attributes, mainly
1187to define common fields.
1188
1189Having common fields allows common driver code for
1190finalizing and serializing attributes."
1191  name
1192
1193  ;; not in the class file:
1194  finalizer  ;; function of 3 arguments: the attribute, parent and class-file
1195  writer     ;; function of 2 arguments: the attribute and the output stream
1196  )
1197
1198(defun finalize-attributes (attributes att class)
1199  "Prepare `attributes' (a list) of attribute `att' list for serialization."
1200  (dolist (attribute attributes)
1201    ;; assure header: make sure 'name' is in the pool
1202    (setf (attribute-name attribute)
1203          (pool-add-utf8 (class-file-constants class)
1204                         (attribute-name attribute)))
1205    ;; we're saving "root" attributes: attributes which have no parent
1206    (funcall (attribute-finalizer attribute) attribute att class)))
1207
1208(defun write-attributes (attributes stream)
1209  "Writes the `attributes' to `stream'."
1210  (write-u2 (length attributes) stream)
1211  (dolist (attribute attributes)
1212    (write-u2 (attribute-name attribute) stream)
1213    ;; set up a bulk catcher for (UNSIGNED-BYTE 8)
1214    ;; since we need to know the attribute length (excluding the header)
1215    (let ((local-stream (sys::%make-byte-array-output-stream)))
1216      (funcall (attribute-writer attribute) attribute local-stream)
1217      (let ((array (sys::%get-output-stream-array local-stream)))
1218        (write-u4 (length array) stream)
1219        (write-sequence array stream)))))
1220
1221
1222
1223(defstruct (code-attribute (:conc-name code-)
1224                           (:include attribute
1225                                     (name "Code")
1226                                     (finalizer #'finalize-code-attribute)
1227                                     (writer #'write-code-attribute))
1228                           (:constructor %make-code-attribute))
1229  "The attribute containing the actual JVM byte code;
1230an attribute of a method."
1231  max-stack
1232  max-locals
1233  code
1234  exception-handlers
1235  attributes
1236
1237  ;; fields not in the class file start here
1238
1239  ;; labels contains offsets into the code array after it's finalized
1240  labels ;; an alist
1241  optimize
1242  (current-local 0)) ;; used for handling nested WITH-CODE-TO-METHOD blocks
1243
1244
1245
1246(defun code-label-offset (code label)
1247  "Retrieves the `label' offset within a `code' attribute after the
1248attribute has been finalized."
1249  (cdr (assoc label (code-labels code))))
1250
1251(defun (setf code-label-offset) (offset code label)
1252  "Sets the `label' offset within a `code' attribute after the attribute
1253has been finalized."
1254  (setf (code-labels code)
1255        (acons label offset (code-labels code))))
1256
1257(defun finalize-code-attribute (code parent class)
1258  "Prepares the `code' attribute for serialization, within method `parent'."
1259  (let* ((handlers (code-exception-handlers code))
1260         (c (finalize-code
1261                     (code-code code)
1262                     (nconc (mapcar #'exception-start-pc handlers)
1263                            (mapcar #'exception-end-pc handlers)
1264                            (mapcar #'exception-handler-pc handlers))
1265                     (code-optimize code)
1266                     (class-file-constants class))))
1267    (invoke-callbacks :code-finalized class parent
1268                      (coerce c 'list) handlers)
1269    (unless (code-max-stack code)
1270      (setf (code-max-stack code)
1271            (analyze-stack c (mapcar #'exception-handler-pc handlers))))
1272    (unless (code-max-locals code)
1273      (setf (code-max-locals code)
1274            (analyze-locals code)))
1275    (multiple-value-bind
1276          (c labels)
1277        (code-bytes c)
1278      (unless (< 0 (length c) 65536)
1279        (signal 'sys:compiler-bytecode-length-error))
1280      (setf (code-code code) c
1281            (code-labels code) labels)))
1282
1283  (setf (code-exception-handlers code)
1284        (remove-if #'(lambda (h)
1285                       (eql (code-label-offset code (exception-start-pc h))
1286                            (code-label-offset code (exception-end-pc h))))
1287                   (code-exception-handlers code)))
1288
1289  (dolist (exception (code-exception-handlers code))
1290    (setf (exception-start-pc exception)
1291          (code-label-offset code (exception-start-pc exception))
1292          (exception-end-pc exception)
1293          (code-label-offset code (exception-end-pc exception))
1294          (exception-handler-pc exception)
1295          (code-label-offset code (exception-handler-pc exception))
1296          (exception-catch-type exception)
1297          (if (null (exception-catch-type exception))
1298              0  ;; generic 'catch all' class index number
1299              (pool-add-class (class-file-constants class)
1300                              (exception-catch-type exception)))))
1301
1302  (finalize-attributes (code-attributes code) code class))
1303
1304(defun write-code-attribute (code stream)
1305  "Writes the attribute `code' to `stream'."
1306  ;;(sys::%format t "max-stack: ~a~%" (code-max-stack code))
1307  (write-u2 (code-max-stack code) stream)
1308  ;;(sys::%format t "max-locals: ~a~%" (code-max-locals code))
1309  (write-u2 (code-max-locals code) stream)
1310  (let ((code-array (code-code code)))
1311    ;;(sys::%format t "length: ~a~%" (length code-array))
1312    (write-u4 (length code-array) stream)
1313    (dotimes (i (length code-array))
1314      (write-u1 (svref code-array i) stream)))
1315
1316  (write-u2 (length (code-exception-handlers code)) stream)
1317  (dolist (exception (reverse (code-exception-handlers code)))
1318    ;;(sys::%format t "start-pc: ~a~%" (exception-start-pc exception))
1319    (write-u2 (exception-start-pc exception) stream)
1320    ;;(sys::%format t "end-pc: ~a~%" (exception-end-pc exception))
1321    (write-u2 (exception-end-pc exception) stream)
1322    ;;(sys::%format t "handler-pc: ~a~%" (exception-handler-pc exception))
1323    (write-u2 (exception-handler-pc exception) stream)
1324    (write-u2 (exception-catch-type exception) stream))
1325
1326  (write-attributes (code-attributes code) stream))
1327
1328(defun make-code-attribute (arg-count &optional optimize)
1329  "Creates an empty 'Code' attribute for a method which takes
1330`arg-count` parameters, including the implicit `this` parameter."
1331  (%make-code-attribute :max-locals arg-count :optimize optimize))
1332
1333(defun code-add-attribute (code attribute)
1334  "Adds `attribute' to `code', returning `attribute'."
1335  (push attribute (code-attributes code))
1336  attribute)
1337
1338(defun code-attribute (code name)
1339  "Returns an attribute of `code' identified by `name'."
1340  (find name (code-attributes code)
1341        :test #'string= :key #'attribute-name))
1342
1343
1344(defun code-add-exception-handler (code start end handler type)
1345  "Adds an exception handler to `code' protecting the region from
1346labels `start' to `end' (inclusive) from exception `type' - where
1347a value of NIL indicates all types. Upon an exception of the given
1348type, control is transferred to label `handler'."
1349  (push (make-exception :start-pc start
1350                        :end-pc end
1351                        :handler-pc handler
1352                        :catch-type type)
1353        (code-exception-handlers code)))
1354
1355(defstruct exception
1356  "Exception handler information.
1357
1358After finalization, the fields contain offsets instead of labels."
1359  start-pc    ;; label target
1360  end-pc      ;; label target
1361  handler-pc  ;; label target
1362  catch-type  ;; a string for a specific type, or NIL for all
1363  )
1364
1365
1366(defstruct (constant-value-attribute (:conc-name constant-value-)
1367                                     (:include attribute
1368                                               (name "ConstantValue")
1369                                               ;; finalizer
1370                                               ;; writer
1371                                               ))
1372  "An attribute of a field of primitive type.
1373
1374"
1375  ;;; ### TODO
1376  )
1377
1378
1379(defstruct (checked-exceptions-attribute
1380             (:conc-name checked-)
1381             (:include attribute
1382                       (name "Exceptions")
1383                       (finalizer #'finalize-checked-exceptions)
1384                       (writer #'write-checked-exceptions)))
1385  "An attribute of `code-attribute', "
1386  table ;; a list of checked classes corresponding to Java's 'throws'
1387)
1388
1389(defun finalize-checked-exceptions (checked-exceptions code class)
1390  (declare (ignorable code class))
1391
1392  "Prepare `checked-exceptions' for serialization."
1393  (setf (checked-table checked-exceptions)
1394        (mapcar #'(lambda (exception)
1395                    (pool-add-class (class-file-constants class)
1396                                    exception))
1397                (checked-table checked-exceptions))))
1398
1399(defun write-checked-exceptions (checked-exceptions stream)
1400  "Write `checked-exceptions' to `stream' in class file representation."
1401  (write-u2 (length (checked-table checked-exceptions)) stream)
1402  (dolist (exception (reverse (checked-table checked-exceptions)))
1403    (write-u2 exception stream)))
1404
1405;; Can't be used yet: serialization missing
1406(defstruct (deprecated-attribute (:include attribute
1407                                           (name "Deprecated")
1408                                           (finalizer (constantly nil))
1409                                           (writer (constantly nil))))
1410  ;; finalizer and writer need to do nothing: Deprecated attributes are empty
1411  "An attribute of a class file, field or method, indicating the element
1412to which it has been attached has been superseded.")
1413
1414(defvar *current-code-attribute* nil)
1415(defvar *method*)
1416
1417(defun save-code-specials (code)
1418  (setf (code-code code) *code*
1419        (code-max-locals code) *registers-allocated*
1420        (code-current-local code) *register*))
1421
1422(defun restore-code-specials (code)
1423  (setf *code* (code-code code)
1424        *registers-allocated* (code-max-locals code)
1425        *register* (code-current-local code)))
1426
1427(defmacro with-code-to-method ((class-file method)
1428                               &body body)
1429  (let ((m (gensym))
1430        (c (gensym)))
1431    `(progn
1432       (when *current-code-attribute*
1433         (save-code-specials *current-code-attribute*))
1434       (unwind-protect
1435           (let* ((,m ,method)
1436                  (*method* ,m)
1437                  (,c (method-ensure-code ,method))
1438                  (*pool* (class-file-constants ,class-file))
1439                  (*code* (code-code ,c))
1440                  (*registers-allocated* (code-max-locals ,c))
1441                  (*register* (code-current-local ,c))
1442                  (*current-code-attribute* ,c))
1443             (unwind-protect
1444                 ,@body
1445               ;; in case of a RETURN-FROM or GO, save the current state
1446               (setf (code-code ,c) *code*
1447                     (code-current-local ,c) *register*
1448                     (code-max-locals ,c) *registers-allocated*)))
1449         ;; using the same line of reasoning, restore the outer-scope state
1450         (when *current-code-attribute*
1451           (restore-code-specials *current-code-attribute*))))))
1452
1453
1454(defstruct (source-file-attribute (:conc-name source-)
1455                                  (:include attribute
1456                                            (name "SourceFile")
1457                                            (finalizer #'finalize-source-file)
1458                                            (writer #'write-source-file)))
1459  "An attribute of the class file indicating which source file
1460it was compiled from."
1461  filename)
1462
1463(defun finalize-source-file (source-file code class)
1464  (declare (ignorable code class))
1465  (setf (source-filename source-file)
1466        (pool-add-utf8 (class-file-constants class)
1467                       (source-filename source-file))))
1468
1469(defun write-source-file (source-file stream)
1470  (write-u2 (source-filename source-file) stream))
1471
1472
1473(defstruct (synthetic-attribute (:include attribute
1474                                          (name "Synthetic")
1475                                          (finalizer (constantly nil))
1476                                          (writer (constantly nil))))
1477  ;; finalizer and writer need to do nothing: Synthetic attributes are empty
1478  "An attribute of a class file, field or method to mark that it wasn't
1479included in the sources - but was generated artificially.")
1480
1481
1482(defstruct (line-numbers-attribute
1483             (:conc-name line-numbers-)
1484             (:include attribute
1485                       (name "LineNumberTable")
1486                       (finalizer #'finalize-line-numbers)
1487                       (writer #'write-line-numbers)))
1488  "An attribute of `code-attribute', containing a mapping of offsets
1489within the code section to the line numbers in the source file."
1490  table ;; a list of line-number structures, in reverse order
1491  )
1492
1493(defstruct line-number
1494  start-pc  ;; a label, before finalization, or 0 for "start of function"
1495  line)
1496
1497(defun finalize-line-numbers (line-numbers code class)
1498  (declare (ignorable code class))
1499  (dolist (line-number (line-numbers-table line-numbers))
1500    (unless (zerop (line-number-start-pc line-number))
1501      (setf (line-number-start-pc line-number)
1502            (code-label-offset code (line-number-start-pc line-number))))))
1503
1504(defun write-line-numbers (line-numbers stream)
1505  (write-u2 (length (line-numbers-table line-numbers)) stream)
1506  (dolist (line-number (reverse (line-numbers-table line-numbers)))
1507    (write-u2 (line-number-start-pc line-number) stream)
1508    (write-u2 (line-number-line line-number) stream)))
1509
1510(defun line-numbers-add-line (line-numbers start-pc line)
1511  (push (make-line-number :start-pc start-pc :line line)
1512        (line-numbers-table line-numbers)))
1513
1514(defstruct (local-variables-attribute
1515             (:conc-name local-var-)
1516             (:include attribute
1517                       (name "LocalVariableTable")
1518                       (finalizer #'finalize-local-variables)
1519                       (writer #'write-local-variables)))
1520  "An attribute of the `code-attribute', containing a table of local variable
1521names, their type and their scope of validity."
1522  table ;; a list of local-variable structures, in reverse order
1523  )
1524
1525(defstruct (local-variable (:conc-name local-))
1526  start-pc  ;; a label, before finalization
1527  length    ;; a label (at the ending position) before finalization
1528  name
1529  descriptor
1530  index ;; The index of the variable inside the block of locals
1531  )
1532
1533(defun finalize-local-variables (local-variables code class)
1534  (dolist (local-variable (local-var-table local-variables))
1535    (setf (local-start-pc local-variable)
1536          (code-label-offset code (local-start-pc local-variable))
1537          (local-length local-variable)
1538          ;; calculate 'length' from the distance between 2 labels
1539          (- (code-label-offset code (local-length local-variable))
1540             (local-start-pc local-variable))
1541          (local-name local-variable)
1542          (pool-add-utf8 (class-file-constants class)
1543                         (local-name local-variable))
1544          (local-descriptor local-variable)
1545          (pool-add-utf8 (class-file-constants class)
1546                         (local-descriptor local-variable)))))
1547
1548(defun write-local-variables (local-variables stream)
1549  (write-u2 (length (local-var-table local-variables)) stream)
1550  (dolist (local-variable (reverse (local-var-table local-variables)))
1551    (write-u2 (local-start-pc local-variable) stream)
1552    (write-u2 (local-length local-variable) stream)
1553    (write-u2 (local-name local-variable) stream)
1554    (write-u2 (local-descriptor local-variable) stream)
1555    (write-u2 (local-index local-variable) stream)))
1556
1557;;Annotations
1558
1559(defstruct (annotations-attribute
1560             (:conc-name annotations-)
1561             (:include attribute
1562                       ;;Name is to be provided by subtypes
1563                       (finalizer #'finalize-annotations)
1564                       (writer #'write-annotations)))
1565  "An attribute of a class, method or field, containing a list of annotations.
1566This structure serves as the abstract supertype of concrete annotations types."
1567  list ;; a list of annotation structures, in reverse order
1568  )
1569
1570(defstruct annotation
1571  "Each value of the annotations table represents a single runtime-visible annotation on a program element.
1572   The annotation structure has the following format:
1573     annotation {
1574       u2 type_index;
1575       u2 num_element_value_pairs;
1576       {
1577         u2 element_name_index;
1578         element_value value;
1579       } element_value_pairs[num_element_value_pairs]
1580     }"
1581  type
1582  elements)
1583
1584(defstruct annotation-element (name "value") tag finalizer writer)
1585
1586(defstruct (primitive-or-string-annotation-element
1587             (:include annotation-element
1588                       (finalizer (lambda (self class)
1589                                    (let ((value (primitive-or-string-annotation-element-value self)))
1590                                      (etypecase value
1591                                        (boolean
1592                                         (setf (annotation-element-tag self)
1593                                               (char-code #\Z)
1594                                               (primitive-or-string-annotation-element-value self)
1595                                               (pool-add-int (class-file-constants class) (if value 1 0))))
1596                                        (character
1597                                         (setf (annotation-element-tag self)
1598                                               (char-code #\C)
1599                                               (primitive-or-string-annotation-element-value self)
1600                                               (pool-add-int (class-file-constants class) (char-code value))))
1601                                        (fixnum
1602                                         (setf (annotation-element-tag self)
1603                                               (char-code #\I)
1604                                               (primitive-or-string-annotation-element-value self)
1605                                               (pool-add-int (class-file-constants class) value)))
1606                                        (integer
1607                                         (setf (annotation-element-tag self)
1608                                               (char-code #\J)
1609                                               (primitive-or-string-annotation-element-value self)
1610                                               (pool-add-long (class-file-constants class) value)))
1611                                        (double-float
1612                                         (setf (annotation-element-tag self)
1613                                               (char-code #\D)
1614                                               (primitive-or-string-annotation-element-value self)
1615                                               (pool-add-double (class-file-constants class) value)))
1616                                        (single-float
1617                                         (setf (annotation-element-tag self)
1618                                               (char-code #\F)
1619                                               (primitive-or-string-annotation-element-value self)
1620                                               (pool-add-float (class-file-constants class) value)))
1621                                        (string
1622                                         (setf (annotation-element-tag self)
1623                                               (char-code #\s)
1624                                               (primitive-or-string-annotation-element-value self)
1625                                               (pool-add-utf8 (class-file-constants class) value)))))))
1626                       (writer (lambda (self stream)
1627                                 (write-u1 (annotation-element-tag self) stream)
1628                                 (write-u2 (primitive-or-string-annotation-element-value self) stream)))))
1629  value)
1630
1631(defstruct (enum-value-annotation-element
1632             (:include annotation-element
1633                       (tag (char-code #\e))
1634                       (finalizer (lambda (self class)
1635                                    (setf (enum-value-annotation-element-type self)
1636                                          (pool-add-utf8 (class-file-constants class)
1637                                                         (enum-value-annotation-element-type self)) ;;Binary name as string
1638                                          (enum-value-annotation-element-value self)
1639                                          (pool-add-utf8 (class-file-constants class)
1640                                                         (enum-value-annotation-element-value self)))))
1641                       (writer (lambda (self stream)
1642                                 (write-u1 (annotation-element-tag self) stream)
1643                                 (write-u2 (enum-value-annotation-element-type self) stream)
1644                                 (write-u2 (enum-value-annotation-element-value self) stream)))))
1645  type
1646  value)
1647
1648(defstruct (annotation-value-annotation-element
1649             (:include annotation-element
1650                       (tag (char-code #\@))
1651                       (finalizer (lambda (self class)
1652                                    (finalize-annotation (annotation-value-annotation-element-value self) class)))
1653                       (writer (lambda (self stream)
1654                                 (write-u1 (annotation-element-tag self) stream)
1655                                 (write-annotation (annotation-value-annotation-element-value self) stream)))))
1656  value)
1657
1658(defstruct (array-annotation-element
1659             (:include annotation-element
1660                       (tag (char-code #\[))
1661                       (finalizer (lambda (self class)
1662                                    (dolist (elem (array-annotation-element-values self))
1663                                      (finalize-annotation-element elem class))))
1664                       (writer (lambda (self stream)
1665                                 (write-u1 (annotation-element-tag self) stream)
1666                                 (write-u2 (length (array-annotation-element-values self)) stream)
1667                                 (dolist (elem (array-annotation-element-values self))
1668                                   (write-annotation-element elem stream))))))
1669  values) ;;In proper order
1670
1671(defstruct (runtime-visible-annotations-attribute
1672             (:include annotations-attribute
1673                       (name "RuntimeVisibleAnnotations")))
1674  "4.8.15 The RuntimeVisibleAnnotations attribute
1675The RuntimeVisibleAnnotations attribute is a variable length attribute in the
1676attributes table of the ClassFile, field_info, and method_info structures. The
1677RuntimeVisibleAnnotations attribute records runtime-visible Java program-
1678ming language annotations on the corresponding class, method, or field. Each
1679ClassFile, field_info, and method_info structure may contain at most one
1680RuntimeVisibleAnnotations attribute, which records all the runtime-visible
1681Java programming language annotations on the corresponding program element.
1682The JVM must make these annotations available so they can be returned by the
1683appropriate reflective APIs.")
1684
1685(defun finalize-annotations (annotations code class)
1686  (declare (ignore code))
1687  (dolist (ann (annotations-list annotations))
1688    (finalize-annotation ann class)))
1689
1690(defun finalize-annotation (ann class)
1691  (setf (annotation-type ann)
1692        (pool-add-class (class-file-constants class) (annotation-type ann)))
1693  (dolist (elem (annotation-elements ann))
1694    (finalize-annotation-element elem class)))
1695
1696(defun finalize-annotation-element (elem class)
1697  (when (annotation-element-name elem)
1698    (setf (annotation-element-name elem)
1699          (pool-add-utf8 (class-file-constants class)
1700                         (annotation-element-name elem))))
1701  (funcall (annotation-element-finalizer elem)
1702           elem class))
1703
1704(defun write-annotations (annotations stream)
1705  (write-u2 (length (annotations-list annotations)) stream)
1706  (dolist (annotation (reverse (annotations-list annotations)))
1707    (write-annotation annotation stream)))
1708
1709(defun write-annotation (annotation stream)
1710  (write-u2 (annotation-type annotation) stream)
1711  (write-u2 (length (annotation-elements annotation)) stream)
1712  (dolist (elem (reverse (annotation-elements annotation)))
1713    (write-annotation-element elem stream)))
1714
1715(defun write-annotation-element (elem stream)
1716  (when (annotation-element-name elem)
1717    (write-u2 (annotation-element-name elem) stream))
1718  (funcall (annotation-element-writer elem)
1719           elem stream))
1720
1721#|
1722
1723;; this is the minimal sequence we need to support:
1724
1725;;  create a class file structure
1726;;  add methods
1727;;  add code to the methods, switching from one method to the other
1728;;  finalize the methods, one by one
1729;;  write the class file
1730
1731to support the sequence above, we probably need to
1732be able to
1733
1734- find methods by signature
1735- find the method's code attribute
1736- add code to the code attribute
1737- finalize the code attribute contents (blocking it for further addition)
1738-
1739
1740
1741|#
1742
1743(provide '#:jvm-class-file)
Note: See TracBrowser for help on using the repository browser.