Changeset 12904


Ignore:
Timestamp:
08/29/10 17:30:04 (11 years ago)
Author:
ehuelsmann
Message:

Resolve the WRITE-CLASS-FILE double-use.

Location:
branches/generic-class-file/abcl/src/org/armedbear/lisp
Files:
2 edited

Legend:

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

    r12897 r12904  
    516516    (emit-invokestatic +lisp+ "type_error"
    517517                       (lisp-object-arg-types 2) +lisp-object+)
    518     (emit 'pop) ; Needed for JVM stack consistency.
     518    (emit 'areturn) ; Needed for JVM stack consistency.
    519519    (label LABEL1))
    520520  t)
     
    911911
    912912
    913 (defun write-class-file (class stream)
     913(defun finish-class (class stream)
     914  "Finalizes the `class' and writes the result to `stream'.
     915
     916The compiler calls this function to indicate it doesn't want to
     917extend the class any further."
    914918  (class-add-method class (make-constructor (class-file-superclass class)
    915919                                            (abcl-class-file-lambda-name class)
    916920                                            (abcl-class-file-lambda-list class)))
    917921  (finalize-class-file class)
    918   (!write-class-file class stream))
     922  (write-class-file class stream))
    919923
    920924
     
    37913795    (p2-compiland compiland)
    37923796;;        (finalize-class-file (compiland-class-file compiland))
    3793   (write-class-file (compiland-class-file compiland) stream)))))
     3797  (finish-class (compiland-class-file compiland) stream)))))
    37943798
    37953799(defun set-compiland-and-write-class (class-file compiland stream)
     
    70867090        (*current-compiland* compiland))
    70877091    (with-saved-compiler-policy
    7088       ;; Pass 1.
    7089       (p1-compiland compiland)
    7090       ;; *all-variables* doesn't contain variables which
    7091       ;; are in an enclosing lexical environment (variable-environment)
    7092       ;; so we don't need to filter them out
    7093       (setf *closure-variables*
    7094             (remove-if #'variable-special-p
    7095                        (remove-if-not #'variable-used-non-locally-p
    7096                                                  *all-variables*)))
    7097       (let ((i 0))
    7098         (dolist (var (reverse *closure-variables*))
    7099           (setf (variable-closure-index var) i)
    7100           (dformat t "var = ~S closure index = ~S~%" (variable-name var)
    7101                    (variable-closure-index var))
    7102           (incf i)))
     7092        ;; Pass 1.
     7093        (p1-compiland compiland))
     7094
     7095    ;; *all-variables* doesn't contain variables which
     7096    ;; are in an enclosing lexical environment (variable-environment)
     7097    ;; so we don't need to filter them out
     7098    (setf *closure-variables*
     7099          (remove-if #'variable-special-p
     7100                     (remove-if-not #'variable-used-non-locally-p
     7101                                    *all-variables*)))
     7102    (let ((i 0))
     7103      (dolist (var (reverse *closure-variables*))
     7104        (setf (variable-closure-index var) i)
     7105        (dformat t "var = ~S closure index = ~S~%" (variable-name var)
     7106                 (variable-closure-index var))
     7107        (incf i)))
    71037108
    71047109      ;; Assert that we're not refering to any variables
    71057110      ;; we're not allowed to use
    7106       (assert (= 0
    7107                  (length (remove-if (complement #'variable-references)
    7108                                     (remove-if #'variable-references-allowed-p
    7109                                                *visible-variables*)))))
     7111
     7112    (assert (= 0
     7113               (length (remove-if (complement #'variable-references)
     7114                                  (remove-if #'variable-references-allowed-p
     7115                                             *visible-variables*)))))
    71107116
    71117117      ;; Pass 2.
    7112       (with-class-file (compiland-class-file compiland)
     7118
     7119    (with-class-file (compiland-class-file compiland)
     7120      (with-saved-compiler-policy
    71137121        (p2-compiland compiland)
    7114 ;;        (finalize-class-file (compiland-class-file compiland))
    7115         (write-class-file (compiland-class-file compiland) stream)))))
     7122        ;;        (finalize-class-file (compiland-class-file compiland))
     7123        (finish-class (compiland-class-file compiland) stream)))))
    71167124
    71177125(defvar *compiler-error-bailout*)
  • branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp

    r12896 r12904  
    533533(defun class-methods-by-name (class name)
    534534  "Returns all methods which have `name'."
    535   (remove name (class-file-methods class)
     535  (remove (map-method-name name) (class-file-methods class)
    536536          :test-not #'string= :key #'method-name))
    537537
    538538(defun class-method (class name return &rest args)
    539539  "Return the method which is (uniquely) identified by its name AND descriptor."
    540   (let ((return-and-args (cons return args)))
     540  (let ((return-and-args (cons return args))
     541        (name (map-method-name name)))
    541542    (find-if #'(lambda (c)
    542543                 (and (string= (method-name c) name)
     
    662663
    663664
    664 (defun !write-class-file (class stream)
     665(defun write-class-file (class stream)
    665666  "Serializes `class' to `stream', after it has been finalized."
    666667
     
    846847be one of two keyword identifiers to identify special methods:
    847848
    848  * :class-constructor
     849 * :static-initializer
    849850 * :constructor
    850851"
    851852  (cond
    852     ((eq name :class-constructor)
     853    ((eq name :static-initializer)
    853854     "<clinit>")
    854855    ((eq name :constructor)
     
    860861  (%make-method :descriptor (cons return args)
    861862                :access-flags flags
    862                 :name name))
     863                :name (map-method-name name)))
    863864
    864865(defun method-add-attribute (method attribute)
     
    899900          (pool-add-utf8 pool (apply #'descriptor (method-descriptor method)))
    900901          (method-name method)
    901           (pool-add-utf8 pool (map-method-name (method-name method)))))
     902          (pool-add-utf8 pool (method-name method))))
    902903  (finalize-attributes (method-attributes method) nil class))
    903904
     
    993994                            (mapcar #'exception-handler-pc handlers))
    994995                     t)))
    995     (setf (code-max-stack code)
    996           (analyze-stack c (mapcar #'exception-handler-pc handlers)))
     996    (unless (code-max-stack code)
     997      (setf (code-max-stack code)
     998            (analyze-stack c (mapcar #'exception-handler-pc handlers))))
     999    (unless (code-max-locals code)
     1000      (setf (code-max-locals code)
     1001            (analyze-locals code)))
    9971002    (multiple-value-bind
    9981003          (c labels)
     
    11441149        *register* (code-current-local code)))
    11451150
    1146 (defmacro with-code-to-method ((class-file method &key (safe-nesting t))
    1147              &body body)
     1151(defmacro with-code-to-method ((class-file method)
     1152                               &body body)
    11481153  (let ((m (gensym))
    11491154        (c (gensym)))
    11501155    `(progn
    1151        ,@(when safe-nesting
    1152            `((when *current-code-attribute*
    1153                (save-code-specials *current-code-attribute*))))
     1156       (when *current-code-attribute*
     1157         (save-code-specials *current-code-attribute*))
    11541158       (let* ((,m ,method)
    11551159              (,c (method-ensure-code ,method))
     
    11611165         ,@body
    11621166         (setf (code-code ,c) *code*
    1163          (code-current-local ,c) *register*
    1164 ;;               (code-exception-handlers ,c) *handlers*
     1167               (code-current-local ,c) *register*
    11651168               (code-max-locals ,c) *registers-allocated*))
    1166        ,@(when safe-nesting
    1167            `((when *current-code-attribute*
    1168                (restore-code-specials *current-code-attribute*)))))))
     1169       (when *current-code-attribute*
     1170         (restore-code-specials *current-code-attribute*)))))
    11691171
    11701172
Note: See TracChangeset for help on using the changeset viewer.