Ignore:
Timestamp:
01/22/05 12:26:21 (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

    r8378 r8384  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.361 2005-01-21 03:27:43 piso Exp $
     4;;; $Id: jvm.lisp,v 1.362 2005-01-22 12:26:21 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    8080  parent
    8181  (children 0) ; Number of local functions defined with FLET or LABELS.
    82   contains-lambda
    8382  argument-register
    8483  closure-register
     
    874873(defconstant +lisp-go-class+ "org/armedbear/lisp/Go")
    875874(defconstant +lisp-ctf-class+ "org/armedbear/lisp/ClosureTemplateFunction")
     875(defconstant +lisp-compiled-function-class+ "org/armedbear/lisp/CompiledFunction")
     876(defconstant +lisp-primitive-class+ "org/armedbear/lisp/Primitive")
    876877
    877878(defsubst emit-push-nil ()
     
    39573958    (cond (*compile-file-truename*
    39583959           ;; Verify that the class file is loadable.
    3959            (unless (ignore-errors (sys:load-compiled-function classfile))
    3960              (error "P2-LOCAL-FUNCTION: unable to load ~S." classfile)))
    3961           (t
    3962           (setf function (sys:load-compiled-function classfile))))
     3960           (let ((*default-pathname-defaults* classfile))
     3961             (unless (ignore-errors (sys:load-compiled-function classfile))
     3962               (error "P2-LOCAL-FUNCTION: unable to load ~S." classfile))))
     3963          (t (setf function (sys:load-compiled-function classfile))))
    39633964    (cond (local-function
    39643965           (setf (local-function-classfile local-function) classfile)
     
    39713972                   +lisp-object+)
    39723973             (emit 'var-set (local-function-variable local-function))))
    3973           (t
    3974            (push (make-local-function :name name
    3975                                       :function function
    3976                                       :classfile classfile)
    3977                  *local-functions*)))))
     3974          (t (push (make-local-function :name name
     3975                                        :function function
     3976                                        :classfile classfile)
     3977                   *local-functions*)))))
    39783978
    39793979(defun p2-flet (form &key (target *val*) representation)
     
    50215021        (return-from analyze-args
    50225022                     (if *closure-variables*
    5023                          #.(%format nil "([~A[~A)~A" +lisp-object+ +lisp-object+ +lisp-object+)
    5024                          #.(%format nil "([~A)~A" +lisp-object+ +lisp-object+))))
     5023                         (make-descriptor (list +lisp-object-array+ +lisp-object-array+)
     5024                                          +lisp-object+)
     5025                         (make-descriptor (list +lisp-object-array+)
     5026                                          +lisp-object+))))
    50255027      (cond
    50265028       (*closure-variables*
     
    50305032                                                    (make-list arg-count :initial-element +lisp-object+))
    50315033                                             +lisp-object+))
    5032                            (t
    5033 ;;                             (error "analyze-args unsupported case")
    5034                             (setf *using-arg-array* t)
    5035                             (setf *arity* arg-count)
    5036                             (make-descriptor (list +lisp-object-array+ +lisp-object-array+)
    5037                                              +lisp-object+)
    5038                             ))))
     5034                           (t (setf *using-arg-array* t)
     5035                              (setf *arity* arg-count)
     5036                              (make-descriptor (list +lisp-object-array+ +lisp-object-array+)
     5037                                               +lisp-object+)))))
    50395038       (t
    50405039        (return-from analyze-args
     
    50425041                            (make-descriptor (make-list arg-count :initial-element +lisp-object+)
    50435042                                             +lisp-object+))
    5044                            (t
    5045                             (setf *using-arg-array* t)
    5046                             (setf *arity* arg-count)
    5047                             (make-descriptor (list +lisp-object-array+) +lisp-object+)))
    5048                      ))))
    5049 
    5050 
     5043                           (t (setf *using-arg-array* t)
     5044                              (setf *arity* arg-count)
     5045                              (make-descriptor (list +lisp-object-array+)
     5046                                               +lisp-object+)))))))
    50515047    (when (or (memq '&KEY args)
    50525048              (memq '&OPTIONAL args)
     
    50565052      (return-from analyze-args
    50575053                   (make-descriptor (list +lisp-object-array+) +lisp-object+)))
    5058 
    50595054    (cond ((<= arg-count 4)
    50605055           (make-descriptor (make-list (length args) :initial-element +lisp-object+)
     
    50635058           (setf *using-arg-array* t)
    50645059           (setf *arity* arg-count)
    5065            (make-descriptor (list +lisp-object-array+) +lisp-object+)))
    5066 
    5067     ))
     5060           (make-descriptor (list +lisp-object-array+) +lisp-object+)))))
    50685061
    50695062(defun write-class-file (args body execute-method classfile)
    50705063  (dformat t "write-class-file ~S~%" classfile)
    5071   (let* ((super
    5072           (cond (*child-p*
    5073                  (dformat t "write-class-file *child-p* case~%")
    5074                  (dformat t "*closure-variables* = ~S~%" (mapcar #'variable-name *closure-variables*))
    5075                  (dformat t "args = ~S~%" args)
    5076                  (dformat t "*hairy-arglist-p* = ~S~%" *hairy-arglist-p*)
    5077                  (if *closure-variables*
    5078                      "org/armedbear/lisp/ClosureTemplateFunction"
    5079                      (if *hairy-arglist-p*
    5080                          "org/armedbear/lisp/CompiledFunction"
    5081                          "org/armedbear/lisp/Primitive")))
    5082                 (*hairy-arglist-p*
    5083                  "org/armedbear/lisp/CompiledFunction")
    5084                 (t
    5085                  "org/armedbear/lisp/Primitive")))
     5064  (let* ((super (cond (*child-p*
     5065                       (if *closure-variables*
     5066                           "org/armedbear/lisp/ClosureTemplateFunction"
     5067                           (if *hairy-arglist-p*
     5068                               +lisp-compiled-function-class+
     5069                               +lisp-primitive-class+)))
     5070                      (*hairy-arglist-p* +lisp-compiled-function-class+)
     5071                      (t +lisp-primitive-class+)))
    50865072         (this-index (pool-class *this-class*))
    50875073         (super-index (pool-class super))
     
    51345120
    51355121
     5122      #+nil
     5123      (unless (or (memq '&KEY lambda-list) (memq '&REST lambda-list))
     5124        (let ((optionals (memq '&OPTIONAL lambda-list)))
     5125          (dformat t "optionals = ~S~%" optionals)
     5126          (when (= (length optionals) 2)
     5127            (let* ((optional-arg (second optionals))
     5128                   (name (if (consp optional-arg) (car optional-arg) optional-arg))
     5129                   (initform (if (consp optional-arg) (cadr optional-arg) nil))
     5130                   (wrapper-args (subseq lambda-list 0 (position '&OPTIONAL lambda-list)))
     5131                   (converted-args (append wrapper-args (list name))))
     5132              (dformat t "optional-arg = ~S~%" optional-arg)
     5133              (dformat t "wrapper-args = ~S~%" wrapper-args)
     5134              (dformat t "converted-args = ~S~%" converted-args)
     5135              (let ((wrapper-form
     5136                     `(lambda ,wrapper-args
     5137                        (let ((,name ,initform))
     5138                          (,(compiland-name compiland) ,@converted-args)))))
     5139                (dformat t "wrapper-form = ~S~%" wrapper-form)
     5140                )
     5141              ))))
     5142
     5143
    51365144      (let* ((closure (sys::make-closure `(lambda ,lambda-list nil) nil))
    51375145             (syms (sys::varlist closure))
     
    51515159                   (mapcar #'variable-name *visible-variables*))
    51525160          (setf (compiland-p1-result compiland)
    5153                 ;;               (list* 'LAMBDA lambda-list (mapcar #'p1 (cddr form)))
    5154                 (list* 'LAMBDA lambda-list (mapcar #'p1 body))
    5155                 ;;             (p1 form)
    5156                 ))))))
     5161                (list* 'LAMBDA lambda-list (mapcar #'p1 body))))))))
    51575162
    51585163(defun p2-compiland (compiland)
     
    52135218    (dformat t "pass2 *using-arg-array* = ~S~%" *using-arg-array*)
    52145219    (dformat t "pass2 *child-p* = ~S~%" *child-p*)
     5220    (dformat t "pass2 *closure-variables* = ~S~%"
     5221             (mapcar #'variable-name *closure-variables*))
    52155222    (setf (method-name-index execute-method)
    52165223          (pool-name (method-name execute-method)))
     
    54565463  (dformat t "compile-1 ~S~%" (compiland-name compiland))
    54575464  (let ((*all-variables* ())
     5465        (*closure-variables* ())
    54585466        (*current-compiland* compiland)
    54595467        (*speed* *speed*)
Note: See TracChangeset for help on using the changeset viewer.