[armedbear-cvs] r12897 - branches/generic-class-file/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Fri Aug 13 23:31:56 UTC 2010
Author: ehuelsmann
Date: Fri Aug 13 19:31:55 2010
New Revision: 12897
Log:
Use the new generator's WRITE-CLASS-FILE function,
axing other WRITE-* methods from pass2.
Modified:
branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri Aug 13 19:31:55 2010
@@ -797,7 +797,7 @@
(let* ((*compiler-debug* nil)
;; We don't normally need to see debugging output for constructors.
(method (make-method :constructor :void nil
- :flags '(:public)))
+ :flags '(:public)))
(code (method-add-code method))
req-params-register
opt-params-register
@@ -907,25 +907,15 @@
method))
-(defun write-source-file-attr (source-file stream)
- (let* ((name-index (pool-name "SourceFile"))
- (source-file-index (pool-name source-file)))
- (write-u2 name-index stream)
- ;; "The value of the attribute_length item of a SourceFile_attribute
- ;; structure must be 2."
- (write-u4 2 stream)
- (write-u2 source-file-index stream)))
-
(defvar *source-line-number* nil)
-(defun write-line-number-table (stream)
- (let* ((name-index (pool-name "LineNumberTable")))
- (write-u2 name-index stream)
- (write-u4 6 stream) ; "the length of the attribute, excluding the initial six bytes"
- (write-u2 1 stream) ; number of entries
- (write-u2 0 stream) ; start_pc
- (write-u2 *source-line-number* stream)))
+(defun write-class-file (class stream)
+ (class-add-method class (make-constructor (class-file-superclass class)
+ (abcl-class-file-lambda-name class)
+ (abcl-class-file-lambda-list class)))
+ (finalize-class-file class)
+ (!write-class-file class stream))
(defknown declare-field (t t t) t)
@@ -1203,7 +1193,7 @@
(declare-with-hashtable
local-function *declared-functions* ht g
(setf g (symbol-name (gensym "LFUN")))
- (let* ((class-name (abcl-class-file-class
+ (let* ((class-name (abcl-class-file-class-name
(local-function-class-file local-function)))
(*code* *static-code*))
;; fixme *declare-inline*
@@ -3799,6 +3789,7 @@
(let ((*current-compiland* compiland))
(with-saved-compiler-policy
(p2-compiland compiland)
+;; (finalize-class-file (compiland-class-file compiland))
(write-class-file (compiland-class-file compiland) stream)))))
(defun set-compiland-and-write-class (class-file compiland stream)
@@ -3821,7 +3812,7 @@
(cond (*file-compilation*
(let* ((pathname (funcall *pathnames-generator*))
(class-file (make-abcl-class-file :pathname pathname
- :lambda-list lambda-list)))
+ :lambda-list lambda-list)))
(with-open-class-file (f class-file)
(set-compiland-and-write-class class-file compiland f))
(setf (local-function-class-file local-function) class-file)))
@@ -6809,59 +6800,6 @@
:if-exists :supersede)
, at body))
-(defun write-class-file (class-file stream)
- (let* ((super (abcl-class-file-superclass class-file))
- (this (abcl-class-file-class class-file))
- (this-index (pool-class this))
- (super-index (pool-class super))
- (constructor (make-constructor super
- (abcl-class-file-lambda-name class-file)
- (abcl-class-file-lambda-list class-file))))
- (pool-name "Code") ; Must be in pool!
- (class-add-method class-file constructor)
-
- (when *file-compilation*
- (pool-name "SourceFile") ; Must be in pool!
- (pool-name (file-namestring *compile-file-truename*)))
- (when (and (boundp '*source-line-number*)
- (fixnump *source-line-number*))
- (pool-name "LineNumberTable")) ; Must be in pool!
- (dolist (field (class-file-fields class-file))
- (finalize-field field class-file))
- (dolist (method (class-file-methods class-file))
- (finalize-method method class-file))
-
- (write-u4 #xCAFEBABE stream)
- (write-u2 3 stream)
- (write-u2 45 stream)
- (write-constants *pool* stream)
- ;; access flags
- (write-u2 #x21 stream)
- (write-u2 this-index stream)
- (write-u2 super-index stream)
- ;; interfaces count
- (write-u2 0 stream)
- ;; fields count
- (write-u2 (length (class-file-fields class-file)) stream)
- ;; fields
- (dolist (field (class-file-fields class-file))
- (write-field field stream))
- ;; methods count
- (write-u2 (length (abcl-class-file-methods class-file)) stream)
- ;; methods
- (dolist (method (abcl-class-file-methods class-file))
- (write-method method stream))
- ;; attributes count
- (cond (*file-compilation*
- ;; attributes count
- (write-u2 1 stream)
- ;; attributes table
- (write-source-file-attr (file-namestring *compile-file-truename*)
- stream))
- (t
- ;; attributes count
- (write-u2 0 stream)))
- stream))
(defknown p2-compiland-process-type-declarations (list) t)
(defun p2-compiland-process-type-declarations (body)
@@ -7130,6 +7068,7 @@
(setf (code-max-locals code) *registers-allocated*)
(setf (code-code code) *code*))
+
t)
(defun p2-with-inline-code (form target representation)
@@ -7172,6 +7111,7 @@
;; Pass 2.
(with-class-file (compiland-class-file compiland)
(p2-compiland compiland)
+;; (finalize-class-file (compiland-class-file compiland))
(write-class-file (compiland-class-file compiland) stream)))))
(defvar *compiler-error-bailout*)
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp Fri Aug 13 19:31:55 2010
@@ -121,6 +121,7 @@
(defstruct (abcl-class-file (:include class-file)
(:constructor %make-abcl-class-file))
pathname ; pathname of output file
+ class-name
lambda-name
lambda-list ; as advertised
static-code
@@ -158,9 +159,11 @@
(class-name-from-filespec pathname)
(make-unique-class-name)))
(class-file (%make-abcl-class-file :pathname pathname
- :class class-name
+ :class class-name ; to be finalized
+ :class-name class-name
:lambda-name lambda-name
- :lambda-list lambda-list)))
+ :lambda-list lambda-list
+ :access-flags '(:public :final))))
(when *file-compilation*
(let ((source-attribute
(make-source-file-attribute
More information about the armedbear-cvs
mailing list