Changeset 12832


Ignore:
Timestamp:
07/29/10 18:27:10 (12 years ago)
Author:
ehuelsmann
Message:

Lots of fixes from writing tests. Most notable the correction of
my perception that the exceptions table was stored as an attribute
of the "Code" attribute. It's not: it's part of said attribute.

Location:
branches/generic-class-file/abcl
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r12806 r12832  
    13051305          (return-from walk-code))))))
    13061306
    1307 (declaim (ftype (function () t) analyze-stack))
    1308 (defun analyze-stack ()
     1307(declaim (ftype (function (t) t) analyze-stack))
     1308(defun analyze-stack (code)
    13091309  (declare (optimize speed))
    1310   (let* ((code *code*)
    1311          (code-length (length code)))
     1310  (let* ((code-length (length code)))
    13121311    (declare (type vector code))
    13131312    (dotimes (i code-length)
     
    15731572
    15741573(defun code-bytes (code)
    1575   (let ((length 0))
     1574  (let ((length 0)
     1575        labels ;; alist
     1576        )
    15761577    (declare (type (unsigned-byte 16) length))
    15771578    ;; Pass 1: calculate label offsets and overall length.
     
    15821583        (if (= opcode 202) ; LABEL
    15831584            (let ((label (car (instruction-args instruction))))
    1584               (set label length))
     1585              (set label length)
     1586              (setf labels
     1587                    (acons label length labels)))
    15851588            (incf length (opcode-size opcode)))))
    15861589    ;; Pass 2: replace labels with calculated offsets.
     
    16091612              (setf (svref bytes index) byte)
    16101613              (incf index)))))
    1611       bytes)))
     1614      (values bytes labels))))
    16121615
    16131616(declaim (inline write-u1))
     
    18791882    (finalize-code)
    18801883    (setf *code* (resolve-instructions *code*))
    1881     (setf (method-max-stack constructor) (analyze-stack))
     1884    (setf (method-max-stack constructor) (analyze-stack *code*))
    18821885    (setf (method-code constructor) (code-bytes *code*))
    18831886    (setf (method-handlers constructor) (nreverse *handlers*))
     
    82068209
    82078210    (setf *code* (resolve-instructions *code*))
    8208     (setf (method-max-stack execute-method) (analyze-stack))
     8211    (setf (method-max-stack execute-method) (analyze-stack *code*))
    82098212    (setf (method-code execute-method) (code-bytes *code*))
    82108213
  • branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp

    r12795 r12832  
    181181in JVM-internal representation."
    182182  (format nil "(~{~A~})~A" (mapcar #'internal-field-ref argument-types)
    183           (internal-field-type return-type)))
     183          (internal-field-ref return-type)))
    184184
    185185
    186186(defstruct pool
    187   ;; `count' contains a reference to the last-used slot (0 being empty)
     187  ;; `index' contains the index of the last allocated slot (0 == empty)
    188188  ;; "A constant pool entry is considered valid if it has
    189189  ;; an index greater than 0 (zero) and less than pool-count"
    190   (count 0)
     190  (index 0)
    191191  entries-list
    192192  ;; the entries hash stores raw values, except in case of string and
     
    285285(defstruct (constant-utf8 (:constructor make-constant-utf8 (index value))
    286286                          (:include constant
    287                                     (tag 11)))
     287                                    (tag 1)))
    288288  value)
    289289
     
    295295  (let ((entry (gethash class (pool-entries pool))))
    296296    (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))
    302301      (push entry (pool-entries-list pool)))
    303302    (constant-index entry)))
     
    312311  (let ((entry (gethash (acons name type class) (pool-entries pool))))
    313312    (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))
    318317      (push entry (pool-entries-list pool)))
    319318    (constant-index entry)))
     
    327326  (let ((entry (gethash (acons name type class) (pool-entries pool))))
    328327    (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))
    333332      (push entry (pool-entries-list pool)))
    334333    (constant-index entry)))
     
    341340  (let ((entry (gethash (acons name type class) (pool-entries pool))))
    342341    (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))
    349347      (push entry (pool-entries-list pool)))
    350348    (constant-index entry)))
     
    355353                        (pool-entries pool))))
    356354    (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))
    360358      (push entry (pool-entries-list pool)))
    361359    (constant-index entry)))
     
    365363  (let ((entry (gethash (cons 3 int) (pool-entries pool))))
    366364    (unless entry
    367       (setf entry (make-constant-int (incf (pool-count pool)) int)
     365      (setf entry (make-constant-int (incf (pool-index pool)) int)
    368366            (gethash (cons 3 int) (pool-entries pool)) entry)
    369367      (push entry (pool-entries-list pool)))
     
    374372  (let ((entry (gethash (cons 4 float) (pool-entries pool))))
    375373    (unless entry
    376       (setf entry (make-constant-float (incf (pool-count pool)) float)
     374      (setf entry (make-constant-float (incf (pool-index pool)) float)
    377375            (gethash (cons 4 float) (pool-entries pool)) entry)
    378376      (push entry (pool-entries-list pool)))
     
    383381  (let ((entry (gethash (cons 5 long) (pool-entries pool))))
    384382    (unless entry
    385       (setf entry (make-constant-long (incf (pool-count pool)) long)
     383      (setf entry (make-constant-long (incf (pool-index pool)) long)
    386384            (gethash (cons 5 long) (pool-entries pool)) entry)
    387385      (push entry (pool-entries-list pool))
    388       (incf (pool-count pool))) ;; double index increase; long takes 2 slots
     386      (incf (pool-index pool))) ;; double index increase; long takes 2 slots
    389387    (constant-index entry)))
    390388
     
    393391  (let ((entry (gethash (cons 6 double) (pool-entries pool))))
    394392    (unless entry
    395       (setf entry (make-constant-double (incf (pool-count pool)) double)
     393      (setf entry (make-constant-double (incf (pool-index pool)) double)
    396394            (gethash (cons 6 double) (pool-entries pool)) entry)
    397395      (push entry (pool-entries-list pool))
    398       (incf (pool-count pool))) ;; double index increase; 'double' takes 2 slots
     396      (incf (pool-index pool))) ;; double index increase; 'double' takes 2 slots
    399397    (constant-index entry)))
    400398
     
    407405                           (internal-field-ref type))))
    408406    (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))
    413411      (push entry (pool-entries-list pool)))
    414412    (constant-index entry)))
     
    420418                        (pool-entries pool))))
    421419    (unless entry
    422       (setf entry (make-constant-utf8 (incf (pool-count pool)) utf8-as-string)
     420      (setf entry (make-constant-utf8 (incf (pool-index pool)) utf8-as-string)
    423421            (gethash (cons 11 utf8-as-string) (pool-entries pool)) entry)
    424422      (push entry (pool-entries-list pool)))
     
    479477which allows easy modification to one which works best for serialization.
    480478
    481 The class can't be modified after serialization."
     479The class can't be modified after finalization."
     480
    482481  ;; constant pool contains constants finalized on addition;
    483482  ;; no need for additional finalization
     
    485484  (setf (class-file-access-flags class)
    486485        (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)
    488490        (pool-add-class (class-file-constants class)
    489491                        (class-file-class class)))
     
    509511  (write-u2  (class-file-access-flags class) stream)
    510512  ;; class name
     513
    511514  (write-u2 (class-file-class class) stream)
    512515  ;; superclass
     
    529532  (write-attributes (class-file-attributes class) stream))
    530533
     534
     535(defvar *jvm-class-debug-pool* nil
     536  "When bound to a non-NIL value, enables output to *standard-output*
     537to allow debugging output of the constant section of the class file.")
     538
    531539(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)
    536580    (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
    557593
    558594#|
     
    576612    (:native       #x0100)
    577613    (:abstract     #x0400)
    578     (:strict       #x0800)))
     614    (:strict       #x0800))
     615  "List of keyword symbols used for human readable representation of (access)
     616flags and their binary values.")
    579617
    580618(defun map-flags (flags)
     
    588626
    589627(defstruct (field (:constructor %make-field))
     628  ""
    590629  access-flags
    591630  name
     
    594633
    595634(defun make-field (name type &key (flags '(:public)))
     635 
    596636  (%make-field :access-flags flags
    597637               :name name
     
    644684
    645685(defun !make-method (name return args &key (flags '(:public)))
    646   (%make-method :descriptor (cons return args)
     686  (%!make-method :descriptor (cons return args)
    647687                :access-flags flags
    648688                :name name))
    649689
    650690(defun method-add-attribute (method attribute)
    651   (push attribute (method-attributes method)))
     691  "Add `attribute' to the list of attributes of `method',
     692returning `attribute'."
     693  (push attribute (method-attributes method))
     694  attribute)
    652695
    653696(defun method-add-code (method)
    654   "Creates an (empty) 'Code' attribute for the method."
     697  "Creates an (empty) 'Code' attribute for the method,
     698returning the created attribute."
    655699  (method-add-attribute
     700   method
    656701   (make-code-attribute (+ (length (cdr (method-descriptor method)))
    657702                           (if (member :static (method-access-flags method))
    658703                               0 1))))) ;; 1 == implicit 'this'
     704
     705(defun method-ensure-code (method)
     706  "Ensures the existence of a 'Code' attribute for the method,
     707returning the attribute."
     708  (let ((code (method-attribute method "Code")))
     709    (if (null code)
     710        (method-add-code method)
     711        code)))
    659712
    660713(defun method-attribute (method name)
     
    677730  (write-u2 (method-access-flags method) stream)
    678731  (write-u2 (method-name method) stream)
     732  (sys::%format t "method-name: ~a~%" (method-name method))
    679733  (write-u2 (method-descriptor method) stream)
    680734  (write-attributes (method-attributes method) stream))
     
    692746    ;; assure header: make sure 'name' is in the pool
    693747    (setf (attribute-name attribute)
    694           (pool-add-string (class-file-constants class)
    695                            (attribute-name attribute)))
     748          (pool-add-utf8 (class-file-constants class)
     749                         (attribute-name attribute)))
    696750    ;; we're saving "root" attributes: attributes which have no parent
    697751    (funcall (attribute-finalizer attribute) attribute att class)))
     
    706760      (funcall (attribute-writer attribute) attribute local-stream)
    707761      (let ((array (sys::%get-output-stream-array local-stream)))
    708         (write-u2 (length array) stream)
     762        (write-u4 (length array) stream)
    709763        (write-sequence array stream)))))
    710764
     
    720774  max-locals
    721775  code
     776  exception-handlers
    722777  attributes
     778
     779  ;; fields not in the class file start here
     780
    723781  ;; 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
    729786
    730787
    731788(defun code-label-offset (code label)
    732   (gethash label (code-labels code)))
     789  (cdr (assoc label (code-labels code))))
    733790
    734791(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
    741820  (finalize-attributes (code-attributes code) code class))
    742821
    743822(defun !write-code (code stream)
     823  (sys::%format t "max-stack: ~a~%" (code-max-stack code))
    744824  (write-u2 (code-max-stack code) stream)
     825  (sys::%format t "max-locals: ~a~%" (code-max-locals code))
    745826  (write-u2 (code-max-locals code) stream)
    746827  (let ((code-array (code-code code)))
     828    (sys::%format t "length: ~a~%" (length code-array))
    747829    (write-u4 (length code-array) stream)
    748830    (dotimes (i (length code-array))
    749831      (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
    750843  (write-attributes (code-attributes code) stream))
    751844
     
    756849
    757850(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)
    759854
    760855(defun code-attribute (code name)
     
    763858
    764859
     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
    765877
    766878(defvar *current-code-attribute*)
     
    769881  (setf (code-code code) *code*
    770882        (code-max-locals code) *registers-allocated*
    771         (code-exception-handlers code) *handlers*
     883;;        (code-exception-handlers code) *handlers*
    772884        (code-current-local code) *register*))
    773885
    774886(defun restore-code-specials (code)
    775887  (setf *code* (code-code code)
     888;;        *handlers* (code-exception-handlers code)
    776889        *registers-allocated* (code-max-locals code)
    777890        *register* (code-current-local code)))
     
    785898               (save-code-specials *current-code-attribute*))))
    786899       (let* ((,m ,method)
    787               (,c (method-attribute ,m "Code"))
     900              (,c (method-ensure-code method))
    788901              (*code* (code-code ,c))
    789902              (*registers-allocated* (code-max-locals ,c))
     
    792905         ,@body
    793906         (setf (code-code ,c) *code*
    794                (code-exception-handlers ,c) *handlers*
     907;;               (code-exception-handlers ,c) *handlers*
    795908               (code-max-locals ,c) *registers-allocated*))
    796909       ,@(when safe-nesting
     
    798911               (restore-code-specials *current-code-attribute*)))))))
    799912
    800 (defstruct (exceptions-attribute (:constructor make-exceptions)
    801                                  (:conc-name exceptions-)
    802                                  (:include attribute
    803                                            (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 required
    811     (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 entries
    826   (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 start
    837                         :end-pc end
    838                         :handler-pc handler
    839                         :catch-type type)
    840         (exceptions-exceptions (code-attribute code "Exceptions"))))
    841 
    842 (defstruct exception
    843   start-pc    ;; label target
    844   end-pc      ;; label target
    845   handler-pc  ;; label target
    846   catch-type  ;; a string for a specific type, or NIL for all
    847   )
    848913
    849914(defstruct (source-file-attribute (:conc-name source-)
  • branches/generic-class-file/abcl/test/lisp/abcl/class-file.lisp

    r12784 r12832  
    6666
    6767(deftest fieldtype.2
    68     (string= (jvm::internal-field-type jvm::+!lisp-object+)
     68    (string= (jvm::internal-field-type jvm::+lisp-object+)
    6969             "org/armedbear/lisp/LispObject")
    7070  T)
     
    112112
    113113(deftest fieldref.2
    114     (string= (jvm::internal-field-ref jvm::+!lisp-object+)
     114    (string= (jvm::internal-field-ref jvm::+lisp-object+)
    115115             "Lorg/armedbear/lisp/LispObject;")
    116116  T)
     
    125125
    126126(deftest descriptor.2
    127     (string= (jvm::descriptor jvm::+!lisp-object+ jvm::+!lisp-object+)
     127    (string= (jvm::descriptor jvm::+lisp-object+ jvm::+lisp-object+)
    128128             "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")
    129129  T)
    130130
    131131(deftest map-flags.1
    132     (eql (jvm::map-flags '(:public)) #x0001))
     132    (eql (jvm::map-flags '(:public)) #x0001)
     133  T)
    133134
    134135(deftest pool.1
    135136    (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)
    138139      (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+)
    144145      (jvm::pool-add-interface-method-ref pool
    145                                           jvm::+!lisp-readtable+ "MBD" :int)
     146                                          jvm::+lisp-readtable+ "MBD" :int)
    146147      (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+)
    149150      (jvm::pool-add-string pool "string")
    150151      (jvm::pool-add-int pool 1)
     
    153154      (jvm::pool-add-double pool 1.0d0)
    154155      (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+)
    156157      (jvm::pool-add-utf8 pool "utf8")
    157158      T)
     
    160161(deftest make-class-file.1
    161162    (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))))
    163164      (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+))
    165166      (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))
    167170      T)
    168171  T)
    169172
    170173(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))))
    173176      (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+))
    175178      (jvm::class-add-method file (jvm::!make-method "MBC" nil '(:int)))
    176179      (jvm::class-add-method file
    177180                             (jvm::!make-method "MBD" nil
    178                                                 (list jvm::+!lisp-object+)))
     181                                                (list jvm::+lisp-object+)))
    179182      (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.