Changeset 8376


Ignore:
Timestamp:
01/20/05 17:09:07 (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

    r8374 r8376  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.358 2005-01-19 15:59:04 piso Exp $
     4;;; $Id: jvm.lisp,v 1.359 2005-01-20 17:09:07 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    856856(defconstant +lisp-object-class+ "org/armedbear/lisp/LispObject")
    857857(defconstant +lisp-object+ "Lorg/armedbear/lisp/LispObject;")
     858(defconstant +lisp-object-array+ "[Lorg/armedbear/lisp/LispObject;")
    858859(defconstant +lisp-string+ "Lorg/armedbear/lisp/SimpleString;")
    859860(defconstant +lisp-symbol-class+ "org/armedbear/lisp/Symbol")
     
    890891      (princ type s))
    891892    (princ #\) s)
    892     (princ (if return-type return-type "V") s)))
     893    (princ (or return-type "V") s)))
    893894
    894895(defun descriptor (designator)
     
    945946      (aver (fixnump *arity*))
    946947      (aver (not (minusp *arity*)))
    947       (emit 'aload 1)
     948;;       (emit 'aload 1)
     949      (aver (not (null (compiland-argument-register *current-compiland*))))
     950      (emit 'aload (compiland-argument-register *current-compiland*))
    948951      (emit 'arraylength)
    949952      (emit 'bipush *arity*)
     
    18121815  descriptor-index)
    18131816
    1814 (defstruct method
     1817(defstruct (java-method (:conc-name method-) (:constructor make-method))
    18151818  access-flags
    18161819  name
     
    40244027(defun p2-local-function (compiland local-function)
    40254028  (let* ((name (compiland-name compiland))
    4026          (arglist (cadr (compiland-lambda-expression compiland)))
     4029         (lambda-list (cadr (compiland-lambda-expression compiland)))
    40274030         form
    40284031         function
    40294032         classfile)
    4030     (when (or (memq '&optional arglist)
    4031               (memq '&key arglist))
     4033    (when (or (memq '&optional lambda-list)
     4034              (memq '&key lambda-list))
    40324035      (let ((state nil))
    4033         (dolist (arg arglist)
     4036        (dolist (arg lambda-list)
    40344037          (cond ((memq arg lambda-list-keywords)
    40354038                 (setf state arg))
     
    41554158                   g
    41564159                   +lisp-object+))
    4157 
    4158 ;;              )
    41594160           )
    41604161          (t
     
    51515152(defun analyze-args (args)
    51525153  (aver (not (memq '&AUX args)))
    5153 
    5154   (when *child-p*
     5154  (let ((arg-count (length args)))
     5155
     5156    (when *child-p*
     5157      (when (or (memq '&KEY args)
     5158                (memq '&OPTIONAL args)
     5159                (memq '&REST args))
     5160        (setf *using-arg-array* t)
     5161        (setf *hairy-arglist-p* t)
     5162        (return-from analyze-args
     5163                     (if *closure-variables*
     5164                         #.(%format nil "([~A[~A)~A" +lisp-object+ +lisp-object+ +lisp-object+)
     5165                         #.(%format nil "([~A)~A" +lisp-object+ +lisp-object+))))
     5166      (cond
     5167       (*closure-variables*
     5168        (return-from analyze-args
     5169                     (cond ((<= arg-count 4)
     5170                            (make-descriptor (list* +lisp-object-array+
     5171                                                    (make-list arg-count :initial-element +lisp-object+))
     5172                                             +lisp-object+))
     5173                           (t
     5174;;                             (error "analyze-args unsupported case")
     5175                            (setf *using-arg-array* t)
     5176                            (setf *arity* arg-count)
     5177                            (make-descriptor (list +lisp-object-array+ +lisp-object-array+)
     5178                                             +lisp-object+)
     5179                            ))))
     5180       (t
     5181        (return-from analyze-args
     5182                     (cond ((<= arg-count 4)
     5183                            (make-descriptor (make-list arg-count :initial-element +lisp-object+)
     5184                                             +lisp-object+))
     5185                           (t
     5186                            (setf *using-arg-array* t)
     5187                            (setf *arity* arg-count)
     5188                            (make-descriptor (list +lisp-object-array+) +lisp-object+)))
     5189                     ))))
     5190
     5191
    51555192    (when (or (memq '&KEY args)
    51565193              (memq '&OPTIONAL args)
     
    51595196      (setf *hairy-arglist-p* t)
    51605197      (return-from analyze-args
    5161                    (if *closure-variables*
    5162                        #.(%format nil "([~A[~A)~A" +lisp-object+ +lisp-object+ +lisp-object+)
    5163                        #.(%format nil "([~A)~A" +lisp-object+ +lisp-object+))))
    5164     (cond
    5165      (*closure-variables*
    5166       (return-from analyze-args
    5167                    (case (length args)
    5168                      (0 #.(%format nil "([~A)~A" +lisp-object+ +lisp-object+))
    5169                      (1 #.(%format nil "([~A~A)~A" +lisp-object+ +lisp-object+ +lisp-object+))
    5170                      (2 #.(%format nil "([~A~A~A)~A" +lisp-object+ +lisp-object+ +lisp-object+ +lisp-object+))
    5171                      (3 #.(%format nil "([~A~A~A~A)~A" +lisp-object+ +lisp-object+ +lisp-object+ +lisp-object+ +lisp-object+))
    5172                      (4 #.(%format nil "([~A~A~A~A~A)~A" +lisp-object+ +lisp-object+ +lisp-object+ +lisp-object+ +lisp-object+ +lisp-object+))
    5173                      (t
    5174                       (error "analyze-args unsupported case")))))
    5175      (t
    5176       (return-from analyze-args
    5177                    (case (length args)
    5178                      (0 #.(%format nil "()~A" +lisp-object+))
    5179                      (1 #.(%format nil "(~A)~A" +lisp-object+ +lisp-object+))
    5180                      (2 #.(%format nil "(~A~A)~A" +lisp-object+ +lisp-object+ +lisp-object+))
    5181                      (3 #.(%format nil "(~A~A~A)~A" +lisp-object+ +lisp-object+ +lisp-object+ +lisp-object+))
    5182                      (4 #.(%format nil "(~A~A~A~A)~A" +lisp-object+ +lisp-object+ +lisp-object+ +lisp-object+ +lisp-object+))
    5183                      (t (setf *using-arg-array* t)
    5184                         (setf *arity* (length args))
    5185                         #.(%format nil "([~A)~A" +lisp-object+ +lisp-object+)))))))
    5186 
    5187 
    5188   (when (or (memq '&KEY args)
    5189             (memq '&OPTIONAL args)
    5190             (memq '&REST args))
    5191     (setf *using-arg-array* t)
    5192     (setf *hairy-arglist-p* t)
    5193     (return-from analyze-args
    5194                  (if *child-p*
    5195                      #.(%format nil "([~A[[~A)~A" +lisp-object+ +lisp-object+ +lisp-object+)
    5196                      #.(%format nil "([~A)~A" +lisp-object+ +lisp-object+))))
    5197   (case (length args)
    5198     (0 #.(%format nil "()~A" +lisp-object+))
    5199     (1 #.(%format nil "(~A)~A" +lisp-object+ +lisp-object+))
    5200     (2 #.(%format nil "(~A~A)~A" +lisp-object+ +lisp-object+ +lisp-object+))
    5201     (3 #.(%format nil "(~A~A~A)~A" +lisp-object+ +lisp-object+ +lisp-object+ +lisp-object+))
    5202     (4 #.(%format nil "(~A~A~A~A)~A" +lisp-object+ +lisp-object+ +lisp-object+ +lisp-object+ +lisp-object+))
    5203     (t (setf *using-arg-array* t)
    5204        (setf *arity* (length args))
    5205        #.(%format nil "([~A)~A" +lisp-object+ +lisp-object+))))
     5198                   (make-descriptor (list +lisp-object-array+) +lisp-object+)))
     5199
     5200    (cond ((<= arg-count 4)
     5201           (make-descriptor (make-list (length args) :initial-element +lisp-object+)
     5202                            +lisp-object+))
     5203          (t
     5204           (setf *using-arg-array* t)
     5205           (setf *arity* arg-count)
     5206           (make-descriptor (list +lisp-object-array+) +lisp-object+)))
     5207
     5208    ))
    52065209
    52075210(defun write-class-file (args body execute-method classfile)
     
    56415644
    56425645(defun compile-defun (name form environment &optional (classfile "out.class"))
    5643   ;;   (dformat t "COMPILE-DEFUN ~S ~S~%" name classfile)
    5644   ;;   (dformat t "compile-defun form = ~S~%" form)
    56455646  (aver (eq (car form) 'LAMBDA))
    56465647  (unless (or (null environment) (sys::empty-environment-p environment))
     
    56545655                                 :lambda-expression precompiled-form
    56555656                                 :classfile classfile
    5656                                  :parent *current-compiland*))))
    5657         )
     5657                                 :parent *current-compiland*)))))
    56585658
    56595659(defun handle-warning (condition)
Note: See TracChangeset for help on using the changeset viewer.