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

Last change on this file since 15569 was 15569, checked in by Mark Evenson, 19 months ago

Untabify en masse

Results of running style.org source blocks on tree
  • 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 15569 2022-03-19 12:50:18Z 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      (assert (< 0 (length c) 65536))
1279      (setf (code-code code) c
1280            (code-labels code) labels)))
1281
1282  (setf (code-exception-handlers code)
1283        (remove-if #'(lambda (h)
1284                       (eql (code-label-offset code (exception-start-pc h))
1285                            (code-label-offset code (exception-end-pc h))))
1286                   (code-exception-handlers code)))
1287
1288  (dolist (exception (code-exception-handlers code))
1289    (setf (exception-start-pc exception)
1290          (code-label-offset code (exception-start-pc exception))
1291          (exception-end-pc exception)
1292          (code-label-offset code (exception-end-pc exception))
1293          (exception-handler-pc exception)
1294          (code-label-offset code (exception-handler-pc exception))
1295          (exception-catch-type exception)
1296          (if (null (exception-catch-type exception))
1297              0  ;; generic 'catch all' class index number
1298              (pool-add-class (class-file-constants class)
1299                              (exception-catch-type exception)))))
1300
1301  (finalize-attributes (code-attributes code) code class))
1302
1303(defun write-code-attribute (code stream)
1304  "Writes the attribute `code' to `stream'."
1305  ;;(sys::%format t "max-stack: ~a~%" (code-max-stack code))
1306  (write-u2 (code-max-stack code) stream)
1307  ;;(sys::%format t "max-locals: ~a~%" (code-max-locals code))
1308  (write-u2 (code-max-locals code) stream)
1309  (let ((code-array (code-code code)))
1310    ;;(sys::%format t "length: ~a~%" (length code-array))
1311    (write-u4 (length code-array) stream)
1312    (dotimes (i (length code-array))
1313      (write-u1 (svref code-array i) stream)))
1314
1315  (write-u2 (length (code-exception-handlers code)) stream)
1316  (dolist (exception (reverse (code-exception-handlers code)))
1317    ;;(sys::%format t "start-pc: ~a~%" (exception-start-pc exception))
1318    (write-u2 (exception-start-pc exception) stream)
1319    ;;(sys::%format t "end-pc: ~a~%" (exception-end-pc exception))
1320    (write-u2 (exception-end-pc exception) stream)
1321    ;;(sys::%format t "handler-pc: ~a~%" (exception-handler-pc exception))
1322    (write-u2 (exception-handler-pc exception) stream)
1323    (write-u2 (exception-catch-type exception) stream))
1324
1325  (write-attributes (code-attributes code) stream))
1326
1327(defun make-code-attribute (arg-count &optional optimize)
1328  "Creates an empty 'Code' attribute for a method which takes
1329`arg-count` parameters, including the implicit `this` parameter."
1330  (%make-code-attribute :max-locals arg-count :optimize optimize))
1331
1332(defun code-add-attribute (code attribute)
1333  "Adds `attribute' to `code', returning `attribute'."
1334  (push attribute (code-attributes code))
1335  attribute)
1336
1337(defun code-attribute (code name)
1338  "Returns an attribute of `code' identified by `name'."
1339  (find name (code-attributes code)
1340        :test #'string= :key #'attribute-name))
1341
1342
1343(defun code-add-exception-handler (code start end handler type)
1344  "Adds an exception handler to `code' protecting the region from
1345labels `start' to `end' (inclusive) from exception `type' - where
1346a value of NIL indicates all types. Upon an exception of the given
1347type, control is transferred to label `handler'."
1348  (push (make-exception :start-pc start
1349                        :end-pc end
1350                        :handler-pc handler
1351                        :catch-type type)
1352        (code-exception-handlers code)))
1353
1354(defstruct exception
1355  "Exception handler information.
1356
1357After finalization, the fields contain offsets instead of labels."
1358  start-pc    ;; label target
1359  end-pc      ;; label target
1360  handler-pc  ;; label target
1361  catch-type  ;; a string for a specific type, or NIL for all
1362  )
1363
1364
1365(defstruct (constant-value-attribute (:conc-name constant-value-)
1366                                     (:include attribute
1367                                               (name "ConstantValue")
1368                                               ;; finalizer
1369                                               ;; writer
1370                                               ))
1371  "An attribute of a field of primitive type.
1372
1373"
1374  ;;; ### TODO
1375  )
1376
1377
1378(defstruct (checked-exceptions-attribute
1379             (:conc-name checked-)
1380             (:include attribute
1381                       (name "Exceptions")
1382                       (finalizer #'finalize-checked-exceptions)
1383                       (writer #'write-checked-exceptions)))
1384  "An attribute of `code-attribute', "
1385  table ;; a list of checked classes corresponding to Java's 'throws'
1386)
1387
1388(defun finalize-checked-exceptions (checked-exceptions code class)
1389  (declare (ignorable code class))
1390
1391  "Prepare `checked-exceptions' for serialization."
1392  (setf (checked-table checked-exceptions)
1393        (mapcar #'(lambda (exception)
1394                    (pool-add-class (class-file-constants class)
1395                                    exception))
1396                (checked-table checked-exceptions))))
1397
1398(defun write-checked-exceptions (checked-exceptions stream)
1399  "Write `checked-exceptions' to `stream' in class file representation."
1400  (write-u2 (length (checked-table checked-exceptions)) stream)
1401  (dolist (exception (reverse (checked-table checked-exceptions)))
1402    (write-u2 exception stream)))
1403
1404;; Can't be used yet: serialization missing
1405(defstruct (deprecated-attribute (:include attribute
1406                                           (name "Deprecated")
1407                                           (finalizer (constantly nil))
1408                                           (writer (constantly nil))))
1409  ;; finalizer and writer need to do nothing: Deprecated attributes are empty
1410  "An attribute of a class file, field or method, indicating the element
1411to which it has been attached has been superseded.")
1412
1413(defvar *current-code-attribute* nil)
1414(defvar *method*)
1415
1416(defun save-code-specials (code)
1417  (setf (code-code code) *code*
1418        (code-max-locals code) *registers-allocated*
1419        (code-current-local code) *register*))
1420
1421(defun restore-code-specials (code)
1422  (setf *code* (code-code code)
1423        *registers-allocated* (code-max-locals code)
1424        *register* (code-current-local code)))
1425
1426(defmacro with-code-to-method ((class-file method)
1427                               &body body)
1428  (let ((m (gensym))
1429        (c (gensym)))
1430    `(progn
1431       (when *current-code-attribute*
1432         (save-code-specials *current-code-attribute*))
1433       (unwind-protect
1434           (let* ((,m ,method)
1435                  (*method* ,m)
1436                  (,c (method-ensure-code ,method))
1437                  (*pool* (class-file-constants ,class-file))
1438                  (*code* (code-code ,c))
1439                  (*registers-allocated* (code-max-locals ,c))
1440                  (*register* (code-current-local ,c))
1441                  (*current-code-attribute* ,c))
1442             (unwind-protect
1443                 ,@body
1444               ;; in case of a RETURN-FROM or GO, save the current state
1445               (setf (code-code ,c) *code*
1446                     (code-current-local ,c) *register*
1447                     (code-max-locals ,c) *registers-allocated*)))
1448         ;; using the same line of reasoning, restore the outer-scope state
1449         (when *current-code-attribute*
1450           (restore-code-specials *current-code-attribute*))))))
1451
1452
1453(defstruct (source-file-attribute (:conc-name source-)
1454                                  (:include attribute
1455                                            (name "SourceFile")
1456                                            (finalizer #'finalize-source-file)
1457                                            (writer #'write-source-file)))
1458  "An attribute of the class file indicating which source file
1459it was compiled from."
1460  filename)
1461
1462(defun finalize-source-file (source-file code class)
1463  (declare (ignorable code class))
1464  (setf (source-filename source-file)
1465        (pool-add-utf8 (class-file-constants class)
1466                       (source-filename source-file))))
1467
1468(defun write-source-file (source-file stream)
1469  (write-u2 (source-filename source-file) stream))
1470
1471
1472(defstruct (synthetic-attribute (:include attribute
1473                                          (name "Synthetic")
1474                                          (finalizer (constantly nil))
1475                                          (writer (constantly nil))))
1476  ;; finalizer and writer need to do nothing: Synthetic attributes are empty
1477  "An attribute of a class file, field or method to mark that it wasn't
1478included in the sources - but was generated artificially.")
1479
1480
1481(defstruct (line-numbers-attribute
1482             (:conc-name line-numbers-)
1483             (:include attribute
1484                       (name "LineNumberTable")
1485                       (finalizer #'finalize-line-numbers)
1486                       (writer #'write-line-numbers)))
1487  "An attribute of `code-attribute', containing a mapping of offsets
1488within the code section to the line numbers in the source file."
1489  table ;; a list of line-number structures, in reverse order
1490  )
1491
1492(defstruct line-number
1493  start-pc  ;; a label, before finalization, or 0 for "start of function"
1494  line)
1495
1496(defun finalize-line-numbers (line-numbers code class)
1497  (declare (ignorable code class))
1498  (dolist (line-number (line-numbers-table line-numbers))
1499    (unless (zerop (line-number-start-pc line-number))
1500      (setf (line-number-start-pc line-number)
1501            (code-label-offset code (line-number-start-pc line-number))))))
1502
1503(defun write-line-numbers (line-numbers stream)
1504  (write-u2 (length (line-numbers-table line-numbers)) stream)
1505  (dolist (line-number (reverse (line-numbers-table line-numbers)))
1506    (write-u2 (line-number-start-pc line-number) stream)
1507    (write-u2 (line-number-line line-number) stream)))
1508
1509(defun line-numbers-add-line (line-numbers start-pc line)
1510  (push (make-line-number :start-pc start-pc :line line)
1511        (line-numbers-table line-numbers)))
1512
1513(defstruct (local-variables-attribute
1514             (:conc-name local-var-)
1515             (:include attribute
1516                       (name "LocalVariableTable")
1517                       (finalizer #'finalize-local-variables)
1518                       (writer #'write-local-variables)))
1519  "An attribute of the `code-attribute', containing a table of local variable
1520names, their type and their scope of validity."
1521  table ;; a list of local-variable structures, in reverse order
1522  )
1523
1524(defstruct (local-variable (:conc-name local-))
1525  start-pc  ;; a label, before finalization
1526  length    ;; a label (at the ending position) before finalization
1527  name
1528  descriptor
1529  index ;; The index of the variable inside the block of locals
1530  )
1531
1532(defun finalize-local-variables (local-variables code class)
1533  (dolist (local-variable (local-var-table local-variables))
1534    (setf (local-start-pc local-variable)
1535          (code-label-offset code (local-start-pc local-variable))
1536          (local-length local-variable)
1537          ;; calculate 'length' from the distance between 2 labels
1538          (- (code-label-offset code (local-length local-variable))
1539             (local-start-pc local-variable))
1540          (local-name local-variable)
1541          (pool-add-utf8 (class-file-constants class)
1542                         (local-name local-variable))
1543          (local-descriptor local-variable)
1544          (pool-add-utf8 (class-file-constants class)
1545                         (local-descriptor local-variable)))))
1546
1547(defun write-local-variables (local-variables stream)
1548  (write-u2 (length (local-var-table local-variables)) stream)
1549  (dolist (local-variable (reverse (local-var-table local-variables)))
1550    (write-u2 (local-start-pc local-variable) stream)
1551    (write-u2 (local-length local-variable) stream)
1552    (write-u2 (local-name local-variable) stream)
1553    (write-u2 (local-descriptor local-variable) stream)
1554    (write-u2 (local-index local-variable) stream)))
1555
1556;;Annotations
1557
1558(defstruct (annotations-attribute
1559             (:conc-name annotations-)
1560             (:include attribute
1561                       ;;Name is to be provided by subtypes
1562                       (finalizer #'finalize-annotations)
1563                       (writer #'write-annotations)))
1564  "An attribute of a class, method or field, containing a list of annotations.
1565This structure serves as the abstract supertype of concrete annotations types."
1566  list ;; a list of annotation structures, in reverse order
1567  )
1568
1569(defstruct annotation
1570  "Each value of the annotations table represents a single runtime-visible annotation on a program element.
1571   The annotation structure has the following format:
1572     annotation {
1573       u2 type_index;
1574       u2 num_element_value_pairs;
1575       {
1576         u2 element_name_index;
1577         element_value value;
1578       } element_value_pairs[num_element_value_pairs]
1579     }"
1580  type
1581  elements)
1582
1583(defstruct annotation-element (name "value") tag finalizer writer)
1584
1585(defstruct (primitive-or-string-annotation-element
1586             (:include annotation-element
1587                       (finalizer (lambda (self class)
1588                                    (let ((value (primitive-or-string-annotation-element-value self)))
1589                                      (etypecase value
1590                                        (boolean
1591                                         (setf (annotation-element-tag self)
1592                                               (char-code #\Z)
1593                                               (primitive-or-string-annotation-element-value self)
1594                                               (pool-add-int (class-file-constants class) (if value 1 0))))
1595                                        (character
1596                                         (setf (annotation-element-tag self)
1597                                               (char-code #\C)
1598                                               (primitive-or-string-annotation-element-value self)
1599                                               (pool-add-int (class-file-constants class) (char-code value))))
1600                                        (fixnum
1601                                         (setf (annotation-element-tag self)
1602                                               (char-code #\I)
1603                                               (primitive-or-string-annotation-element-value self)
1604                                               (pool-add-int (class-file-constants class) value)))
1605                                        (integer
1606                                         (setf (annotation-element-tag self)
1607                                               (char-code #\J)
1608                                               (primitive-or-string-annotation-element-value self)
1609                                               (pool-add-long (class-file-constants class) value)))
1610                                        (double-float
1611                                         (setf (annotation-element-tag self)
1612                                               (char-code #\D)
1613                                               (primitive-or-string-annotation-element-value self)
1614                                               (pool-add-double (class-file-constants class) value)))
1615                                        (single-float
1616                                         (setf (annotation-element-tag self)
1617                                               (char-code #\F)
1618                                               (primitive-or-string-annotation-element-value self)
1619                                               (pool-add-float (class-file-constants class) value)))
1620                                        (string
1621                                         (setf (annotation-element-tag self)
1622                                               (char-code #\s)
1623                                               (primitive-or-string-annotation-element-value self)
1624                                               (pool-add-utf8 (class-file-constants class) value)))))))
1625                       (writer (lambda (self stream)
1626                                 (write-u1 (annotation-element-tag self) stream)
1627                                 (write-u2 (primitive-or-string-annotation-element-value self) stream)))))
1628  value)
1629
1630(defstruct (enum-value-annotation-element
1631             (:include annotation-element
1632                       (tag (char-code #\e))
1633                       (finalizer (lambda (self class)
1634                                    (setf (enum-value-annotation-element-type self)
1635                                          (pool-add-utf8 (class-file-constants class)
1636                                                         (enum-value-annotation-element-type self)) ;;Binary name as string
1637                                          (enum-value-annotation-element-value self)
1638                                          (pool-add-utf8 (class-file-constants class)
1639                                                         (enum-value-annotation-element-value self)))))
1640                       (writer (lambda (self stream)
1641                                 (write-u1 (annotation-element-tag self) stream)
1642                                 (write-u2 (enum-value-annotation-element-type self) stream)
1643                                 (write-u2 (enum-value-annotation-element-value self) stream)))))
1644  type
1645  value)
1646
1647(defstruct (annotation-value-annotation-element
1648             (:include annotation-element
1649                       (tag (char-code #\@))
1650                       (finalizer (lambda (self class)
1651                                    (finalize-annotation (annotation-value-annotation-element-value self) class)))
1652                       (writer (lambda (self stream)
1653                                 (write-u1 (annotation-element-tag self) stream)
1654                                 (write-annotation (annotation-value-annotation-element-value self) stream)))))
1655  value)
1656
1657(defstruct (array-annotation-element
1658             (:include annotation-element
1659                       (tag (char-code #\[))
1660                       (finalizer (lambda (self class)
1661                                    (dolist (elem (array-annotation-element-values self))
1662                                      (finalize-annotation-element elem class))))
1663                       (writer (lambda (self stream)
1664                                 (write-u1 (annotation-element-tag self) stream)
1665                                 (write-u2 (length (array-annotation-element-values self)) stream)
1666                                 (dolist (elem (array-annotation-element-values self))
1667                                   (write-annotation-element elem stream))))))
1668  values) ;;In proper order
1669
1670(defstruct (runtime-visible-annotations-attribute
1671             (:include annotations-attribute
1672                       (name "RuntimeVisibleAnnotations")))
1673  "4.8.15 The RuntimeVisibleAnnotations attribute
1674The RuntimeVisibleAnnotations attribute is a variable length attribute in the
1675attributes table of the ClassFile, field_info, and method_info structures. The
1676RuntimeVisibleAnnotations attribute records runtime-visible Java program-
1677ming language annotations on the corresponding class, method, or field. Each
1678ClassFile, field_info, and method_info structure may contain at most one
1679RuntimeVisibleAnnotations attribute, which records all the runtime-visible
1680Java programming language annotations on the corresponding program element.
1681The JVM must make these annotations available so they can be returned by the
1682appropriate reflective APIs.")
1683
1684(defun finalize-annotations (annotations code class)
1685  (declare (ignore code))
1686  (dolist (ann (annotations-list annotations))
1687    (finalize-annotation ann class)))
1688
1689(defun finalize-annotation (ann class)
1690  (setf (annotation-type ann)
1691        (pool-add-class (class-file-constants class) (annotation-type ann)))
1692  (dolist (elem (annotation-elements ann))
1693    (finalize-annotation-element elem class)))
1694
1695(defun finalize-annotation-element (elem class)
1696  (when (annotation-element-name elem)
1697    (setf (annotation-element-name elem)
1698          (pool-add-utf8 (class-file-constants class)
1699                         (annotation-element-name elem))))
1700  (funcall (annotation-element-finalizer elem)
1701           elem class))
1702
1703(defun write-annotations (annotations stream)
1704  (write-u2 (length (annotations-list annotations)) stream)
1705  (dolist (annotation (reverse (annotations-list annotations)))
1706    (write-annotation annotation stream)))
1707
1708(defun write-annotation (annotation stream)
1709  (write-u2 (annotation-type annotation) stream)
1710  (write-u2 (length (annotation-elements annotation)) stream)
1711  (dolist (elem (reverse (annotation-elements annotation)))
1712    (write-annotation-element elem stream)))
1713
1714(defun write-annotation-element (elem stream)
1715  (when (annotation-element-name elem)
1716    (write-u2 (annotation-element-name elem) stream))
1717  (funcall (annotation-element-writer elem)
1718           elem stream))
1719
1720#|
1721
1722;; this is the minimal sequence we need to support:
1723
1724;;  create a class file structure
1725;;  add methods
1726;;  add code to the methods, switching from one method to the other
1727;;  finalize the methods, one by one
1728;;  write the class file
1729
1730to support the sequence above, we probably need to
1731be able to
1732
1733- find methods by signature
1734- find the method's code attribute
1735- add code to the code attribute
1736- finalize the code attribute contents (blocking it for further addition)
1737-
1738
1739
1740|#
1741
1742(provide '#:jvm-class-file)
Note: See TracBrowser for help on using the repository browser.