Changeset 8390
- Timestamp:
- 01/24/05 02:39:14 (18 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/j/src/org/armedbear/lisp/jvm.lisp
r8389 r8390 2 2 ;;; 3 3 ;;; Copyright (C) 2003-2005 Peter Graves 4 ;;; $Id: jvm.lisp,v 1.36 6 2005-01-23 19:07:02piso Exp $4 ;;; $Id: jvm.lisp,v 1.367 2005-01-24 02:39:14 piso Exp $ 5 5 ;;; 6 6 ;;; This program is free software; you can redistribute it and/or … … 75 75 pathname ; pathname of output file 76 76 class 77 superclass 77 78 methods) 78 79 … … 82 83 arg-vars 83 84 p1-result 84 ;; classfile ; the filename of the class-file85 85 parent 86 86 (children 0) ; Number of local functions defined with FLET or LABELS. … … 96 96 (defvar *pool-entries* nil) 97 97 98 ;; (defvar *stream* nil)99 98 (defvar *this-class* nil) 100 99 … … 3788 3787 (%format nil "local-~D.class" *child-count*) 3789 3788 (incf *child-count*)))) 3790 ;; (setf (compiland-classfile compiland) pathname)3791 3789 3792 3790 (setf class-file (make-class-file :pathname pathname)) … … 3814 3812 +lisp-object+) 3815 3813 (emit 'var-set (local-function-variable local-function)))) 3816 (t (push (make-local-function :name name 3817 :function function 3818 :class-file class-file) 3819 *local-functions*))))) 3814 (t 3815 (push (make-local-function :name name 3816 :function function 3817 :class-file class-file) 3818 *local-functions*))))) 3820 3819 3821 3820 (defun p2-flet (form &key (target *val*) representation) … … 3887 3886 (cond (*compile-file-truename* 3888 3887 3889 ;; (setf (compiland-classfile compiland) (sys::next-classfile-name))3890 3891 3888 (aver (null (compiland-class-file compiland))) 3892 3889 (setf (compiland-class-file compiland) … … 3901 3898 3902 3899 (let* ((local-function 3903 ;; (make-local-function :classfile (compiland-classfile compiland)) 3904 (make-local-function :class-file (compiland-class-file compiland)) 3905 ) 3900 (make-local-function :class-file (compiland-class-file compiland))) 3906 3901 (g (declare-local-function local-function))) 3907 3902 (emit 'getstatic *this-class* g +lisp-object+))) 3908 3903 (t 3909 3904 (aver (null (compiland-class-file compiland))) 3910 ;; (setf (compiland-classfile compiland)3911 ;; (prog13912 ;; (%format nil "local-~D.class" *child-count*)3913 ;; (incf *child-count*)))3914 3905 (setf (compiland-class-file compiland) 3915 3906 (make-class-file :pathname … … 3924 3915 (p2-compiland compiland) 3925 3916 (setf compiled-function 3926 ;; (sys:load-compiled-function (compiland-classfile compiland)) 3927 (sys:load-compiled-function (class-file-pathname (compiland-class-file compiland))) 3928 ) 3917 (sys:load-compiled-function 3918 (class-file-pathname (compiland-class-file compiland)))) 3929 3919 (emit 'getstatic *this-class* 3930 3920 (declare-object compiled-function) +lisp-object+)))) … … 4864 4854 (get-descriptor (list +lisp-object-array+) +lisp-object+))))) 4865 4855 4866 (defun write-class-file (args execute-method filespec) 4867 (dformat t "write-class-file ~S~%" filespec) 4856 (defun write-class-file (args execute-method class-file) 4868 4857 (let* ((super (cond (*child-p* 4869 4858 (if *closure-variables* … … 4884 4873 4885 4874 ;; Write out the class file. 4886 (with-open-file (stream filespec4875 (with-open-file (stream (class-file-pathname class-file) 4887 4876 :direction :output 4888 4877 :element-type '(unsigned-byte 8) … … 4966 4955 (list* 'LAMBDA lambda-list (mapcar #'p1 body)))))))) 4967 4956 4957 (defun class-name-from-filespec (filespec) 4958 (let* ((name (pathname-name filespec))) 4959 (dotimes (i (length name)) 4960 (when (eql (char name i) #\-) 4961 (setf (char name i) #\_))) 4962 (concatenate 'string "org/armedbear/lisp/" name))) 4963 4968 4964 (defun p2-compiland (compiland) 4969 4965 (dformat t "p2-compiland ~S~%" (compiland-name compiland)) … … 4974 4970 (*declared-fixnums* (make-hash-table :test 'eql)) 4975 4971 (filespec (class-file-pathname (compiland-class-file compiland))) 4976 (class-name (let* ((name (pathname-name filespec))) 4977 (dotimes (i (length name)) 4978 (when (eql (char name i) #\-) 4979 (setf (char name i) #\_))) 4980 name)) 4981 (*this-class* 4982 (concatenate 'string "org/armedbear/lisp/" class-name)) 4972 (*this-class* (class-name-from-filespec filespec)) 4983 4973 (args (cadr p1-result)) 4984 4974 (body (cddr p1-result)) … … 5257 5247 (setf (method-max-locals execute-method) *registers-allocated*) 5258 5248 (setf (method-handlers execute-method) (nreverse *handlers*)) 5259 (write-class-file args execute-method filespec) 5260 (dformat t "leaving p2-compiland ~S~%" (compiland-name compiland)) 5261 filespec)) 5249 (write-class-file args execute-method (compiland-class-file compiland)) 5250 (dformat t "leaving p2-compiland ~S~%" (compiland-name compiland)))) 5262 5251 5263 5252 (defun compile-1 (compiland) … … 5288 5277 5289 5278 ;; Pass 2. 5290 (prog1 5291 (p2-compiland compiland) 5292 (dformat t "*all-variables* = ~S~%" (mapcar #'variable-name *all-variables*))) 5293 )) 5279 (p2-compiland compiland) 5280 (dformat t "*all-variables* = ~S~%" (mapcar #'variable-name *all-variables*)) 5281 (class-file-pathname (compiland-class-file compiland)))) 5294 5282 5295 5283 (defun compile-defun (name form environment &optional (filespec "out.class")) … … 5301 5289 (compile-1 (make-compiland :name name 5302 5290 :lambda-expression (precompile-form form t) 5303 ;; :classfile filespec5304 5291 :class-file (make-class-file :pathname filespec) 5305 5292 :parent *current-compiland*))))
Note: See TracChangeset
for help on using the changeset viewer.