Changeset 8390

Timestamp:

01/24/05 02:39:14 (18 years ago)

Author:

piso

Message:

Work in progress (tested).

File:

• trunk/j/src/org/armedbear/lisp/jvm.lisp (modified) (16 diffs)

trunk/j/src/org/armedbear/lisp/jvm.lisp

@@ -2 +2 @@
 ;;;
 ;;; Copyright (C) 2003-2005 Peter Graves
-;;; $Id: jvm.lisp,v 1.366 2005-01-23 19:07:02 piso Exp $
+;;; $Id: jvm.lisp,v 1.367 2005-01-24 02:39:14 piso Exp $
 ;;;
 ;;; This program is free software; you can redistribute it and/or
@@ -75 +75 @@
   pathname ; pathname of output file
   class
+  superclass
   methods)
 
@@ -82 +83 @@
   arg-vars
   p1-result
-;;   classfile ; the filename of the class-file
   parent
   (children 0) ; Number of local functions defined with FLET or LABELS.
@@ -96 +96 @@
 (defvar *pool-entries* nil)
 
-;; (defvar *stream* nil)
 (defvar *this-class* nil)
 
@@ -3788 +3787 @@
                          (%format nil "local-~D.class" *child-count*)
                          (incf *child-count*))))
-;;     (setf (compiland-classfile compiland) pathname)
 
     (setf class-file (make-class-file :pathname pathname))
@@ -3814 +3812 @@
                    +lisp-object+)
              (emit 'var-set (local-function-variable local-function))))
-          (t (push (make-local-function :name name
-                                        :function function
-                                        :class-file class-file)
-                   *local-functions*)))))
+          (t
+           (push (make-local-function :name name
+                                      :function function
+                                      :class-file class-file)
+                 *local-functions*)))))
 
 (defun p2-flet (form &key (target *val*) representation)
@@ -3887 +3886 @@
     (cond (*compile-file-truename*
 
-;;            (setf (compiland-classfile compiland) (sys::next-classfile-name))
-
            (aver (null (compiland-class-file compiland)))
            (setf (compiland-class-file compiland)
@@ -3901 +3898 @@
 
            (let* ((local-function
-;;                    (make-local-function :classfile (compiland-classfile compiland))
-                   (make-local-function :class-file (compiland-class-file compiland))
-                   )
+                   (make-local-function :class-file (compiland-class-file compiland)))
                   (g (declare-local-function local-function)))
              (emit 'getstatic *this-class* g +lisp-object+)))
           (t
            (aver (null (compiland-class-file compiland)))
-;;            (setf (compiland-classfile compiland)
-;;                  (prog1
-;;                     (%format nil "local-~D.class" *child-count*)
-;;                     (incf *child-count*)))
            (setf (compiland-class-file compiland)
                  (make-class-file :pathname
@@ -3924 +3915 @@
              (p2-compiland compiland)
              (setf compiled-function
-;;                    (sys:load-compiled-function (compiland-classfile compiland))
-                   (sys:load-compiled-function (class-file-pathname (compiland-class-file compiland)))
-                   )
+                   (sys:load-compiled-function
+                    (class-file-pathname (compiland-class-file compiland))))
              (emit 'getstatic *this-class*
                    (declare-object compiled-function) +lisp-object+))))
@@ -4864 +4854 @@
            (get-descriptor (list +lisp-object-array+) +lisp-object+)))))
 
-(defun write-class-file (args execute-method filespec)
-  (dformat t "write-class-file ~S~%" filespec)
+(defun write-class-file (args execute-method class-file)
   (let* ((super (cond (*child-p*
                        (if *closure-variables*
@@ -4884 +4873 @@
 
     ;; Write out the class file.
-    (with-open-file (stream filespec
+    (with-open-file (stream (class-file-pathname class-file)
                             :direction :output
                             :element-type '(unsigned-byte 8)
@@ -4966 +4955 @@
                 (list* 'LAMBDA lambda-list (mapcar #'p1 body))))))))
 
+(defun class-name-from-filespec (filespec)
+  (let* ((name (pathname-name filespec)))
+    (dotimes (i (length name))
+      (when (eql (char name i) #\-)
+        (setf (char name i) #\_)))
+    (concatenate 'string "org/armedbear/lisp/" name)))
+  
 (defun p2-compiland (compiland)
   (dformat t "p2-compiland ~S~%" (compiland-name compiland))
@@ -4974 +4970 @@
          (*declared-fixnums* (make-hash-table :test 'eql))
          (filespec (class-file-pathname (compiland-class-file compiland)))
-         (class-name (let* ((name (pathname-name filespec)))
-                       (dotimes (i (length name))
-                         (when (eql (char name i) #\-)
-                           (setf (char name i) #\_)))
-                       name))
-         (*this-class*
-          (concatenate 'string "org/armedbear/lisp/" class-name))
+         (*this-class* (class-name-from-filespec filespec))
          (args (cadr p1-result))
          (body (cddr p1-result))
@@ -5257 +5247 @@
     (setf (method-max-locals execute-method) *registers-allocated*)
     (setf (method-handlers execute-method) (nreverse *handlers*))
-    (write-class-file args execute-method filespec)
-    (dformat t "leaving p2-compiland ~S~%" (compiland-name compiland))
-    filespec))
+    (write-class-file args execute-method (compiland-class-file compiland))
+    (dformat t "leaving p2-compiland ~S~%" (compiland-name compiland))))
 
 (defun compile-1 (compiland)
@@ -5288 +5277 @@
 
     ;; Pass 2.
-    (prog1
-     (p2-compiland compiland)
-     (dformat t "*all-variables* = ~S~%" (mapcar #'variable-name *all-variables*)))
-    ))
+    (p2-compiland compiland)
+    (dformat t "*all-variables* = ~S~%" (mapcar #'variable-name *all-variables*))
+    (class-file-pathname (compiland-class-file compiland))))
 
 (defun compile-defun (name form environment &optional (filespec "out.class"))
@@ -5301 +5289 @@
       (compile-1 (make-compiland :name name
                                  :lambda-expression (precompile-form form t)
-;;                                  :classfile filespec
                                  :class-file (make-class-file :pathname filespec)
                                  :parent *current-compiland*))))