Changeset 12785
- Timestamp:
- 07/04/10 21:31:17 (13 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
r12783 r12785 59 59 60 60 (defun map-primitive-type (type) 61 "Maps a symbolic primitive type name to its Java string representation." 61 62 (case type 62 63 (:int "I") … … 87 88 88 89 (defun make-class-name (name) 90 "Creates a `class-name' structure for the class or interface `name'. 91 92 `name' should be specified using Java representation, which is converted 93 to 'internal' (JVM) representation by this function." 89 94 (setf name (substitute #\/ #\. name)) 90 95 (%make-class-name :name-internal name … … 93 98 94 99 (defmacro define-class-name (symbol java-dotted-name &optional documentation) 100 "Convenience macro to define constants for `class-name' structures, 101 initialized from the `java-dotted-name'." 95 102 `(defconstant ,symbol (make-class-name ,java-dotted-name) 96 103 ,documentation)) … … 154 161 155 162 (defun internal-field-type (field-type) 163 "Returns a string containing the JVM-internal representation 164 of `field-type', which should either be a symbol identifying a primitive 165 type, or a `class-name' structure identifying a class or interface." 156 166 (if (symbolp field-type) 157 167 (map-primitive-type field-type) … … 159 169 160 170 (defun internal-field-ref (field-type) 171 "Returns a string containing the JVM-internal representation of a reference 172 to `field-type', which should either be a symbol identifying a primitive 173 type, or a `class-name' structure identifying a class or interface." 161 174 (if (symbolp field-type) 162 175 (map-primitive-type field-type) … … 164 177 165 178 (defun descriptor (return-type &rest argument-types) 179 "Returns a string describing the `return-type' and `argument-types' 180 in JVM-internal representation." 166 181 (format nil "(~{~A~})~A" (mapcar #'internal-field-ref argument-types) 167 182 (internal-field-type return-type))) … … 178 193 (entries (make-hash-table :test #'equal :size 2048 :rehash-size 2.0))) 179 194 195 180 196 (defstruct constant 197 "Structure to be included in all constant sub-types." 181 198 tag 182 199 index) … … 210 227 make-constant-interface-method-ref)) 211 228 (defun make-constant-field-ref (index class-index name/type-index) 229 "Creates a `constant-member-ref' instance containing a field reference." 212 230 (%make-constant-member-ref 9 index class-index name/type-index)) 213 231 214 232 (defun make-constant-method-ref (index class-index name/type-index) 233 "Creates a `constant-member-ref' instance containing a method reference." 215 234 (%make-constant-member-ref 10 index class-index name/type-index)) 216 235 217 236 (defun make-constant-interface-method-ref (index class-index name/type-index) 237 "Creates a `constant-member-ref' instance containing an 238 interface-method reference." 218 239 (%make-constant-member-ref 11 index class-index name/type-index)) 219 240 … … 222 243 (:include constant 223 244 (tag 8))) 224 value-index) ;;; #### is this the value or the value index???245 value-index) 225 246 226 247 (defstruct (constant-float/int (:constructor … … 231 252 (declaim (inline make-constant-float make-constant-int)) 232 253 (defun make-constant-float (index value) 254 "Creates a `constant-float/int' structure instance containing a float." 233 255 (%make-constant-float/int 4 index value)) 234 256 235 257 (defun make-constant-int (index value) 258 "Creates a `constant-float/int' structure instance containing an int." 236 259 (%make-constant-float/int 3 index value)) 237 260 … … 243 266 (declaim (inline make-constant-double make-constant-float)) 244 267 (defun make-constant-double (index value) 268 "Creates a `constant-double/long' structure instance containing a double." 245 269 (%make-constant-double/long 6 index value)) 246 270 247 271 (defun make-constant-long (index value) 272 "Creates a `constant-double/long' structure instance containing a long." 248 273 (%make-constant-double/long 5 index value)) 249 274 … … 264 289 265 290 (defun pool-add-class (pool class) 266 ;; ### do we make class a string or class-name structure? 291 "Returns the index of the constant-pool class item for `class'. 292 293 `class' must be an instance of `class-name'." 267 294 (let ((entry (gethash class (pool-entries pool)))) 268 295 (unless entry … … 276 303 277 304 (defun pool-add-field-ref (pool class name type) 305 "Returns the index of the constant-pool item which denotes a reference 306 to the `name' field of the `class', being of `type'. 307 308 `class' should be an instance of `class-name'. 309 `name' is a string. 310 `type' is a field-type (see `internal-field-type')" 278 311 (let ((entry (gethash (acons name type class) (pool-entries pool)))) 279 312 (unless entry … … 286 319 287 320 (defun pool-add-method-ref (pool class name type) 321 "Returns the index of the constant-pool item which denotes a reference 322 to the method with `name' in `class', which is of `type'. 323 324 Here, `type' is a method descriptor, which defines the argument types 325 and return type. `class' is an instance of `class-name'." 288 326 (let ((entry (gethash (acons name type class) (pool-entries pool)))) 289 327 (unless entry … … 296 334 297 335 (defun pool-add-interface-method-ref (pool class name type) 336 "Returns the index of the constant-pool item which denotes a reference to 337 the method `name' in the interface `class', which is of `type'. 338 339 See `pool-add-method-ref' for remarks." 298 340 (let ((entry (gethash (acons name type class) (pool-entries pool)))) 299 341 (unless entry … … 308 350 309 351 (defun pool-add-string (pool string) 352 "Returns the index of the constant-pool item denoting the string." 310 353 (let ((entry (gethash (cons 8 string) ;; 8 == string-tag 311 354 (pool-entries pool)))) … … 318 361 319 362 (defun pool-add-int (pool int) 363 "Returns the index of the constant-pool item denoting the int." 320 364 (let ((entry (gethash (cons 3 int) (pool-entries pool)))) 321 365 (unless entry … … 326 370 327 371 (defun pool-add-float (pool float) 372 "Returns the index of the constant-pool item denoting the float." 328 373 (let ((entry (gethash (cons 4 float) (pool-entries pool)))) 329 374 (unless entry … … 334 379 335 380 (defun pool-add-long (pool long) 381 "Returns the index of the constant-pool item denoting the long." 336 382 (let ((entry (gethash (cons 5 long) (pool-entries pool)))) 337 383 (unless entry … … 343 389 344 390 (defun pool-add-double (pool double) 391 "Returns the index of the constant-pool item denoting the double." 345 392 (let ((entry (gethash (cons 6 double) (pool-entries pool)))) 346 393 (unless entry … … 352 399 353 400 (defun pool-add-name/type (pool name type) 401 "Returns the index of the constant-pool item denoting 402 the name/type identifier." 354 403 (let ((entry (gethash (cons name type) (pool-entries pool))) 355 404 (internal-type (if (listp type) … … 365 414 366 415 (defun pool-add-utf8 (pool utf8-as-string) 416 "Returns the index of the textual value that will be stored in the 417 class file as UTF-8 encoded data." 367 418 (let ((entry (gethash (cons 11 utf8-as-string) ;; 11 == utf8 368 419 (pool-entries pool)))) … … 385 436 386 437 (defun class-add-field (class field) 438 "Adds a `field' created by `make-field'." 387 439 (push field (class-file-fields class))) 388 440 389 441 (defun class-field (class name) 442 "Finds a field by name." ;; ### strictly speaking, a field is uniquely 443 ;; identified by its name and type, not by the name alone. 390 444 (find name (class-file-fields class) 391 445 :test #'string= :key #'field-name)) 392 446 393 447 (defun class-add-method (class method) 448 "Adds a `method' to `class'; the method must have been created using 449 `make-method'." 394 450 (push method (class-file-methods class))) 395 451 396 452 (defun class-methods-by-name (class name) 453 "Returns all methods which have `name'." 397 454 (remove name (class-file-methods class) 398 455 :test-not #'string= :key #'method-name)) 399 456 400 457 (defun class-method (class name return &rest args) 458 "Return the method which is (uniquely) identified by its name AND descriptor." 401 459 (let ((return-and-args (cons return args))) 402 460 (find-if #'(lambda (c) … … 406 464 407 465 (defun class-add-attribute (class attribute) 466 "Adds `attribute' to the class; attributes must be instances of 467 structure classes which include the `attribute' structure class." 408 468 (push attribute (class-file-attributes class))) 409 469 410 470 (defun class-attribute (class name) 471 "Returns the attribute which is named `name'." 411 472 (find name (class-file-attributes class) 412 473 :test #'string= :key #'attribute-name)) … … 414 475 415 476 (defun finalize-class-file (class) 416 477 "Transforms the representation of the class-file from one 478 which allows easy modification to one which works best for serialization. 479 480 The class can't be modified after serialization." 417 481 ;; constant pool contains constants finalized on addition; 418 482 ;; no need for additional finalization … … 429 493 (finalize-method method class)) 430 494 ;; top-level attributes (no parent attributes to refer to) 431 (finalize-attributes (class-file-attributes class) nil class) 432 433 ) 495 (finalize-attributes (class-file-attributes class) nil class)) 434 496 435 497 (defun !write-class-file (class stream) 436 ;; all components need to finalize themselves: 437 ;; the constant pool needs to be complete before we start 438 ;; writing our output. 498 "Serializes `class' to `stream', after it has been finalized." 439 499 440 500 ;; header … … 474 534 (write-u1 tag stream) 475 535 (case tag 476 (1 ; UTF8536 (1 ; UTF8 477 537 (write-utf8 (constant-utf8-value entry) stream)) 478 ((3 4) ; int538 ((3 4) ; int 479 539 (write-u4 (constant-float/int-value entry) stream)) 480 ((5 6) ; long double540 ((5 6) ; long double 481 541 (write-u4 (logand (ash (constant-double/long-value entry) -32) 482 542 #xFFFFffff) stream) … … 485 545 (write-u2 (constant-member-ref-class-index entry) stream) 486 546 (write-u2 (constant-member-ref-name/type-index entry) stream)) 487 (12 ; nameAndType547 (12 ; nameAndType 488 548 (write-u2 (constant-name/type-name-index entry) stream) 489 549 (write-u2 (constant-name/type-descriptor-index entry) stream)) 490 (7 ; class550 (7 ; class 491 551 (write-u2 (constant-class-name-index entry) stream)) 492 (8 ; string552 (8 ; string 493 553 (write-u2 (constant-string-value-index entry) stream)) 494 554 (t … … 518 578 519 579 (defun map-flags (flags) 580 "Calculates the bitmap of the flags from a list of symbols." 520 581 (reduce #'(lambda (y x) 521 582 (logior (or (when (member (car x) flags) … … 529 590 name 530 591 descriptor 531 attributes 532 ) 592 attributes) 533 593 534 594 (defun make-field (name type &key (flags '(:public))) … … 565 625 name 566 626 descriptor 567 attributes 568 ) 627 attributes) 569 628 570 629 571 630 (defun map-method-name (name) 631 "Methods should be identified by strings containing their names, or, 632 be one of two keyword identifiers to identify special methods: 633 634 * :class-constructor 635 * :constructor 636 " 572 637 (cond 573 638 ((eq name :class-constructor)
Note: See TracChangeset
for help on using the changeset viewer.
