Ignore:
Timestamp:
01/24/05 18:58:57 (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

    r8396 r8398  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.368 2005-01-24 15:04:42 piso Exp $
     4;;; $Id: jvm.lisp,v 1.369 2005-01-24 18:58:57 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    7676  class
    7777  superclass
     78  lambda-list ; as advertised
    7879  methods)
    7980
     
    18281829  handlers)
    18291830
    1830 (defun make-constructor (super name args)
     1831(defun make-constructor (super args)
    18311832  (let* ((*compiler-debug* nil) ; We don't normally need to see debugging output for constructors.
    18321833         (constructor (make-method :name "<init>"
     
    18561857                  (emit 'aload_0)
    18571858                  (emit-invokespecial-init super nil))
    1858                  (t (emit 'aload_0) ;; this
    1859                     (let* ((*print-level* nil)
    1860                            (*print-length* nil)
    1861                            (s (%format nil "~S" args)))
    1862                       (emit 'ldc (pool-string s))
    1863                       (emit-invokestatic +lisp-class+ "readObjectFromString"
    1864                                          (list +java-string+) +lisp-object+))
    1865                     (emit-invokespecial-init super (list +lisp-object+)))))
    1866           (t (emit 'aload_0)
    1867              (emit-invokespecial-init super nil)))
     1859                 (t
     1860                  (emit 'aload_0) ;; this
     1861                  (let* ((*print-level* nil)
     1862                         (*print-length* nil)
     1863                         (s (%format nil "~S" args)))
     1864                    (emit 'ldc (pool-string s))
     1865                    (emit-invokestatic +lisp-class+ "readObjectFromString"
     1866                                       (list +java-string+) +lisp-object+))
     1867                  (emit-invokespecial-init super (list +lisp-object+)))))
     1868          (t
     1869           (emit 'aload_0)
     1870           (emit-invokespecial-init super nil)))
    18681871    (setf *code* (append *static-code* *code*))
    18691872    (emit 'return)
     
    37763779                 (when (and (consp arg)
    37773780                            (not (constantp (second arg))))
    3778                    (error "P2-LOCAL-FUNCTION: can't handle optional argument with non-constant initform."))))))))
    3779   (let* ((name (compiland-name compiland))
    3780          form
    3781          function
    3782          pathname
    3783          class-file)
    3784     (setf form (compiland-lambda-expression compiland))
    3785     (setf pathname (if *compile-file-truename*
    3786                         (sys::next-classfile-name)
    3787                         (prog1
    3788                           (%format nil "local-~D.class" *child-count*)
    3789                           (incf *child-count*))))
    3790 
    3791     (setf class-file (make-class-file :pathname pathname))
    3792     (setf (compiland-class-file compiland) class-file)
    3793 
    3794     (let ((*current-compiland* compiland)
    3795           (*speed* *speed*)
    3796           (*safety* *safety*)
    3797           (*debug* *debug*))
    3798       (p2-compiland compiland))
    3799     (cond (*compile-file-truename*
    3800            ;; Verify that the class file is loadable.
    3801            (let ((*default-pathname-defaults* pathname))
    3802              (unless (ignore-errors (sys:load-compiled-function pathname))
    3803                (error "P2-LOCAL-FUNCTION: unable to load ~S." pathname))))
    3804           (t (setf function (sys:load-compiled-function pathname))))
    3805     (cond (local-function
    3806            (setf (local-function-class-file local-function) class-file)
    3807            (let ((g (if *compile-file-truename*
    3808                         (declare-local-function local-function)
    3809                         (declare-object function))))
    3810              (emit 'getstatic
    3811                    *this-class*
    3812                    g
    3813                    +lisp-object+)
    3814              (emit 'var-set (local-function-variable local-function))))
    3815           (t
    3816            (push (make-local-function :name name
    3817                                       :function function
    3818                                       :class-file class-file)
    3819                  *local-functions*)))))
     3781                   (error "P2-LOCAL-FUNCTION: can't handle optional argument with non-constant initform.")))))))
     3782    (let* ((name (compiland-name compiland))
     3783           form
     3784           function
     3785           pathname
     3786           class-file)
     3787      (setf form (compiland-lambda-expression compiland))
     3788      (setf pathname (if *compile-file-truename*
     3789                         (sys::next-classfile-name)
     3790                         (prog1
     3791                           (%format nil "local-~D.class" *child-count*)
     3792                           (incf *child-count*))))
     3793
     3794      (setf class-file (make-class-file :pathname pathname
     3795                                        :lambda-list lambda-list))
     3796      (setf (compiland-class-file compiland) class-file)
     3797
     3798      (let ((*current-compiland* compiland)
     3799            (*speed* *speed*)
     3800            (*safety* *safety*)
     3801            (*debug* *debug*))
     3802        (p2-compiland compiland))
     3803      (cond (*compile-file-truename*
     3804             ;; Verify that the class file is loadable.
     3805             (let ((*default-pathname-defaults* pathname))
     3806               (unless (ignore-errors (sys:load-compiled-function pathname))
     3807                 (error "P2-LOCAL-FUNCTION: unable to load ~S." pathname))))
     3808            (t (setf function (sys:load-compiled-function pathname))))
     3809      (cond (local-function
     3810             (setf (local-function-class-file local-function) class-file)
     3811             (let ((g (if *compile-file-truename*
     3812                          (declare-local-function local-function)
     3813                          (declare-object function))))
     3814               (emit 'getstatic
     3815                     *this-class*
     3816                     g
     3817                     +lisp-object+)
     3818               (emit 'var-set (local-function-variable local-function))))
     3819            (t
     3820             (push (make-local-function :name name
     3821                                        :function function
     3822                                        :class-file class-file)
     3823                   *local-functions*))))))
    38203824
    38213825(defun p2-flet (form &key (target *val*) representation)
     
    38483852      (compile-form (car forms) :target (if (cdr forms) nil target)))))
    38493853
    3850 (defun contains-symbol (symbol form)
    3851   (cond ((node-p form)
    3852          (contains-symbol symbol (node-form form)))
    3853         ((atom form)
    3854          (eq form symbol))
    3855         (t
    3856          (or (contains-symbol symbol (car form))
    3857              (contains-symbol symbol (cdr form))))))
    3858 
    3859 (defun contains-go (form)
    3860   (cond ((node-p form)
    3861          (contains-go (node-form form)))
    3862         ((atom form)
    3863          nil)
    3864         (t
    3865          (case (car form)
    3866            (QUOTE
    3867             nil)
    3868            (GO
    3869             t)
    3870            (t
    3871             (dolist (subform form)
    3872               (when (contains-go subform)
    3873                 (return t))))))))
    3874 
    38753854(defun p2-lambda (compiland target)
    38763855  (let* ((lambda-list (cadr (compiland-lambda-expression compiland))))
     
    38843863                 (when (and (consp arg)
    38853864                            (not (constantp (second arg))))
    3886                    (error "P2-LAMBDA: can't handle optional argument with non-constant initform."))))))))
    3887   (aver (null (compiland-class-file compiland)))
    3888   (setf (compiland-class-file compiland)
    3889         (make-class-file :pathname (if *compile-file-truename*
    3890                                        (sys::next-classfile-name)
    3891                                        (prog1
    3892                                          (%format nil "local-~D.class" *child-count*)
    3893                                          (incf *child-count*)))))
     3865                   (error "P2-LAMBDA: can't handle optional argument with non-constant initform.")))))))
     3866    (aver (null (compiland-class-file compiland)))
     3867    (setf (compiland-class-file compiland)
     3868          (make-class-file :pathname (if *compile-file-truename*
     3869                                         (sys::next-classfile-name)
     3870                                         (prog1
     3871                                           (%format nil "local-~D.class" *child-count*)
     3872                                           (incf *child-count*)))
     3873                           :lambda-list lambda-list)))
    38943874  (let ((*current-compiland* compiland)
    38953875        (*speed* *speed*)
     
    48364816
    48374817(defun write-class-file (args execute-method class-file)
    4838   (let* ((super (cond (*child-p*
    4839                        (if *closure-variables*
    4840                            +lisp-ctf-class+
    4841                            (if *hairy-arglist-p*
    4842                                +lisp-compiled-function-class+
    4843                                +lisp-primitive-class+)))
    4844                       (*hairy-arglist-p*
    4845                        +lisp-compiled-function-class+)
    4846                       (t
    4847                        +lisp-primitive-class+)))
     4818  (let* ((super (class-file-superclass class-file))
    48484819         (this-index (pool-class *this-class*))
    48494820         (super-index (pool-class super))
    4850          (constructor (make-constructor super
    4851                                         (compiland-name *current-compiland*)
    4852                                         args)))
     4821         (constructor (make-constructor super args)))
    48534822    (pool-name "Code") ; Must be in pool!
    48544823
     
    48834852(defun p1-compiland (compiland)
    48844853  (let ((form (compiland-lambda-expression compiland)))
    4885 ;;     (dformat t "p1-compiland form = ~S~%" form)
    48864854    (aver (eq (car form) 'LAMBDA))
    48874855    (process-optimization-declarations (cddr form))
     
    52285196    (setf (method-max-locals execute-method) *registers-allocated*)
    52295197    (setf (method-handlers execute-method) (nreverse *handlers*))
     5198
     5199    (setf (class-file-superclass (compiland-class-file compiland))
     5200          (cond (*child-p*
     5201                 (if *closure-variables*
     5202                     +lisp-ctf-class+
     5203                     (if *hairy-arglist-p*
     5204                         +lisp-compiled-function-class+
     5205                         +lisp-primitive-class+)))
     5206                (*hairy-arglist-p*
     5207                 +lisp-compiled-function-class+)
     5208                (t
     5209                 +lisp-primitive-class+)))
     5210
    52305211    (write-class-file args execute-method (compiland-class-file compiland))
    52315212    (dformat t "leaving p2-compiland ~S~%" (compiland-name compiland))))
     
    52705251      (compile-1 (make-compiland :name name
    52715252                                 :lambda-expression (precompile-form form t)
    5272                                  :class-file (make-class-file :pathname filespec)
     5253                                 :class-file (make-class-file :pathname filespec
     5254                                                              :lambda-list (cadr form))
    52735255                                 :parent *current-compiland*))))
    52745256
Note: See TracChangeset for help on using the changeset viewer.