Changeset 8389


Ignore:
Timestamp:
01/23/05 19:07:02 (17 years ago)
Author:
piso
Message:

Work in progress (tested).

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/jvm.lisp

    r8388 r8389  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.365 2005-01-23 16:50:39 piso Exp $
     4;;; $Id: jvm.lisp,v 1.366 2005-01-23 19:07:02 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    7272(defvar *compiler-debug* nil)
    7373
     74(defstruct class-file
     75  pathname ; pathname of output file
     76  class
     77  methods)
     78
    7479(defstruct compiland
    7580  name
     
    7782  arg-vars
    7883  p1-result
    79   classfile
     84;;   classfile ; the filename of the class-file
    8085  parent
    8186  (children 0) ; Number of local functions defined with FLET or LABELS.
    8287  argument-register
    8388  closure-register
     89  class-file ; class-file object
    8490  )
    8591
     
    209215  compiland
    210216  function
    211   classfile
     217  class-file
    212218  variable)
    213219
     
    19201926    (setf (field-name-index field) (pool-name (field-name field)))
    19211927    (setf (field-descriptor-index field) (pool-name (field-descriptor field)))
    1922     (setq *fields* (cons field *fields*))))
     1928    (push field *fields*)))
    19231929
    19241930(defun sanitize (symbol)
     
    21222128(defun declare-local-function (local-function)
    21232129  (let* ((g (symbol-name (gensym)))
    2124          (classfile (local-function-classfile local-function))
     2130         (pathname (class-file-pathname (local-function-class-file local-function)))
    21252131         (*code* *static-code*))
    21262132    (declare-field g +lisp-object+)
    2127     (emit 'ldc (pool-string (file-namestring classfile)))
     2133    (emit 'ldc (pool-string (file-namestring pathname)))
    21282134    (emit-invokestatic +lisp-class+ "loadCompiledFunction"
    21292135                       (list +java-string+) +lisp-object+)
     
    37643770         form
    37653771         function
    3766          classfile)
     3772         pathname
     3773         class-file)
    37673774    (when (or (memq '&optional lambda-list)
    37683775              (memq '&key lambda-list))
     
    37763783                   (error "P2-LOCAL-FUNCTION: can't handle optional argument with non-constant initform.")))))))
    37773784    (setf form (compiland-lambda-expression compiland))
    3778     (setf classfile (if *compile-file-truename*
     3785    (setf pathname (if *compile-file-truename*
    37793786                        (sys::next-classfile-name)
    37803787                        (prog1
    37813788                         (%format nil "local-~D.class" *child-count*)
    37823789                         (incf *child-count*))))
    3783     (setf (compiland-classfile compiland) classfile)
     3790;;     (setf (compiland-classfile compiland) pathname)
     3791
     3792    (setf class-file (make-class-file :pathname pathname))
     3793    (setf (compiland-class-file compiland) class-file)
     3794
    37843795    (let ((*current-compiland* compiland)
    37853796          (*speed* *speed*)
     
    37893800    (cond (*compile-file-truename*
    37903801           ;; Verify that the class file is loadable.
    3791            (let ((*default-pathname-defaults* classfile))
    3792              (unless (ignore-errors (sys:load-compiled-function classfile))
    3793                (error "P2-LOCAL-FUNCTION: unable to load ~S." classfile))))
    3794           (t (setf function (sys:load-compiled-function classfile))))
     3802           (let ((*default-pathname-defaults* pathname))
     3803             (unless (ignore-errors (sys:load-compiled-function pathname))
     3804               (error "P2-LOCAL-FUNCTION: unable to load ~S." pathname))))
     3805          (t (setf function (sys:load-compiled-function pathname))))
    37953806    (cond (local-function
    3796            (setf (local-function-classfile local-function) classfile)
     3807           (setf (local-function-class-file local-function) class-file)
    37973808           (let ((g (if *compile-file-truename*
    37983809                        (declare-local-function local-function)
     
    38053816          (t (push (make-local-function :name name
    38063817                                        :function function
    3807                                         :classfile classfile)
     3818                                        :class-file class-file)
    38083819                   *local-functions*)))))
    38093820
     
    38763887    (cond (*compile-file-truename*
    38773888
    3878            (setf (compiland-classfile compiland) (sys::next-classfile-name))
     3889;;            (setf (compiland-classfile compiland) (sys::next-classfile-name))
     3890
     3891           (aver (null (compiland-class-file compiland)))
     3892           (setf (compiland-class-file compiland)
     3893                 (make-class-file :pathname (sys::next-classfile-name)))
    38793894
    38803895           (let ((*current-compiland* compiland)
     
    38853900             (p2-compiland compiland))
    38863901
    3887            (let* ((local-function (make-local-function :classfile (compiland-classfile compiland)))
     3902           (let* ((local-function
     3903;;                    (make-local-function :classfile (compiland-classfile compiland))
     3904                   (make-local-function :class-file (compiland-class-file compiland))
     3905                   )
    38883906                  (g (declare-local-function local-function)))
    3889              (emit 'getstatic
    3890                    *this-class*
    3891                    g
    3892                    +lisp-object+))
    3893            )
     3907             (emit 'getstatic *this-class* g +lisp-object+)))
    38943908          (t
    3895            (setf (compiland-classfile compiland)
    3896                  (prog1
    3897                     (%format nil "local-~D.class" *child-count*)
    3898                     (incf *child-count*)))
     3909           (aver (null (compiland-class-file compiland)))
     3910;;            (setf (compiland-classfile compiland)
     3911;;                  (prog1
     3912;;                     (%format nil "local-~D.class" *child-count*)
     3913;;                     (incf *child-count*)))
     3914           (setf (compiland-class-file compiland)
     3915                 (make-class-file :pathname
     3916                                  (prog1
     3917                                   (%format nil "local-~D.class" *child-count*)
     3918                                   (incf *child-count*))))
    38993919           (let ((*current-compiland* compiland)
    39003920                 (*speed* *speed*)
     
    39043924             (p2-compiland compiland)
    39053925             (setf compiled-function
    3906                    (sys:load-compiled-function (compiland-classfile compiland)))
    3907              (emit 'getstatic
    3908                    *this-class*
    3909                    (declare-object compiled-function)
    3910                    +lisp-object+))))
     3926;;                    (sys:load-compiled-function (compiland-classfile compiland))
     3927                   (sys:load-compiled-function (class-file-pathname (compiland-class-file compiland)))
     3928                   )
     3929             (emit 'getstatic *this-class*
     3930                   (declare-object compiled-function) +lisp-object+))))
    39113931    (cond
    39123932     ((null *closure-variables*)) ; Nothing to do.
     
    48444864           (get-descriptor (list +lisp-object-array+) +lisp-object+)))))
    48454865
    4846 (defun write-class-file (args execute-method classfile)
    4847   (dformat t "write-class-file ~S~%" classfile)
     4866(defun write-class-file (args execute-method filespec)
     4867  (dformat t "write-class-file ~S~%" filespec)
    48484868  (let* ((super (cond (*child-p*
    48494869                       (if *closure-variables*
     
    48644884
    48654885    ;; Write out the class file.
    4866     (with-open-file (stream classfile
     4886    (with-open-file (stream filespec
    48674887                            :direction :output
    48684888                            :element-type '(unsigned-byte 8)
     
    49534973         (*declared-strings* (make-hash-table :test 'eq))
    49544974         (*declared-fixnums* (make-hash-table :test 'eql))
    4955          (classfile (compiland-classfile compiland))
    4956          (class-name
    4957           (let* ((pathname (pathname classfile))
    4958                  (name (pathname-name classfile)))
    4959             (dotimes (i (length name))
    4960               (when (eql (char name i) #\-)
    4961                 (setf (char name i) #\_)))
    4962             name))
     4975         (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))
    49634981         (*this-class*
    49644982          (concatenate 'string "org/armedbear/lisp/" class-name))
     
    52395257    (setf (method-max-locals execute-method) *registers-allocated*)
    52405258    (setf (method-handlers execute-method) (nreverse *handlers*))
    5241     (write-class-file args execute-method classfile)
     5259    (write-class-file args execute-method filespec)
    52425260    (dformat t "leaving p2-compiland ~S~%" (compiland-name compiland))
    5243     classfile))
     5261    filespec))
    52445262
    52455263(defun compile-1 (compiland)
     
    52755293    ))
    52765294
    5277 (defun compile-defun (name form environment &optional (classfile "out.class"))
     5295(defun compile-defun (name form environment &optional (filespec "out.class"))
    52785296  (aver (eq (car form) 'LAMBDA))
    52795297  (unless (or (null environment) (sys::empty-environment-p environment))
     
    52835301      (compile-1 (make-compiland :name name
    52845302                                 :lambda-expression (precompile-form form t)
    5285                                  :classfile classfile
     5303;;                                  :classfile filespec
     5304                                 :class-file (make-class-file :pathname filespec)
    52865305                                 :parent *current-compiland*))))
    52875306
     
    53525371                            (symbol-package name)
    53535372                            *package*))
    5354              classfile
    53555373             compiled-definition
    53565374             (warnings-p t)
    53575375             (failure-p t))
    53585376        (with-compilation-unit
    5359           (setf classfile (compile-defun name expr env))
    5360           (setf compiled-definition (sys:load-compiled-function classfile))
    5361           (when (and name (functionp compiled-definition))
    5362             (sys::%set-lambda-name compiled-definition name)
    5363             (sys:set-call-count compiled-definition (sys:call-count definition))
    5364             (sys::%set-arglist compiled-definition (sys::arglist definition))
    5365             (if (macro-function name)
    5366                 (setf (fdefinition name) (sys::make-macro name compiled-definition))
    5367                 (setf (fdefinition name) compiled-definition)))
    5368           (cond
    5369            ((zerop (+ jvm::*errors* jvm::*warnings* jvm::*style-warnings*))
    5370             (setf warnings-p nil failure-p nil))
    5371            ((zerop (+ jvm::*errors* jvm::*warnings*))
    5372             (setf failure-p nil)))
    5373           (when *compile-print*
    5374             (if name
    5375                 (%format t "~A Compiled ~S~%" prefix name)
    5376                 (%format t "~A Compiled top-level form~%" prefix))))
     5377          (let ((filespec (compile-defun name expr env)))
     5378            (setf compiled-definition (sys:load-compiled-function filespec))
     5379            (when (and name (functionp compiled-definition))
     5380              (sys::%set-lambda-name compiled-definition name)
     5381              (sys:set-call-count compiled-definition (sys:call-count definition))
     5382              (sys::%set-arglist compiled-definition (sys::arglist definition))
     5383              (if (macro-function name)
     5384                  (setf (fdefinition name) (sys::make-macro name compiled-definition))
     5385                  (setf (fdefinition name) compiled-definition)))
     5386            (cond
     5387             ((zerop (+ jvm::*errors* jvm::*warnings* jvm::*style-warnings*))
     5388              (setf warnings-p nil failure-p nil))
     5389             ((zerop (+ jvm::*errors* jvm::*warnings*))
     5390              (setf failure-p nil)))
     5391            (when *compile-print*
     5392              (if name
     5393                  (%format t "~A Compiled ~S~%" prefix name)
     5394                  (%format t "~A Compiled top-level form~%" prefix)))))
    53775395        (values (or name compiled-definition) warnings-p failure-p)))))
    53785396
Note: See TracChangeset for help on using the changeset viewer.