Changeset 12832
- Timestamp:
- 07/29/10 18:27:10 (13 years ago)
- Location:
- branches/generic-class-file/abcl
- Files:
-
- 3 edited
-
src/org/armedbear/lisp/compiler-pass2.lisp (modified) (6 diffs)
-
src/org/armedbear/lisp/jvm-class-file.lisp (modified) (31 diffs)
-
test/lisp/abcl/class-file.lisp (modified) (5 diffs)
Legend:
- Unmodified
- Added
- Removed
-
branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
r12806 r12832 1305 1305 (return-from walk-code)))))) 1306 1306 1307 (declaim (ftype (function ( ) t) analyze-stack))1308 (defun analyze-stack ( )1307 (declaim (ftype (function (t) t) analyze-stack)) 1308 (defun analyze-stack (code) 1309 1309 (declare (optimize speed)) 1310 (let* ((code *code*) 1311 (code-length (length code))) 1310 (let* ((code-length (length code))) 1312 1311 (declare (type vector code)) 1313 1312 (dotimes (i code-length) … … 1573 1572 1574 1573 (defun code-bytes (code) 1575 (let ((length 0)) 1574 (let ((length 0) 1575 labels ;; alist 1576 ) 1576 1577 (declare (type (unsigned-byte 16) length)) 1577 1578 ;; Pass 1: calculate label offsets and overall length. … … 1582 1583 (if (= opcode 202) ; LABEL 1583 1584 (let ((label (car (instruction-args instruction)))) 1584 (set label length)) 1585 (set label length) 1586 (setf labels 1587 (acons label length labels))) 1585 1588 (incf length (opcode-size opcode))))) 1586 1589 ;; Pass 2: replace labels with calculated offsets. … … 1609 1612 (setf (svref bytes index) byte) 1610 1613 (incf index))))) 1611 bytes)))1614 (values bytes labels)))) 1612 1615 1613 1616 (declaim (inline write-u1)) … … 1879 1882 (finalize-code) 1880 1883 (setf *code* (resolve-instructions *code*)) 1881 (setf (method-max-stack constructor) (analyze-stack ))1884 (setf (method-max-stack constructor) (analyze-stack *code*)) 1882 1885 (setf (method-code constructor) (code-bytes *code*)) 1883 1886 (setf (method-handlers constructor) (nreverse *handlers*)) … … 8206 8209 8207 8210 (setf *code* (resolve-instructions *code*)) 8208 (setf (method-max-stack execute-method) (analyze-stack ))8211 (setf (method-max-stack execute-method) (analyze-stack *code*)) 8209 8212 (setf (method-code execute-method) (code-bytes *code*)) 8210 8213 -
branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
r12795 r12832 181 181 in JVM-internal representation." 182 182 (format nil "(~{~A~})~A" (mapcar #'internal-field-ref argument-types) 183 (internal-field- typereturn-type)))183 (internal-field-ref return-type))) 184 184 185 185 186 186 (defstruct pool 187 ;; ` count' contains a reference to the last-used slot (0 beingempty)187 ;; `index' contains the index of the last allocated slot (0 == empty) 188 188 ;; "A constant pool entry is considered valid if it has 189 189 ;; an index greater than 0 (zero) and less than pool-count" 190 ( count0)190 (index 0) 191 191 entries-list 192 192 ;; the entries hash stores raw values, except in case of string and … … 285 285 (defstruct (constant-utf8 (:constructor make-constant-utf8 (index value)) 286 286 (:include constant 287 (tag 1 1)))287 (tag 1))) 288 288 value) 289 289 … … 295 295 (let ((entry (gethash class (pool-entries pool)))) 296 296 (unless entry 297 (setf entry 298 (make-constant-class (incf (pool-count pool)) 299 (pool-add-utf8 pool 300 (class-name-internal class))) 301 (gethash class (pool-entries pool)) entry) 297 (let ((utf8 (pool-add-utf8 pool (class-name-internal class)))) 298 (setf entry 299 (make-constant-class (incf (pool-index pool)) utf8) 300 (gethash class (pool-entries pool)) entry)) 302 301 (push entry (pool-entries-list pool))) 303 302 (constant-index entry))) … … 312 311 (let ((entry (gethash (acons name type class) (pool-entries pool)))) 313 312 (unless entry 314 ( setf entry (make-constant-field-ref (incf (pool-count pool))315 (pool-add-class pool class)316 (pool-add-name/type pool name type))317 (gethash (acons name type class) (pool-entries pool)) entry) 313 (let ((c (pool-add-class pool class)) 314 (n/t (pool-add-name/type pool name type))) 315 (setf entry (make-constant-field-ref (incf (pool-index pool)) c n/t) 316 (gethash (acons name type class) (pool-entries pool)) entry)) 318 317 (push entry (pool-entries-list pool))) 319 318 (constant-index entry))) … … 327 326 (let ((entry (gethash (acons name type class) (pool-entries pool)))) 328 327 (unless entry 329 ( setf entry (make-constant-method-ref (incf (pool-count pool))330 (pool-add-class pool class)331 (pool-add-name/type pool name type))332 (gethash (acons name type class) (pool-entries pool)) entry)328 (let ((c (pool-add-class pool class)) 329 (n/t (pool-add-name/type pool name type))) 330 (setf entry (make-constant-method-ref (incf (pool-index pool)) c n/t) 331 (gethash (acons name type class) (pool-entries pool)) entry)) 333 332 (push entry (pool-entries-list pool))) 334 333 (constant-index entry))) … … 341 340 (let ((entry (gethash (acons name type class) (pool-entries pool)))) 342 341 (unless entry 343 (setf entry 344 (make-constant-interface-method-ref (incf (pool-count pool)) 345 (pool-add-class pool class) 346 (pool-add-name/type pool 347 name type)) 348 (gethash (acons name type class) (pool-entries pool)) entry) 342 (let ((c (pool-add-class pool class)) 343 (n/t (pool-add-name/type pool name type))) 344 (setf entry 345 (make-constant-interface-method-ref (incf (pool-index pool)) c n/t) 346 (gethash (acons name type class) (pool-entries pool)) entry)) 349 347 (push entry (pool-entries-list pool))) 350 348 (constant-index entry))) … … 355 353 (pool-entries pool)))) 356 354 (unless entry 357 ( setf entry (make-constant-string (incf (pool-count pool))358 (pool-add-utf8 pool string))359 (gethash (cons 8 string) (pool-entries pool)) entry)355 (let ((utf8 (pool-add-utf8 pool string))) 356 (setf entry (make-constant-string (incf (pool-index pool)) utf8) 357 (gethash (cons 8 string) (pool-entries pool)) entry)) 360 358 (push entry (pool-entries-list pool))) 361 359 (constant-index entry))) … … 365 363 (let ((entry (gethash (cons 3 int) (pool-entries pool)))) 366 364 (unless entry 367 (setf entry (make-constant-int (incf (pool- countpool)) int)365 (setf entry (make-constant-int (incf (pool-index pool)) int) 368 366 (gethash (cons 3 int) (pool-entries pool)) entry) 369 367 (push entry (pool-entries-list pool))) … … 374 372 (let ((entry (gethash (cons 4 float) (pool-entries pool)))) 375 373 (unless entry 376 (setf entry (make-constant-float (incf (pool- countpool)) float)374 (setf entry (make-constant-float (incf (pool-index pool)) float) 377 375 (gethash (cons 4 float) (pool-entries pool)) entry) 378 376 (push entry (pool-entries-list pool))) … … 383 381 (let ((entry (gethash (cons 5 long) (pool-entries pool)))) 384 382 (unless entry 385 (setf entry (make-constant-long (incf (pool- countpool)) long)383 (setf entry (make-constant-long (incf (pool-index pool)) long) 386 384 (gethash (cons 5 long) (pool-entries pool)) entry) 387 385 (push entry (pool-entries-list pool)) 388 (incf (pool- countpool))) ;; double index increase; long takes 2 slots386 (incf (pool-index pool))) ;; double index increase; long takes 2 slots 389 387 (constant-index entry))) 390 388 … … 393 391 (let ((entry (gethash (cons 6 double) (pool-entries pool)))) 394 392 (unless entry 395 (setf entry (make-constant-double (incf (pool- countpool)) double)393 (setf entry (make-constant-double (incf (pool-index pool)) double) 396 394 (gethash (cons 6 double) (pool-entries pool)) entry) 397 395 (push entry (pool-entries-list pool)) 398 (incf (pool- countpool))) ;; double index increase; 'double' takes 2 slots396 (incf (pool-index pool))) ;; double index increase; 'double' takes 2 slots 399 397 (constant-index entry))) 400 398 … … 407 405 (internal-field-ref type)))) 408 406 (unless entry 409 ( setf entry (make-constant-name/type (incf (pool-count pool))410 (pool-add-utf8 pool name)411 (pool-add-utf8 pool internal-type))412 (gethash (cons name type) (pool-entries pool)) entry)407 (let ((n (pool-add-utf8 pool name)) 408 (i-t (pool-add-utf8 pool internal-type))) 409 (setf entry (make-constant-name/type (incf (pool-index pool)) n i-t) 410 (gethash (cons name type) (pool-entries pool)) entry)) 413 411 (push entry (pool-entries-list pool))) 414 412 (constant-index entry))) … … 420 418 (pool-entries pool)))) 421 419 (unless entry 422 (setf entry (make-constant-utf8 (incf (pool- countpool)) utf8-as-string)420 (setf entry (make-constant-utf8 (incf (pool-index pool)) utf8-as-string) 423 421 (gethash (cons 11 utf8-as-string) (pool-entries pool)) entry) 424 422 (push entry (pool-entries-list pool))) … … 479 477 which allows easy modification to one which works best for serialization. 480 478 481 The class can't be modified after serialization." 479 The class can't be modified after finalization." 480 482 481 ;; constant pool contains constants finalized on addition; 483 482 ;; no need for additional finalization … … 485 484 (setf (class-file-access-flags class) 486 485 (map-flags (class-file-access-flags class))) 487 (setf (class-file-class class) 486 (setf (class-file-superclass class) 487 (pool-add-class (class-file-constants class) 488 (class-file-superclass class)) 489 (class-file-class class) 488 490 (pool-add-class (class-file-constants class) 489 491 (class-file-class class))) … … 509 511 (write-u2 (class-file-access-flags class) stream) 510 512 ;; class name 513 511 514 (write-u2 (class-file-class class) stream) 512 515 ;; superclass … … 529 532 (write-attributes (class-file-attributes class) stream)) 530 533 534 535 (defvar *jvm-class-debug-pool* nil 536 "When bound to a non-NIL value, enables output to *standard-output* 537 to allow debugging output of the constant section of the class file.") 538 531 539 (defun write-constants (constants stream) 532 (write-u2 (pool-count constants) stream) 533 (dolist (entry (reverse (pool-entries-list constants))) 534 (let ((tag (constant-tag entry))) 535 (write-u1 tag stream) 540 "Writes the constant section given in `constants' to the class file `stream'." 541 (let ((pool-index 0)) 542 (write-u2 (1+ (pool-index constants)) stream) 543 (when *jvm-class-debug-pool* 544 (sys::%format t "pool count ~A~%" (pool-index constants))) 545 (dolist (entry (reverse (pool-entries-list constants))) 546 (incf pool-index) 547 (let ((tag (constant-tag entry))) 548 (when *jvm-class-debug-pool* 549 (print-constant entry t)) 550 (write-u1 tag stream) 551 (case tag 552 (1 ; UTF8 553 (write-utf8 (constant-utf8-value entry) stream)) 554 ((3 4) ; float int 555 (write-u4 (constant-float/int-value entry) stream)) 556 ((5 6) ; long double 557 (write-u4 (logand (ash (constant-double/long-value entry) -32) 558 #xFFFFffff) stream) 559 (write-u4 (logand (constant-double/long-value entry) #xFFFFffff) 560 stream)) 561 ((9 10 11) ; fieldref methodref InterfaceMethodref 562 (write-u2 (constant-member-ref-class-index entry) stream) 563 (write-u2 (constant-member-ref-name/type-index entry) stream)) 564 (12 ; nameAndType 565 (write-u2 (constant-name/type-name-index entry) stream) 566 (write-u2 (constant-name/type-descriptor-index entry) stream)) 567 (7 ; class 568 (write-u2 (constant-class-name-index entry) stream)) 569 (8 ; string 570 (write-u2 (constant-string-value-index entry) stream)) 571 (t 572 (error "write-constant-pool-entry unhandled tag ~D~%" tag))))))) 573 574 575 (defun print-constant (entry stream) 576 "Debugging helper to print the content of a constant-pool entry." 577 (let ((tag (constant-tag entry)) 578 (index (constant-index entry))) 579 (sys::%format stream "pool element ~a, tag ~a, " index tag) 536 580 (case tag 537 (1 ; UTF8 538 (write-utf8 (constant-utf8-value entry) stream)) 539 ((3 4) ; int 540 (write-u4 (constant-float/int-value entry) stream)) 541 ((5 6) ; long double 542 (write-u4 (logand (ash (constant-double/long-value entry) -32) 543 #xFFFFffff) stream) 544 (write-u4 (logand (constant-double/long-value entry) #xFFFFffff) stream)) 545 ((9 10 11) ; fieldref methodref InterfaceMethodref 546 (write-u2 (constant-member-ref-class-index entry) stream) 547 (write-u2 (constant-member-ref-name/type-index entry) stream)) 548 (12 ; nameAndType 549 (write-u2 (constant-name/type-name-index entry) stream) 550 (write-u2 (constant-name/type-descriptor-index entry) stream)) 551 (7 ; class 552 (write-u2 (constant-class-name-index entry) stream)) 553 (8 ; string 554 (write-u2 (constant-string-value-index entry) stream)) 555 (t 556 (error "write-constant-pool-entry unhandled tag ~D~%" tag)))))) 581 (1 (sys::%format t "utf8: ~a~%" (constant-utf8-value entry))) 582 ((3 4) (sys::%format t "f/i: ~a~%" (constant-float/int-value entry))) 583 ((5 6) (sys::%format t "d/l: ~a~%" (constant-double/long-value entry))) 584 ((9 10 11) (sys::%format t "ref: ~a,~a~%" 585 (constant-member-ref-class-index entry) 586 (constant-member-ref-name/type-index entry))) 587 (12 (sys::%format t "n/t: ~a,~a~%" 588 (constant-name/type-name-index entry) 589 (constant-name/type-descriptor-index entry))) 590 (7 (sys::%format t "cls: ~a~%" (constant-class-name-index entry))) 591 (8 (sys::%format t "str: ~a~%" (constant-string-value-index entry)))))) 592 557 593 558 594 #| … … 576 612 (:native #x0100) 577 613 (:abstract #x0400) 578 (:strict #x0800))) 614 (:strict #x0800)) 615 "List of keyword symbols used for human readable representation of (access) 616 flags and their binary values.") 579 617 580 618 (defun map-flags (flags) … … 588 626 589 627 (defstruct (field (:constructor %make-field)) 628 "" 590 629 access-flags 591 630 name … … 594 633 595 634 (defun make-field (name type &key (flags '(:public))) 635 596 636 (%make-field :access-flags flags 597 637 :name name … … 644 684 645 685 (defun !make-method (name return args &key (flags '(:public))) 646 (% make-method :descriptor (cons return args)686 (%!make-method :descriptor (cons return args) 647 687 :access-flags flags 648 688 :name name)) 649 689 650 690 (defun method-add-attribute (method attribute) 651 (push attribute (method-attributes method))) 691 "Add `attribute' to the list of attributes of `method', 692 returning `attribute'." 693 (push attribute (method-attributes method)) 694 attribute) 652 695 653 696 (defun method-add-code (method) 654 "Creates an (empty) 'Code' attribute for the method." 697 "Creates an (empty) 'Code' attribute for the method, 698 returning the created attribute." 655 699 (method-add-attribute 700 method 656 701 (make-code-attribute (+ (length (cdr (method-descriptor method))) 657 702 (if (member :static (method-access-flags method)) 658 703 0 1))))) ;; 1 == implicit 'this' 704 705 (defun method-ensure-code (method) 706 "Ensures the existence of a 'Code' attribute for the method, 707 returning the attribute." 708 (let ((code (method-attribute method "Code"))) 709 (if (null code) 710 (method-add-code method) 711 code))) 659 712 660 713 (defun method-attribute (method name) … … 677 730 (write-u2 (method-access-flags method) stream) 678 731 (write-u2 (method-name method) stream) 732 (sys::%format t "method-name: ~a~%" (method-name method)) 679 733 (write-u2 (method-descriptor method) stream) 680 734 (write-attributes (method-attributes method) stream)) … … 692 746 ;; assure header: make sure 'name' is in the pool 693 747 (setf (attribute-name attribute) 694 (pool-add- string(class-file-constants class)695 748 (pool-add-utf8 (class-file-constants class) 749 (attribute-name attribute))) 696 750 ;; we're saving "root" attributes: attributes which have no parent 697 751 (funcall (attribute-finalizer attribute) attribute att class))) … … 706 760 (funcall (attribute-writer attribute) attribute local-stream) 707 761 (let ((array (sys::%get-output-stream-array local-stream))) 708 (write-u 2(length array) stream)762 (write-u4 (length array) stream) 709 763 (write-sequence array stream))))) 710 764 … … 720 774 max-locals 721 775 code 776 exception-handlers 722 777 attributes 778 779 ;; fields not in the class file start here 780 723 781 ;; labels contains offsets into the code array after it's finalized 724 (labels (make-hash-table :test #'eq)) 725 726 ;; fields not in the class file start here 727 current-local ;; used for handling nested WITH-CODE-TO-METHOD blocks 728 ) 782 labels ;; an alist 783 784 current-local) ;; used for handling nested WITH-CODE-TO-METHOD blocks 785 729 786 730 787 731 788 (defun code-label-offset (code label) 732 ( gethash label (code-labels code)))789 (cdr (assoc label (code-labels code)))) 733 790 734 791 (defun (setf code-label-offset) (offset code label) 735 (setf (gethash label (code-labels code)) offset)) 736 737 (defun !finalize-code (code class) 738 (let ((c (coerce (resolve-instructions (code-code code)) 'vector))) 739 (setf (code-max-stack code) (analyze-stack c) 740 (code-code code) (code-bytes c))) 792 (setf (code-labels code) 793 (acons label offset (code-labels code)))) 794 795 796 797 (defun !finalize-code (code parent class) 798 (declare (ignore parent)) 799 (let ((c (resolve-instructions (coerce (reverse (code-code code)) 'vector)))) 800 (setf (code-max-stack code) (analyze-stack c)) 801 (multiple-value-bind 802 (c labels) 803 (code-bytes c) 804 (setf (code-code code) c 805 (code-labels code) labels))) 806 807 (dolist (exception (code-exception-handlers code)) 808 (setf (exception-start-pc exception) 809 (code-label-offset code (exception-start-pc exception)) 810 (exception-end-pc exception) 811 (code-label-offset code (exception-end-pc exception)) 812 (exception-handler-pc exception) 813 (code-label-offset code (exception-handler-pc exception)) 814 (exception-catch-type exception) 815 (if (null (exception-catch-type exception)) 816 0 ;; generic 'catch all' class index number 817 (pool-add-class (class-file-constants class) 818 (exception-catch-type exception))))) 819 741 820 (finalize-attributes (code-attributes code) code class)) 742 821 743 822 (defun !write-code (code stream) 823 (sys::%format t "max-stack: ~a~%" (code-max-stack code)) 744 824 (write-u2 (code-max-stack code) stream) 825 (sys::%format t "max-locals: ~a~%" (code-max-locals code)) 745 826 (write-u2 (code-max-locals code) stream) 746 827 (let ((code-array (code-code code))) 828 (sys::%format t "length: ~a~%" (length code-array)) 747 829 (write-u4 (length code-array) stream) 748 830 (dotimes (i (length code-array)) 749 831 (write-u1 (svref code-array i) stream))) 832 833 (write-u2 (length (code-exception-handlers code)) stream) 834 (dolist (exception (reverse (code-exception-handlers code))) 835 (sys::%format t "start-pc: ~a~%" (exception-start-pc exception)) 836 (write-u2 (exception-start-pc exception) stream) 837 (sys::%format t "end-pc: ~a~%" (exception-end-pc exception)) 838 (write-u2 (exception-end-pc exception) stream) 839 (sys::%format t "handler-pc: ~a~%" (exception-handler-pc exception)) 840 (write-u2 (exception-handler-pc exception) stream) 841 (write-u2 (exception-catch-type exception) stream)) 842 750 843 (write-attributes (code-attributes code) stream)) 751 844 … … 756 849 757 850 (defun code-add-attribute (code attribute) 758 (push attribute (code-attributes code))) 851 "Adds `attribute' to `code', returning `attribute'." 852 (push attribute (code-attributes code)) 853 attribute) 759 854 760 855 (defun code-attribute (code name) … … 763 858 764 859 860 (defun code-add-exception-handler (code start end handler type) 861 (push (make-exception :start-pc start 862 :end-pc end 863 :handler-pc handler 864 :catch-type type) 865 (code-exception-handlers code))) 866 867 (defun add-exception-handler (start end handler type) 868 (code-add-exception-handler *current-code-attribute* start end handler type)) 869 870 (defstruct exception 871 start-pc ;; label target 872 end-pc ;; label target 873 handler-pc ;; label target 874 catch-type ;; a string for a specific type, or NIL for all 875 ) 876 765 877 766 878 (defvar *current-code-attribute*) … … 769 881 (setf (code-code code) *code* 770 882 (code-max-locals code) *registers-allocated* 771 (code-exception-handlers code) *handlers*883 ;; (code-exception-handlers code) *handlers* 772 884 (code-current-local code) *register*)) 773 885 774 886 (defun restore-code-specials (code) 775 887 (setf *code* (code-code code) 888 ;; *handlers* (code-exception-handlers code) 776 889 *registers-allocated* (code-max-locals code) 777 890 *register* (code-current-local code))) … … 785 898 (save-code-specials *current-code-attribute*)))) 786 899 (let* ((,m ,method) 787 (,c (method- attribute ,m "Code"))900 (,c (method-ensure-code method)) 788 901 (*code* (code-code ,c)) 789 902 (*registers-allocated* (code-max-locals ,c)) … … 792 905 ,@body 793 906 (setf (code-code ,c) *code* 794 (code-exception-handlers ,c) *handlers*907 ;; (code-exception-handlers ,c) *handlers* 795 908 (code-max-locals ,c) *registers-allocated*)) 796 909 ,@(when safe-nesting … … 798 911 (restore-code-specials *current-code-attribute*))))))) 799 912 800 (defstruct (exceptions-attribute (:constructor make-exceptions)801 (:conc-name exceptions-)802 (:include attribute803 (name "Exceptions")804 (finalizer #'finalize-exceptions)805 (writer #'write-exceptions)))806 exceptions)807 808 (defun finalize-exceptions (exceptions code class)809 (dolist (exception (exceptions-exceptions exceptions))810 ;; no need to finalize `catch-type': it's already the index required811 (setf (exception-start-pc exception)812 (code-label-offset code (exception-start-pc exception))813 (exception-end-pc exception)814 (code-label-offset code (exception-end-pc exception))815 (exception-handler-pc exception)816 (code-label-offset code (exception-handler-pc exception))817 (exception-catch-type exception)818 (pool-add-string (class-file-constants class)819 (exception-catch-type exception))))820 ;;(finalize-attributes (exceptions-attributes exception) exceptions class)821 )822 823 824 (defun write-exceptions (exceptions stream)825 ; number of entries826 (write-u2 (length (exceptions-exceptions exceptions)) stream)827 (dolist (exception (exceptions-exceptions exceptions))828 (write-u2 (exception-start-pc exception) stream)829 (write-u2 (exception-end-pc exception) stream)830 (write-u2 (exception-handler-pc exception) stream)831 (write-u2 (exception-catch-type exception) stream)))832 833 (defun code-add-exception (code start end handler type)834 (when (null (code-attribute code "Exceptions"))835 (code-add-attribute code (make-exceptions)))836 (push (make-exception :start-pc start837 :end-pc end838 :handler-pc handler839 :catch-type type)840 (exceptions-exceptions (code-attribute code "Exceptions"))))841 842 (defstruct exception843 start-pc ;; label target844 end-pc ;; label target845 handler-pc ;; label target846 catch-type ;; a string for a specific type, or NIL for all847 )848 913 849 914 (defstruct (source-file-attribute (:conc-name source-) -
branches/generic-class-file/abcl/test/lisp/abcl/class-file.lisp
r12784 r12832 66 66 67 67 (deftest fieldtype.2 68 (string= (jvm::internal-field-type jvm::+ !lisp-object+)68 (string= (jvm::internal-field-type jvm::+lisp-object+) 69 69 "org/armedbear/lisp/LispObject") 70 70 T) … … 112 112 113 113 (deftest fieldref.2 114 (string= (jvm::internal-field-ref jvm::+ !lisp-object+)114 (string= (jvm::internal-field-ref jvm::+lisp-object+) 115 115 "Lorg/armedbear/lisp/LispObject;") 116 116 T) … … 125 125 126 126 (deftest descriptor.2 127 (string= (jvm::descriptor jvm::+ !lisp-object+ jvm::+!lisp-object+)127 (string= (jvm::descriptor jvm::+lisp-object+ jvm::+lisp-object+) 128 128 "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;") 129 129 T) 130 130 131 131 (deftest map-flags.1 132 (eql (jvm::map-flags '(:public)) #x0001)) 132 (eql (jvm::map-flags '(:public)) #x0001) 133 T) 133 134 134 135 (deftest pool.1 135 136 (let* ((pool (jvm::make-pool))) 136 (jvm::pool-add-class pool jvm::+ !lisp-readtable+)137 (jvm::pool-add-field-ref pool jvm::+ !lisp-readtable+ "ABC" :int)137 (jvm::pool-add-class pool jvm::+lisp-readtable+) 138 (jvm::pool-add-field-ref pool jvm::+lisp-readtable+ "ABC" :int) 138 139 (jvm::pool-add-field-ref pool 139 jvm::+ !lisp-readtable+ "ABD"140 jvm::+ !lisp-readtable+)141 (jvm::pool-add-method-ref pool jvm::+ !lisp-readtable+ "MBC" :int)142 (jvm::pool-add-method-ref pool jvm::+ !lisp-readtable+ "MBD"143 jvm::+ !lisp-readtable+)140 jvm::+lisp-readtable+ "ABD" 141 jvm::+lisp-readtable+) 142 (jvm::pool-add-method-ref pool jvm::+lisp-readtable+ "MBC" :int) 143 (jvm::pool-add-method-ref pool jvm::+lisp-readtable+ "MBD" 144 jvm::+lisp-readtable+) 144 145 (jvm::pool-add-interface-method-ref pool 145 jvm::+ !lisp-readtable+ "MBD" :int)146 jvm::+lisp-readtable+ "MBD" :int) 146 147 (jvm::pool-add-interface-method-ref pool 147 jvm::+ !lisp-readtable+ "MBD"148 jvm::+ !lisp-readtable+)148 jvm::+lisp-readtable+ "MBD" 149 jvm::+lisp-readtable+) 149 150 (jvm::pool-add-string pool "string") 150 151 (jvm::pool-add-int pool 1) … … 153 154 (jvm::pool-add-double pool 1.0d0) 154 155 (jvm::pool-add-name/type pool "name1" :int) 155 (jvm::pool-add-name/type pool "name2" jvm::+ !lisp-object+)156 (jvm::pool-add-name/type pool "name2" jvm::+lisp-object+) 156 157 (jvm::pool-add-utf8 pool "utf8") 157 158 T) … … 160 161 (deftest make-class-file.1 161 162 (let* ((class (jvm::make-class-name "org/armedbear/lisp/mcf_1")) 162 (file (jvm::!make-class-file class jvm::+ !lisp-object+ '(:public))))163 (file (jvm::!make-class-file class jvm::+lisp-object+ '(:public)))) 163 164 (jvm::class-add-field file (jvm::make-field "ABC" :int)) 164 (jvm::class-add-field file (jvm::make-field "ABD" jvm::+ !lisp-object+))165 (jvm::class-add-field file (jvm::make-field "ABD" jvm::+lisp-object+)) 165 166 (jvm::class-add-method file (jvm::!make-method "MBC" nil :int)) 166 (jvm::class-add-method file (jvm::!make-method "MBD" nil jvm::+!lisp-object+)) 167 (jvm::class-add-method file (jvm::!make-method "MBD" nil jvm::+lisp-object+)) 168 (jvm::class-add-method file (jvm::!make-method :constructor :void nil)) 169 (jvm::class-add-method file (jvm::!make-method :class-constructor :void nil)) 167 170 T) 168 171 T) 169 172 170 173 (deftest finalize-class-file.1 171 (let* ((class (jvm::make-class-name "org/armedbear/lisp/ mcf_1"))172 (file (jvm::!make-class-file class jvm::+ !lisp-object+ '(:public))))174 (let* ((class (jvm::make-class-name "org/armedbear/lisp/fcf_1")) 175 (file (jvm::!make-class-file class jvm::+lisp-object+ '(:public)))) 173 176 (jvm::class-add-field file (jvm::make-field "ABC" :int)) 174 (jvm::class-add-field file (jvm::make-field "ABD" jvm::+ !lisp-object+))177 (jvm::class-add-field file (jvm::make-field "ABD" jvm::+lisp-object+)) 175 178 (jvm::class-add-method file (jvm::!make-method "MBC" nil '(:int))) 176 179 (jvm::class-add-method file 177 180 (jvm::!make-method "MBD" nil 178 (list jvm::+ !lisp-object+)))181 (list jvm::+lisp-object+))) 179 182 (jvm::finalize-class-file file) 180 file) 181 T) 183 file 184 T) 185 T) 186 187 (deftest generate-method.1 188 (let* ((class (jvm::make-class-name "org/armedbear/lisp/gm_1")) 189 (file (jvm::!make-class-file class jvm::+lisp-object+ '(:public))) 190 (method (jvm::!make-method :class-constructor :void nil 191 :flags '(:static)))) 192 (jvm::class-add-method file method) 193 (jvm::with-code-to-method (method) 194 (jvm::emit 'return)) 195 (jvm::finalize-class-file file) 196 (with-open-stream (stream (sys::%make-byte-array-output-stream)) 197 (jvm::!write-class-file file stream) 198 (sys::load-compiled-function (sys::%get-output-stream-bytes stream))) 199 T) 200 T) 201 202 (deftest generate-method.2 203 (let* ((class (jvm::make-class-name "org/armedbear/lisp/gm_2")) 204 (file (jvm::!make-class-file class jvm::+lisp-object+ '(:public))) 205 (method (jvm::!make-method "doNothing" :void nil))) 206 (jvm::class-add-method file method) 207 (jvm::with-code-to-method (method) 208 (let ((label1 (gensym)) 209 (label2 (gensym)) 210 (label3 (gensym))) 211 (jvm::label label1) 212 (jvm::emit 'jvm::iconst_1) 213 (jvm::label label2) 214 (jvm::emit 'return) 215 (jvm::label label3) 216 (jvm::code-add-exception-handler (jvm::method-attribute method "Code") 217 label1 label2 label3 nil)) 218 (jvm::emit 'return)) 219 (jvm::finalize-class-file file) 220 (with-open-stream (stream (sys::%make-byte-array-output-stream)) 221 (jvm::!write-class-file file stream) 222 (sys::load-compiled-function (sys::%get-output-stream-bytes stream))) 223 T) 224 T) 225 226 227 ;;(deftest generate-method.2 228 ;; (let* ((class))))
Note: See TracChangeset
for help on using the changeset viewer.
