Changeset 9152


Ignore:
Timestamp:
05/12/05 16:00:25 (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

    r9151 r9152  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.456 2005-05-12 09:21:16 piso Exp $
     4;;; $Id: jvm.lisp,v 1.457 2005-05-12 16:00:25 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    254254;; True for local functions defined with FLET or LABELS.
    255255(defvar *child-p* nil)
    256 
    257 (defvar *child-count* 0)
    258256
    259257(defun find-visible-variable (name)
     
    41834181    (emit-move-from-stack target)))
    41844182
    4185 (defun p2-local-function (compiland local-function)
     4183(defun p2-flet-process-compiland (compiland)
    41864184  (let ((lambda-list (cadr (compiland-lambda-expression compiland))))
    41874185    (when (or (memq '&optional lambda-list)
     
    41944192                 (when (and (consp arg)
    41954193                            (not (constantp (second arg))))
    4196                    (compiler-unsupported "P2-LOCAL-FUNCTION: can't handle optional argument with non-constant initform.")))))))
    4197     (let* ((name (compiland-name compiland))
    4198            function
    4199            pathname
    4200            class-file)
    4201       (setf pathname (if *compile-file-truename*
    4202                          (sys::next-classfile-name)
    4203                          (prog1
    4204                            (sys::%format nil "local-~D.class" *child-count*)
    4205                            (incf *child-count*))))
    4206 
    4207       (setf class-file (make-class-file :pathname pathname
    4208                                         :lambda-list lambda-list))
    4209 
    4210       (setf (compiland-class-file compiland) class-file)
    4211 
    4212       (with-class-file class-file
    4213         (let ((*current-compiland* compiland)
    4214               (*speed* *speed*)
    4215               (*safety* *safety*)
    4216               (*debug* *debug*))
    4217           (p2-compiland compiland)
    4218           (write-class-file (compiland-class-file compiland))
    4219           ))
    4220       (cond (*compile-file-truename*
     4194                   (compiler-unsupported "P2-FLET-PROCESS-COMPILAND: can't handle optional argument with non-constant initform.")))))))
     4195    (cond (*compile-file-truename*
     4196           (let* ((pathname (sys::next-classfile-name))
     4197                  (class-file (make-class-file :pathname pathname
     4198                                               :lambda-list lambda-list)))
     4199             (setf (compiland-class-file compiland) class-file)
     4200             (with-class-file class-file
     4201               (let ((*current-compiland* compiland)
     4202                     (*speed* *speed*)
     4203                     (*safety* *safety*)
     4204                     (*debug* *debug*))
     4205                 (p2-compiland compiland)
     4206                 (write-class-file (compiland-class-file compiland))))
    42214207             ;; Verify that the class file is loadable.
    42224208             (let ((*default-pathname-defaults* pathname))
    42234209               (unless (ignore-errors (sys:load-compiled-function pathname))
    4224                  (error "P2-LOCAL-FUNCTION: unable to load ~S." pathname))))
    4225             (t (setf function (sys:load-compiled-function pathname))))
    4226       (cond (local-function
    4227              (setf (local-function-class-file local-function) class-file)
    4228              (let ((g (if *compile-file-truename*
    4229                           (declare-local-function local-function)
    4230                           (declare-object function))))
    4231                (emit 'getstatic *this-class* g +lisp-object+)
    4232                (emit 'var-set (local-function-variable local-function))))
    4233             (t
    4234              (push (make-local-function :name name
    4235                                         :function function
     4210                 (error "Unable to load ~S." pathname)))
     4211             (push (make-local-function :name (compiland-name compiland)
    42364212                                        :class-file class-file)
    4237                    *local-functions*))))))
     4213                   *local-functions*)))
     4214          (t
     4215           (let* ((pathname (make-temp-file))
     4216                  (class-file (make-class-file :pathname pathname
     4217                                               :lambda-list lambda-list)))
     4218             (setf (compiland-class-file compiland) class-file)
     4219             (unwind-protect
     4220                 (progn
     4221                   (with-class-file class-file
     4222                     (let ((*current-compiland* compiland)
     4223                           (*speed* *speed*)
     4224                           (*safety* *safety*)
     4225                           (*debug* *debug*))
     4226                       (p2-compiland compiland)
     4227                       (write-class-file (compiland-class-file compiland))))
     4228                   (push (make-local-function :name (compiland-name compiland)
     4229                                              :function (sys:load-compiled-function pathname)
     4230                                              :class-file class-file)
     4231                         *local-functions*))
     4232               (delete-file pathname)))))))
    42384233
    42394234(defun p2-flet (form &key (target :stack) representation)
     
    42424237        (body (cddr form)))
    42434238    (dolist (compiland compilands)
    4244       (p2-local-function compiland nil))
     4239      (p2-flet-process-compiland compiland))
    42454240    (do ((forms body (cdr forms)))
    42464241        ((null forms))
    42474242      (compile-form (car forms) :target (if (cdr forms) nil target)))))
     4243
     4244(defun p2-labels-process-compiland (compiland local-function)
     4245  (let ((lambda-list (cadr (compiland-lambda-expression compiland))))
     4246    (when (or (memq '&optional lambda-list)
     4247              (memq '&key lambda-list))
     4248      (let ((state nil))
     4249        (dolist (arg lambda-list)
     4250          (cond ((memq arg lambda-list-keywords)
     4251                 (setf state arg))
     4252                ((memq state '(&optional &key))
     4253                 (when (and (consp arg)
     4254                            (not (constantp (second arg))))
     4255                   (compiler-unsupported "P2-LABELS-PROCESS-COMPILAND: can't handle optional argument with non-constant initform.")))))))
     4256    (cond (*compile-file-truename*
     4257           (let* ((pathname (sys::next-classfile-name))
     4258                  (class-file (make-class-file :pathname pathname
     4259                                               :lambda-list lambda-list)))
     4260             (setf (compiland-class-file compiland) class-file)
     4261             (with-class-file class-file
     4262               (let ((*current-compiland* compiland)
     4263                     (*speed* *speed*)
     4264                     (*safety* *safety*)
     4265                     (*debug* *debug*))
     4266                 (p2-compiland compiland)
     4267                 (write-class-file (compiland-class-file compiland))))
     4268             ;; Verify that the class file is loadable.
     4269             (let ((*default-pathname-defaults* pathname))
     4270               (unless (ignore-errors (sys:load-compiled-function pathname))
     4271                 (error "Unable to load ~S." pathname)))
     4272             (setf (local-function-class-file local-function) class-file)
     4273             (let ((g (declare-local-function local-function)))
     4274               (emit 'getstatic *this-class* g +lisp-object+)
     4275               (emit 'var-set (local-function-variable local-function)))))
     4276          (t
     4277           (let* ((pathname (make-temp-file))
     4278                  (class-file (make-class-file :pathname pathname
     4279                                               :lambda-list lambda-list)))
     4280             (setf (compiland-class-file compiland) class-file)
     4281             (unwind-protect
     4282                 (progn
     4283                   (with-class-file class-file
     4284                     (let ((*current-compiland* compiland)
     4285                           (*speed* *speed*)
     4286                           (*safety* *safety*)
     4287                           (*debug* *debug*))
     4288                       (p2-compiland compiland)
     4289                       (write-class-file (compiland-class-file compiland))))
     4290                   (setf (local-function-class-file local-function) class-file)
     4291                   (let ((g (declare-object (sys:load-compiled-function pathname))))
     4292                     (emit 'getstatic *this-class* g +lisp-object+)
     4293                     (emit 'var-set (local-function-variable local-function))))
     4294               (delete-file pathname)))))))
    42484295
    42494296(defun p2-labels (form &key target representation)
     
    42604307          (setf (variable-register variable) (allocate-register)))))
    42614308    (dolist (local-function local-functions)
    4262       (p2-local-function (local-function-compiland local-function) local-function))
     4309      (p2-labels-process-compiland (local-function-compiland local-function)
     4310                                   local-function))
    42634311    (do ((forms body (cdr forms)))
    42644312        ((null forms))
     
    42794327                    "P2-LAMBDA: can't handle optional argument with non-constant initform.")))))))
    42804328    (aver (null (compiland-class-file compiland)))
    4281     (setf (compiland-class-file compiland)
    4282           (make-class-file :pathname (if *compile-file-truename*
    4283                                          (sys::next-classfile-name)
    4284                                          (prog1
    4285                                            (sys::%format nil "local-~D.class" *child-count*)
    4286                                            (incf *child-count*)))
    4287                            :lambda-list lambda-list)))
    4288   (with-class-file (compiland-class-file compiland)
    4289     (let ((*current-compiland* compiland)
    4290           (*speed* *speed*)
    4291           (*safety* *safety*)
    4292           (*debug* *debug*))
    4293       (p2-compiland compiland)
    4294       (write-class-file (compiland-class-file compiland))
    4295       ))
    4296   (let ((class-file (compiland-class-file compiland)))
    4297     (emit 'getstatic *this-class*
    4298           (if *compile-file-truename*
    4299               (declare-local-function (make-local-function :class-file class-file))
    4300               (declare-object (sys:load-compiled-function (class-file-pathname class-file))))
    4301           +lisp-object+))
    4302   (cond ((null *closure-variables*)) ; Nothing to do.
    4303         ((compiland-closure-register *current-compiland*)
    4304          (emit 'aload (compiland-closure-register *current-compiland*))
    4305          (emit-invokestatic +lisp-class+ "makeCompiledClosure"
    4306                             (list +lisp-object+ +lisp-object-array+)
    4307                             +lisp-object+)
    4308          (emit 'checkcast +lisp-compiled-closure-class+)) ; Stack: compiled-closure
    4309         (t
    4310          (aver nil))) ;; Shouldn't happen.
    4311   (emit-move-from-stack target))
     4329    (cond (*compile-file-truename*
     4330           (setf (compiland-class-file compiland)
     4331                 (make-class-file :pathname (sys::next-classfile-name)
     4332                                  :lambda-list lambda-list))
     4333           (with-class-file (compiland-class-file compiland)
     4334             (let ((*current-compiland* compiland)
     4335                   (*speed* *speed*)
     4336                   (*safety* *safety*)
     4337                   (*debug* *debug*))
     4338               (p2-compiland compiland)
     4339               (write-class-file (compiland-class-file compiland))))
     4340           (let ((class-file (compiland-class-file compiland)))
     4341             (emit 'getstatic *this-class*
     4342                   (declare-local-function (make-local-function :class-file class-file))
     4343                   +lisp-object+)))
     4344          (t
     4345           (let ((pathname (make-temp-file)))
     4346             (setf (compiland-class-file compiland)
     4347                   (make-class-file :pathname pathname
     4348                                    :lambda-list lambda-list))
     4349             (unwind-protect
     4350                 (progn
     4351                   (with-class-file (compiland-class-file compiland)
     4352                     (let ((*current-compiland* compiland)
     4353                           (*speed* *speed*)
     4354                           (*safety* *safety*)
     4355                           (*debug* *debug*))
     4356                       (p2-compiland compiland)
     4357                       (write-class-file (compiland-class-file compiland))))
     4358                   (emit 'getstatic *this-class*
     4359                         (declare-object (sys:load-compiled-function pathname))
     4360                         +lisp-object+))
     4361               (delete-file pathname)))))
     4362    (cond ((null *closure-variables*)) ; Nothing to do.
     4363          ((compiland-closure-register *current-compiland*)
     4364           (emit 'aload (compiland-closure-register *current-compiland*))
     4365           (emit-invokestatic +lisp-class+ "makeCompiledClosure"
     4366                              (list +lisp-object+ +lisp-object-array+)
     4367                              +lisp-object+)
     4368           (emit 'checkcast +lisp-compiled-closure-class+)) ; Stack: compiled-closure
     4369          (t
     4370           (aver nil))) ;; Shouldn't happen.
     4371    (emit-move-from-stack target)))
    43124372
    43134373(defun p2-function (form &key (target :stack) representation)
     
    58615921        (*closure-variables* ())
    58625922        (*current-compiland* xep)
    5863         (*child-count* 0)
    58645923        (*speed* 3)
    58655924        (*safety* 0)
     
    63216380        (*closure-variables* ())
    63226381        (*current-compiland* compiland)
    6323         (*child-count* 0)
    63246382        (*speed* *speed*)
    63256383        (*safety* *safety*)
Note: See TracChangeset for help on using the changeset viewer.