Changeset 8396


Ignore:
Timestamp:
01/24/05 15:04: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

    r8390 r8396  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.367 2005-01-24 02:39:14 piso Exp $
     4;;; $Id: jvm.lisp,v 1.368 2005-01-24 15:04:42 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    879879(defconstant +lisp-go-class+ "org/armedbear/lisp/Go")
    880880(defconstant +lisp-ctf-class+ "org/armedbear/lisp/ClosureTemplateFunction")
     881(defconstant +lisp-compiled-closure-class+ "org/armedbear/lisp/CompiledClosure")
    881882(defconstant +lisp-compiled-function-class+ "org/armedbear/lisp/CompiledFunction")
    882883(defconstant +lisp-primitive-class+ "org/armedbear/lisp/Primitive")
     
    37653766
    37663767(defun p2-local-function (compiland local-function)
    3767   (let* ((name (compiland-name compiland))
    3768          (lambda-list (cadr (compiland-lambda-expression compiland)))
    3769          form
    3770          function
    3771          pathname
    3772          class-file)
     3768  (let ((lambda-list (cadr (compiland-lambda-expression compiland))))
    37733769    (when (or (memq '&optional lambda-list)
    37743770              (memq '&key lambda-list))
     
    37803776                 (when (and (consp arg)
    37813777                            (not (constantp (second arg))))
    3782                    (error "P2-LOCAL-FUNCTION: can't handle optional argument with non-constant initform.")))))))
     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)
    37833784    (setf form (compiland-lambda-expression compiland))
    37843785    (setf pathname (if *compile-file-truename*
    37853786                        (sys::next-classfile-name)
    37863787                        (prog1
    3787                          (%format nil "local-~D.class" *child-count*)
    3788                          (incf *child-count*))))
     3788                          (%format nil "local-~D.class" *child-count*)
     3789                          (incf *child-count*))))
    37893790
    37903791    (setf class-file (make-class-file :pathname pathname))
     
    38833884                 (when (and (consp arg)
    38843885                            (not (constantp (second arg))))
    3885                    (error "P2-LAMBDA: can't handle optional argument with non-constant initform.")))))))
    3886     (cond (*compile-file-truename*
    3887 
    3888            (aver (null (compiland-class-file compiland)))
    3889            (setf (compiland-class-file compiland)
    3890                  (make-class-file :pathname (sys::next-classfile-name)))
    3891 
    3892            (let ((*current-compiland* compiland)
    3893                  (*speed* *speed*)
    3894                  (*safety* *safety*)
    3895                  (*debug* *debug*)
    3896                  compiled-function)
    3897              (p2-compiland compiland))
    3898 
    3899            (let* ((local-function
    3900                    (make-local-function :class-file (compiland-class-file compiland)))
    3901                   (g (declare-local-function local-function)))
    3902              (emit 'getstatic *this-class* g +lisp-object+)))
    3903           (t
    3904            (aver (null (compiland-class-file compiland)))
    3905            (setf (compiland-class-file compiland)
    3906                  (make-class-file :pathname
    3907                                   (prog1
    3908                                    (%format nil "local-~D.class" *child-count*)
    3909                                    (incf *child-count*))))
    3910            (let ((*current-compiland* compiland)
    3911                  (*speed* *speed*)
    3912                  (*safety* *safety*)
    3913                  (*debug* *debug*)
    3914                  compiled-function)
    3915              (p2-compiland compiland)
    3916              (setf compiled-function
    3917                    (sys:load-compiled-function
    3918                     (class-file-pathname (compiland-class-file compiland))))
    3919              (emit 'getstatic *this-class*
    3920                    (declare-object compiled-function) +lisp-object+))))
    3921     (cond
    3922      ((null *closure-variables*)) ; Nothing to do.
    3923      ((compiland-closure-register *current-compiland*)
    3924       (emit 'aload (compiland-closure-register *current-compiland*))
    3925       (emit-invokestatic +lisp-class+ "makeCompiledClosure"
    3926                          (list +lisp-object+ +lisp-object-array+) +lisp-object+)
    3927       (emit 'checkcast "org/armedbear/lisp/CompiledClosure")) ; Stack: compiled-closure
    3928      (t
    3929       ;; Shouldn't happen.
    3930       (aver (progn 'unexpected nil))
    3931       (emit-push-constant-int 0)
    3932       (emit 'anewarray +lisp-object-class+)))
    3933     (emit-move-from-stack target)))
     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*)))))
     3894  (let ((*current-compiland* compiland)
     3895        (*speed* *speed*)
     3896        (*safety* *safety*)
     3897        (*debug* *debug*))
     3898    (p2-compiland compiland))
     3899  (let ((class-file (compiland-class-file compiland)))
     3900    (emit 'getstatic *this-class*
     3901          (if *compile-file-truename*
     3902              (declare-local-function (make-local-function :class-file class-file))
     3903              (declare-object (sys:load-compiled-function (class-file-pathname class-file))))
     3904          +lisp-object+))
     3905  (cond ((null *closure-variables*)) ; Nothing to do.
     3906        ((compiland-closure-register *current-compiland*)
     3907         (emit 'aload (compiland-closure-register *current-compiland*))
     3908         (emit-invokestatic +lisp-class+ "makeCompiledClosure"
     3909                            (list +lisp-object+ +lisp-object-array+)
     3910                            +lisp-object+)
     3911         (emit 'checkcast +lisp-compiled-closure-class+)) ; Stack: compiled-closure
     3912        (t
     3913         (aver nil))) ;; Shouldn't happen.
     3914  (emit-move-from-stack target))
    39343915
    39353916(defun p2-function (form &key (target *val*) representation)
     
    49614942        (setf (char name i) #\_)))
    49624943    (concatenate 'string "org/armedbear/lisp/" name)))
    4963  
     4944
    49644945(defun p2-compiland (compiland)
    49654946  (dformat t "p2-compiland ~S~%" (compiland-name compiland))
Note: See TracChangeset for help on using the changeset viewer.