Changeset 8402


Ignore:
Timestamp:
01/25/05 20:15:42 (16 years ago)
Author:
piso
Message:

Work in progress (tested).

File:
1 edited

Legend:

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

    r8401 r8402  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.371 2005-01-25 05:37:05 piso Exp $
     4;;; $Id: jvm.lisp,v 1.372 2005-01-25 20:15:42 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
     74(defvar *pool* nil)
     75(defvar *pool-count* 1)
     76(defvar *pool-entries* nil)
     77(defvar *fields* ())
     78(defvar *static-code* ())
     79
     80(defstruct (class-file (:constructor %make-class-file))
    7581  pathname ; pathname of output file
    7682  class
    7783  superclass
    7884  lambda-list ; as advertised
    79   methods)
     85  pool
     86  (pool-count 1)
     87  (pool-entries (make-hash-table :test #'equal))
     88  fields
     89  methods
     90  static-code)
     91
     92(defun class-name-from-filespec (filespec)
     93  (let* ((name (pathname-name filespec)))
     94    (dotimes (i (length name))
     95      (when (eql (char name i) #\-)
     96        (setf (char name i) #\_)))
     97    (concatenate 'string "org/armedbear/lisp/" name)))
     98
     99(defun make-class-file (&key pathname lambda-list)
     100  (aver (not (null pathname)))
     101  (let ((class-file (%make-class-file :pathname pathname
     102                                      :lambda-list lambda-list)))
     103    (setf (class-file-class class-file) (class-name-from-filespec pathname))
     104    class-file))
     105
     106(defmacro with-class-file (class-file &body body)
     107  (let ((var (gensym)))
     108    `(let* ((,var ,class-file)
     109            (*pool* (class-file-pool ,var))
     110            (*pool-count* (class-file-pool-count ,var))
     111            (*pool-entries* (class-file-pool-entries ,var))
     112            (*fields* (class-file-fields ,var))
     113            (*static-code* (class-file-static-code ,var)))
     114       (progn ,@body)
     115       (setf (class-file-pool ,var) *pool*
     116             (class-file-pool-count ,var) *pool-count*
     117             (class-file-pool-entries ,var) *pool-entries*
     118             (class-file-fields ,var) *fields*
     119             (class-file-static-code ,var) *static-code*
     120             ))))
    80121
    81122(defstruct compiland
     
    93134(defvar *current-compiland* nil)
    94135
    95 (defvar *pool* nil)
    96 (defvar *pool-count* 1)
    97 (defvar *pool-entries* nil)
    98 
    99136(defvar *this-class* nil)
    100137
    101138(defvar *code* ())
    102 (defvar *static-code* ())
    103 (defvar *fields* ())
    104139
    105140;; All tags visible at the current point of compilation, some of which may not
     
    18221857
    18231858(defun make-constructor (super args)
     1859;;   (%format t "make-constructor (length *static-code*) = ~S~%" (length *static-code*))
    18241860  (let* ((*compiler-debug* nil) ; We don't normally need to see debugging output for constructors.
    18251861         (constructor (make-method :name "<init>"
     
    18311867    (setf (method-descriptor-index constructor) (pool-name (method-descriptor constructor)))
    18321868    (setf (method-max-locals constructor) 1)
    1833     (cond (*hairy-arglist-p*
     1869    (cond (;;*hairy-arglist-p*
     1870           (equal super +lisp-compiled-function-class+)
     1871
    18341872           (emit 'aload_0) ;; this
    18351873           (emit 'aconst_null) ;; name
     
    18451883                                    (list +lisp-symbol+ +lisp-object+
    18461884                                          +lisp-object+ +lisp-environment+)))
    1847           (*child-p*
    1848            (cond ((null *closure-variables*)
    1849                   (emit 'aload_0)
    1850                   (emit-invokespecial-init super nil))
    1851                  (t
    1852                   (emit 'aload_0) ;; this
    1853                   (let* ((*print-level* nil)
    1854                          (*print-length* nil)
    1855                          (s (%format nil "~S" args)))
    1856                     (emit 'ldc (pool-string s))
    1857                     (emit-invokestatic +lisp-class+ "readObjectFromString"
    1858                                        (list +java-string+) +lisp-object+))
    1859                   (emit-invokespecial-init super (list +lisp-object+)))))
     1885          ((equal super +lisp-primitive-class+)
     1886           (emit 'aload_0)
     1887           (emit-invokespecial-init super nil))
     1888;;           (*child-p*
     1889;;            (cond ((null *closure-variables*)
     1890;;                   (emit 'aload_0)
     1891;;                   (emit-invokespecial-init super nil))
     1892;;                  (t
     1893;;                   (emit 'aload_0) ;; this
     1894;;                   (let* ((*print-level* nil)
     1895;;                          (*print-length* nil)
     1896;;                          (s (%format nil "~S" args)))
     1897;;                     (emit 'ldc (pool-string s))
     1898;;                     (emit-invokestatic +lisp-class+ "readObjectFromString"
     1899;;                                        (list +java-string+) +lisp-object+))
     1900;;                   (emit-invokespecial-init super (list +lisp-object+)))))
     1901;;           (t
     1902;;            (emit 'aload_0)
     1903;;            (emit-invokespecial-init super nil)))
     1904          ((equal super +lisp-ctf-class+)
     1905           (emit 'aload_0) ;; this
     1906           (let* ((*print-level* nil)
     1907                  (*print-length* nil)
     1908                  (s (%format nil "~S" args)))
     1909             (emit 'ldc (pool-string s))
     1910             (emit-invokestatic +lisp-class+ "readObjectFromString"
     1911                                (list +java-string+) +lisp-object+))
     1912           (emit-invokespecial-init super (list +lisp-object+)))
    18601913          (t
    1861            (emit 'aload_0)
    1862            (emit-invokespecial-init super nil)))
     1914           (aver nil)))
     1915
    18631916    (setf *code* (append *static-code* *code*))
    18641917    (emit 'return)
     
    19572010        (emit 'putstatic *this-class* g +lisp-symbol+)
    19582011        (setf *static-code* *code*)
     2012;;         (%format t "declare-symbol (length *static-code* = ~S~%" (length *static-code*))
    19592013        (setf (gethash symbol *declared-symbols*) g)))
    19602014    g))
     
    37453799      (setf class-file (make-class-file :pathname pathname
    37463800                                        :lambda-list lambda-list))
     3801
    37473802      (setf (compiland-class-file compiland) class-file)
    37483803
    3749       (let ((*current-compiland* compiland)
    3750             (*speed* *speed*)
    3751             (*safety* *safety*)
    3752             (*debug* *debug*))
    3753         (p2-compiland compiland))
     3804      (with-class-file class-file
     3805        (let ((*current-compiland* compiland)
     3806              (*speed* *speed*)
     3807              (*safety* *safety*)
     3808              (*debug* *debug*))
     3809          (p2-compiland compiland)
     3810          (write-class-file (compiland-class-file compiland))
     3811          ))
    37543812      (cond (*compile-file-truename*
    37553813             ;; Verify that the class file is loadable.
     
    38203878                                           (incf *child-count*)))
    38213879                           :lambda-list lambda-list)))
    3822   (let ((*current-compiland* compiland)
    3823         (*speed* *speed*)
    3824         (*safety* *safety*)
    3825         (*debug* *debug*))
    3826     (p2-compiland compiland))
     3880  (with-class-file (compiland-class-file compiland)
     3881    (let ((*current-compiland* compiland)
     3882          (*speed* *speed*)
     3883          (*safety* *safety*)
     3884          (*debug* *debug*))
     3885      (p2-compiland compiland)
     3886      (write-class-file (compiland-class-file compiland))
     3887      ))
    38273888  (let ((class-file (compiland-class-file compiland)))
    38283889    (emit 'getstatic *this-class*
     
    47514812(defun write-class-file (class-file)
    47524813  (let* ((super (class-file-superclass class-file))
    4753          (this-index (pool-class *this-class*))
     4814         (this-index (pool-class (class-file-class class-file)))
    47544815         (super-index (pool-class super))
    47554816         (constructor (make-constructor super
     
    48424903                (list* 'LAMBDA lambda-list (mapcar #'p1 body))))))))
    48434904
    4844 (defun class-name-from-filespec (filespec)
    4845   (let* ((name (pathname-name filespec)))
    4846     (dotimes (i (length name))
    4847       (when (eql (char name i) #\-)
    4848         (setf (char name i) #\_)))
    4849     (concatenate 'string "org/armedbear/lisp/" name)))
    4850 
    48514905(defun p2-compiland (compiland)
    48524906  (dformat t "p2-compiland ~S~%" (compiland-name compiland))
     
    48574911         (*declared-fixnums* (make-hash-table :test 'eql))
    48584912         (class-file (compiland-class-file compiland))
    4859          (*this-class* (class-name-from-filespec (class-file-pathname class-file)))
     4913;;          (*this-class* (class-name-from-filespec (class-file-pathname class-file)))
     4914         (*this-class* (class-file-class class-file))
    48604915         (args (cadr p1-result))
    48614916         (body (cddr p1-result))
     
    48704925                                      :descriptor descriptor))
    48714926         (*code* ())
    4872          (*static-code* ())
    4873          (*fields* ())
     4927;;          (*static-code* ())
     4928;;          (*fields* ())
    48744929         (*register* 0)
    48754930         (*registers-allocated* 0)
     
    48804935         (parameters ())
    48814936
    4882          (*pool* ())
    4883          (*pool-count* 1)
    4884          (*pool-entries* (make-hash-table :test #'equal))
     4937;;          (*pool* ())
     4938;;          (*pool-count* 1)
     4939;;          (*pool-entries* (make-hash-table :test #'equal))
    48854940         (*val* nil)
    48864941         (*thread* nil)
     
    51345189    (push execute-method (class-file-methods class-file))
    51355190
    5136     (write-class-file (compiland-class-file compiland))
     5191;;     (write-class-file (compiland-class-file compiland))
    51375192    (dformat t "leaving p2-compiland ~S~%" (compiland-name compiland))))
    51385193
     
    51645219
    51655220    ;; Pass 2.
    5166     (p2-compiland compiland)
     5221;;     (%format t "compile-1 (length *fields*) = ~S~%" (length *fields*))
     5222    (with-class-file (compiland-class-file compiland)
     5223      (p2-compiland compiland)
     5224      (write-class-file (compiland-class-file compiland))
     5225      )
     5226;;     (%format t "compile-1 (length *fields*) = ~S~%" (length *fields*))
     5227
    51675228    (dformat t "*all-variables* = ~S~%" (mapcar #'variable-name *all-variables*))
    51685229    (class-file-pathname (compiland-class-file compiland))))
     
    51745235  (aver (null *current-compiland*))
    51755236  (handler-bind ((warning #'handle-warning))
    5176       (compile-1 (make-compiland :name name
    5177                                  :lambda-expression (precompile-form form t)
    5178                                  :class-file (make-class-file :pathname filespec
    5179                                                               :lambda-list (cadr form))
    5180                                  :parent *current-compiland*))))
     5237    (compile-1 (make-compiland :name name
     5238                               :lambda-expression (precompile-form form t)
     5239                               :class-file (make-class-file :pathname filespec
     5240                                                            :lambda-list (cadr form))
     5241                               :parent *current-compiland*))))
    51815242
    51825243(defun handle-warning (condition)
Note: See TracChangeset for help on using the changeset viewer.