Changeset 5861


Ignore:
Timestamp:
02/17/04 01:40:58 (17 years ago)
Author:
piso
Message:

Work in progress.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/jvm.lisp

    r5857 r5861  
    22;;;
    33;;; Copyright (C) 2003-2004 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.68 2004-02-16 19:14:42 piso Exp $
     4;;; $Id: jvm.lisp,v 1.69 2004-02-17 01:40:58 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    335335(defvar *hairy-arglist-p* nil)
    336336
     337(defvar *env* nil)
     338(defvar *closure-vars* nil)
     339
    337340(defvar *val* nil) ; index of value register
    338341
     
    502505(defconstant +lisp-thread-class+ "org/armedbear/lisp/LispThread")
    503506(defconstant +lisp-cons-class+ "org/armedbear/lisp/Cons")
     507(defconstant +lisp-environment-class+ "org/armedbear/lisp/Environment")
    504508
    505509(defun emit-push-nil ()
     
    659663      ((187 ; NEW class-name
    660664        189 ; ANEWARRAY class-name
     665        192 ; CHECKCAST class-name
    661666        193 ; INSTANCEOF class-name
    662667        )
     
    744749     1)
    745750    (189 ; ANEWARRAY
     751     0)
     752    (192 ; CHECKCAST
    746753     0)
    747754    (193 ; INSTANCEOF
     
    20172024             (emit 'astore (1+ index))))
    20182025      (return-from compile-setq))
     2026    (when (memq sym *closure-vars*)
     2027      (error "Unable to compile function defined in non-null lexical environment."))
    20192028    ;; still not found
    20202029    ;; must be a global variable
     
    20982107      (setf form (list* 'lambda arglist body)))
    20992108    (format t "form = ~S~%" form)
    2100     (setf function (compile-defun name form "flet.out"))
     2109    (setf function (compile-defun name form nil "flet.out"))
    21012110    (format t "function = ~S~%" function)
    21022111    (push (make-local-function :name name
     
    22232232           (compile-function-call (car form) (cdr form))))))
    22242233
    2225 (defun compile-variable-ref (form)
    2226   (let ((v (find-variable form)))
     2234(defun compile-variable-ref (var)
     2235  (let ((v (find-variable var)))
    22272236    (unless (and v (variable-special-p v))
    2228       (let ((index (position form *locals* :from-end t)))
     2237      (let ((index (position var *locals* :from-end t)))
    22292238        (when index
    22302239          (emit 'aload index)
     
    22322241          (return-from compile-variable-ref)))
    22332242      ;; Not found in locals; look in args.
    2234       (let ((index (position form *args*)))
     2243      (let ((index (position var *args*)))
    22352244        (when index
    22362245          (cond (*using-arg-array*
     
    22442253                 (emit-store-value)
    22452254                 (return-from compile-variable-ref))))))
     2255    (when (memq var *closure-vars*)
     2256      (let ((g (declare-object *env*)))
     2257        (emit 'getstatic
     2258              *this-class*
     2259              g
     2260              "Lorg/armedbear/lisp/LispObject;"))
     2261      ;; Cast it to an Environment object.
     2262      (emit 'checkcast +lisp-environment-class+)
     2263      (let ((g (declare-symbol var)))
     2264        (emit 'getstatic
     2265              *this-class*
     2266              g
     2267              "Lorg/armedbear/lisp/Symbol;"))
     2268      (emit-invokevirtual +lisp-environment-class+
     2269                          "lookup"
     2270                          "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
     2271                          -1)
     2272      (emit-store-value)
     2273      (return-from compile-variable-ref))
    22462274    ;; Otherwise it must be a global variable.
    2247     (let ((g (declare-symbol form)))
     2275    (let ((g (declare-symbol var)))
    22482276      (emit 'getstatic
    22492277            *this-class*
     
    23182346       #.(format nil "([~A)~A" +lisp-object+ +lisp-object+))))
    23192347
    2320 (defun compile-defun (name form &optional (classfile "out.class"))
     2348(defun compile-defun (name form environment &optional (classfile "out.class"))
    23212349  (unless (eq (car form) 'LAMBDA)
    23222350    (return-from compile-defun nil))
     
    23412369         (*locals* (make-array 256 :fill-pointer 0)) ; FIXME Remove hard limit!
    23422370         (*max-locals* 0)
     2371         (*env* environment)
     2372         (*closure-vars* (if environment (sys::environment-vars environment) nil))
    23432373         (*variables* ())
    23442374         (*pool* ())
     
    24102440      (with-open-file (*stream* classfile
    24112441                                :direction :output
    2412                                 :element-type 'unsigned-byte
     2442                                :element-type '(unsigned-byte 8)
    24132443                                :if-exists :supersede)
    24142444        (write-u4 #xCAFEBABE)
     
    24402470           (eq (car definition-designator) 'LAMBDA))
    24412471      definition-designator
    2442       (multiple-value-bind (lambda-expression closure-p)
     2472      (multiple-value-bind (lambda-expression environment)
    24432473        (function-lambda-expression definition-designator)
    2444         (when closure-p
    2445           (error "Unable to compile function defined in non-null lexical environment."))
     2474        (when environment
     2475          (warn "Function defined in non-null lexical environment."))
    24462476  (unless lambda-expression
    24472477    (error :format-control "Can't find a definition for ~S."
    24482478                 :format-arguments (list definition-designator)))
    2449         lambda-expression)))
     2479        (values lambda-expression environment))))
    24502480
    24512481(defun load-verbose-prefix ()
     
    24802510        (return-from jvm-compile (values name nil nil))))
    24812511    (handler-case
    2482         (let* ((*package* (if (and name (symbol-package name))
    2483                               (symbol-package name)
    2484                               *package*))
    2485                (expr (get-lambda-to-compile definition))
    2486                (compiled-definition (compile-defun name expr)))
    2487           (when (and name (functionp compiled-definition))
    2488             (sys::%set-lambda-name compiled-definition name)
    2489             (sys::%set-call-count compiled-definition (sys::%call-count definition))
    2490             (sys::%set-arglist compiled-definition (sys::arglist definition))
    2491             (if (macro-function name)
    2492                 (setf (fdefinition name) (sys::make-macro compiled-definition))
    2493                 (setf (fdefinition name) compiled-definition)))
    2494           (when *compile-print*
    2495             (if name
    2496                 (%format t "~A Compiled ~S~%" prefix name)
    2497                 (%format t "~A Compiled top-level form~%" prefix)))
    2498           (values (or name compiled-definition) nil nil))
     2512        (multiple-value-bind (expr env) (get-lambda-to-compile definition)
     2513          (let* ((*package* (if (and name (symbol-package name))
     2514                                (symbol-package name)
     2515                                *package*))
     2516                 (compiled-definition (compile-defun name expr env)))
     2517            (when (and name (functionp compiled-definition))
     2518              (sys::%set-lambda-name compiled-definition name)
     2519              (sys::%set-call-count compiled-definition (sys::%call-count definition))
     2520              (sys::%set-arglist compiled-definition (sys::arglist definition))
     2521              (if (macro-function name)
     2522                  (setf (fdefinition name) (sys::make-macro compiled-definition))
     2523                  (setf (fdefinition name) compiled-definition)))
     2524            (when *compile-print*
     2525              (if name
     2526                  (%format t "~A Compiled ~S~%" prefix name)
     2527                  (%format t "~A Compiled top-level form~%" prefix)))
     2528            (values (or name compiled-definition) nil nil)))
    24992529      (error (c)
    25002530             (%format t "Error: ~A~%" c)
Note: See TracChangeset for help on using the changeset viewer.