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

Last change on this file was 15605, checked in by Mark Evenson, 3 years ago

Added the possibility to specify array types in jnew-runtime-class

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