;;; compiler-tests.lisp
;;;
;;; Copyright (C) 2010 Erik Huelsmann
;;;
;;; $Id$
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

#+abcl
(require '#:jvm)

(in-package #:abcl.test.lisp)


(deftest fieldtype.1a
    (string= (jvm::internal-field-type :int) "I")
  T)

(deftest fieldtype.1b
    (string= (jvm::internal-field-type :long) "J")
  T)

(deftest fieldtype.1c
    (string= (jvm::internal-field-type :float) "F")
  T)

(deftest fieldtype.1d
    (string= (jvm::internal-field-type :double) "D")
  T)

(deftest fieldtype.1e
    (string= (jvm::internal-field-type :boolean) "Z")
  T)

(deftest fieldtype.1f
    (string= (jvm::internal-field-type :char) "C")
  T)

(deftest fieldtype.1g
    (string= (jvm::internal-field-type :byte) "B")
  T)

(deftest fieldtype.1h
    (string= (jvm::internal-field-type :short) "S")
  T)

(deftest fieldtype.1i
    (string= (jvm::internal-field-type :void) "V")
  T)

(deftest fieldtype.1j
    (string= (jvm::internal-field-type nil) "V")
  T)

(deftest fieldtype.2
    (string= (jvm::internal-field-type jvm::+lisp-object+)
             "org/armedbear/lisp/LispObject")
  T)


(deftest fieldref.1a
    (string= (jvm::internal-field-ref :int) "I")
  T)

(deftest fieldref.1b
    (string= (jvm::internal-field-ref :long) "J")
  T)

(deftest fieldref.1c
    (string= (jvm::internal-field-ref :float) "F")
  T)

(deftest fieldref.1d
    (string= (jvm::internal-field-ref :double) "D")
  T)

(deftest fieldref.1e
    (string= (jvm::internal-field-ref :boolean) "Z")
  T)

(deftest fieldref.1f
    (string= (jvm::internal-field-ref :char) "C")
  T)

(deftest fieldref.1g
    (string= (jvm::internal-field-ref :byte) "B")
  T)

(deftest fieldref.1h
    (string= (jvm::internal-field-ref :short) "S")
  T)

(deftest fieldref.1i
    (string= (jvm::internal-field-ref :void) "V")
  T)

(deftest fieldref.1j
    (string= (jvm::internal-field-ref nil) "V")
  T)

(deftest fieldref.2
    (string= (jvm::internal-field-ref jvm::+lisp-object+)
             "Lorg/armedbear/lisp/LispObject;")
  T)

(deftest descriptor.1
    (and
     (string= (jvm::descriptor :void :int :long :boolean)
              "(IJZ)V")
     (string= (jvm::descriptor nil :int :long :boolean)
              "(IJZ)V"))
  T)

(deftest descriptor.2
    (string= (jvm::descriptor jvm::+lisp-object+ jvm::+lisp-object+)
             "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")
  T)

(deftest map-flags.1
    (eql (jvm::map-flags '(:public)) #x0001)
  T)

(deftest pool.1
    (let* ((pool (jvm::make-pool)))
      (jvm::pool-add-class pool jvm::+lisp-readtable+)
      (jvm::pool-add-field-ref pool jvm::+lisp-readtable+ "ABC" :int)
      (jvm::pool-add-field-ref pool
                               jvm::+lisp-readtable+ "ABD"
                               jvm::+lisp-readtable+)
      (jvm::pool-add-method-ref pool jvm::+lisp-readtable+ "MBC" :int)
      (jvm::pool-add-method-ref pool jvm::+lisp-readtable+ "MBD"
                                jvm::+lisp-readtable+)
      (jvm::pool-add-interface-method-ref pool
                                          jvm::+lisp-readtable+ "MBD" :int)
      (jvm::pool-add-interface-method-ref pool
                                          jvm::+lisp-readtable+ "MBD"
                                          jvm::+lisp-readtable+)
      (jvm::pool-add-string pool "string")
      (jvm::pool-add-int pool 1)
      (jvm::pool-add-float pool 1.0f0)
      (jvm::pool-add-long pool 1)
      (jvm::pool-add-double pool 1.0d0)
      (jvm::pool-add-name/type pool "name1" :int)
      (jvm::pool-add-name/type pool "name2" jvm::+lisp-object+)
      (jvm::pool-add-utf8 pool "utf8")
      T)
  T)

(deftest make-class-file.1
    (let* ((class (jvm::make-jvm-class-name "org/armedbear/lisp/mcf_1"))
           (file (jvm::make-class-file class jvm::+lisp-object+ '(:public))))
      (jvm::class-add-field file (jvm::make-field "ABC" :int))
      (jvm::class-add-field file (jvm::make-field "ABD" jvm::+lisp-object+))
      (jvm::class-add-method file (jvm::make-jvm-method "MBC" nil :int))
      (jvm::class-add-method file (jvm::make-jvm-method "MBD" nil jvm::+lisp-object+))
      (jvm::class-add-method file (jvm::make-jvm-method :constructor :void nil))
      (jvm::class-add-method file (jvm::make-jvm-method :static-initializer :void nil))
      T)
  T)

(deftest finalize-class-file.1
    (let* ((class (jvm::make-jvm-class-name "org/armedbear/lisp/fcf_1"))
           (file (jvm::make-class-file class jvm::+lisp-object+ '(:public))))
      (jvm::class-add-field file (jvm::make-field "ABC" :int))
      (jvm::class-add-field file (jvm::make-field "ABD" jvm::+lisp-object+))
      (jvm::class-add-method file (jvm::make-jvm-method "MBC" nil '(:int)))
      (jvm::class-add-method file
                             (jvm::make-jvm-method "MBD" nil
                                                (list jvm::+lisp-object+)))
      (jvm::finalize-class-file file)
      file
      T)
  T)

(deftest generate-method.1
    (let* ((class (jvm::make-jvm-class-name "org/armedbear/lisp/gm_1"))
           (file (jvm::make-class-file class jvm::+lisp-object+ '(:public)))
           (method (jvm::make-jvm-method :static-initializer :void nil
                                      :flags '(:static))))
      (jvm::class-add-method file method)
      (jvm::with-code-to-method (file method)
        (jvm::emit 'return))
      (jvm::finalize-class-file file)
      (with-open-stream (stream (sys::%make-byte-array-output-stream))
        (jvm::write-class-file file stream)
        (sys::load-compiled-function (sys::%get-output-stream-bytes stream)))
      T)
  T)

(deftest generate-method.2
    (let* ((class (jvm::make-jvm-class-name "org/armedbear/lisp/gm_2"))
           (file (jvm::make-class-file class jvm::+lisp-object+ '(:public)))
           (method (jvm::make-jvm-method "doNothing" :void nil)))
      (jvm::class-add-method file method)
      (jvm::with-code-to-method (file method)
        (let ((label1 (gensym))
              (label2 (gensym))
              (label3 (gensym)))
          (jvm::label label1)
          (jvm::emit 'jvm::iconst_1)
          (jvm::label label2)
          (jvm::emit 'return)
          (jvm::label label3)
          (jvm::code-add-exception-handler (jvm::method-attribute method "Code")
                                           label1 label2 label3 nil))
        (jvm::emit 'return))
      (jvm::finalize-class-file file)
      (with-open-stream (stream (sys::%make-byte-array-output-stream))
        (jvm::write-class-file file stream)
        (sys::load-compiled-function (sys::%get-output-stream-bytes stream)))
      T)
  T)

;; generation of an ABCL-like function class
(deftest generate-method.3
    (let* ((class (jvm::make-jvm-class-name "org.armedbear.lisp.gm_3"))
           (file (jvm::make-class-file class jvm::+lisp-primitive+ '(:public)))
           )
      (let ((method (jvm::make-jvm-method :constructor :void nil)))
        (jvm::class-add-method file method)
        (jvm::with-code-to-method (file method)
          (jvm::emit 'aload 0)
          (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-symbol+)
          (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-symbol+)
          (jvm::emit-invokespecial-init jvm::+lisp-primitive+
                                        (list jvm::+lisp-object+
                                              jvm::+lisp-object+))
          (jvm::emit 'return)))
      (let ((method (jvm::make-jvm-method "execute" jvm::+lisp-object+ nil)))
        (jvm::class-add-method file method)
        (jvm::with-code-to-method (file method)
          (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-symbol+)
          (jvm::emit 'jvm::areturn)))
      (jvm::finalize-class-file file)
      (with-open-stream (stream (sys::%make-byte-array-output-stream))
        (jvm::write-class-file file stream)
        (funcall (sys::load-compiled-function (sys::%get-output-stream-bytes stream)))))
  NIL)

;; generation of an ABCL-like function class with static init function and
;; static field
(deftest generate-method.4
    (let* ((class (jvm::make-jvm-class-name "org.armedbear.lisp.gm_4"))
           (file (jvm::make-class-file class jvm::+lisp-primitive+ '(:public)))
           )
      (jvm::class-add-field file (jvm::make-field "N1" jvm::+lisp-object+
                                                  :flags '(:static :private)))
      (let ((method (jvm::make-jvm-method :static-initializer :void nil :flags '(:static))))
        (jvm::class-add-method file method)
        (jvm::with-code-to-method (file method)
          (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-symbol+)
          (jvm::emit-putstatic class "N1" jvm::+lisp-object+)
          (jvm::emit 'return)))
      (let ((method (jvm::make-jvm-method :constructor :void nil)))
        (jvm::class-add-method file method)
        (jvm::with-code-to-method (file method)
          (jvm::emit 'aload 0)
          (jvm::emit-getstatic class "N1" jvm::+lisp-object+)
          (jvm::emit-getstatic class "N1" jvm::+lisp-object+)
          (jvm::emit-invokespecial-init jvm::+lisp-primitive+
                                        (list jvm::+lisp-object+
                                              jvm::+lisp-object+))
          (jvm::emit 'return)))
      (let ((method (jvm::make-jvm-method "execute" jvm::+lisp-object+ nil)))
        (jvm::class-add-method file method)
        (jvm::with-code-to-method (file method)
          (jvm::emit-getstatic class "N1" jvm::+lisp-object+)
          (jvm::emit 'jvm::areturn)))
      (jvm::finalize-class-file file)
      (with-open-stream (stream (sys::%make-byte-array-output-stream))
        (jvm::write-class-file file stream)
        (funcall (sys::load-compiled-function (sys::%get-output-stream-bytes stream)))))
  NIL)


;; generation of ABCL-like function class with multiple 'execute' methods
(deftest generate-method.5
    (let* ((class (jvm::make-jvm-class-name "org.armedbear.lisp.gm_5"))
           (file (jvm::make-class-file class jvm::+lisp-primitive+ '(:public)))
           )
      (let ((method (jvm::make-jvm-method :constructor :void nil)))
        (jvm::class-add-method file method)
        (jvm::with-code-to-method (file method)
          (jvm::emit 'aload 0)
          (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-symbol+)
          (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-symbol+)
          (jvm::emit-invokespecial-init jvm::+lisp-primitive+
                                        (list jvm::+lisp-object+
                                              jvm::+lisp-object+))
          (jvm::emit 'return)))
      (let ((method (jvm::make-jvm-method "execute" jvm::+lisp-object+ nil)))
        (jvm::class-add-method file method)
        (jvm::with-code-to-method (file method)
          (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-symbol+)
          (jvm::emit 'jvm::areturn)))
      (let ((method (jvm::make-jvm-method "execute" jvm::+lisp-object+
                                       (list jvm::+lisp-object+))))
        (jvm::class-add-method file method)
        (jvm::with-code-to-method (file method)
          (jvm::emit-getstatic jvm::+lisp+ "T" jvm::+lisp-symbol+)
          (jvm::emit 'jvm::areturn)))
      (jvm::finalize-class-file file)
      (with-open-stream (stream (sys::%make-byte-array-output-stream))
        (jvm::write-class-file file stream)
        (let* ((bytes (sys::%get-output-stream-bytes stream))
               (fn (sys::load-compiled-function bytes)))
          (values (funcall fn) (funcall fn NIL)))))
  NIL T)

;;Nested with-code-to-method
(deftest with-code-to-method.1
    (let* ((class (jvm::make-jvm-class-name "org/armedbear/lisp/gm_6"))
           (file (jvm::make-class-file class jvm::+lisp-object+ '(:public)))
           (method (jvm::make-jvm-method :static-initializer :void nil
				      :flags '(:static)))
	   (registers nil))
      (jvm::class-add-method file method)
      (jvm::with-code-to-method (file method)
	(jvm::allocate-register :int)
	(push jvm::*register* registers)
	(jvm::with-code-to-method (file method)
	  (jvm::allocate-register :int)
	  (push jvm::*register* registers)
	  (jvm::with-code-to-method (file method)
	    (jvm::allocate-register :int)
	    (push jvm::*register* registers))
	  (jvm::allocate-register :int)
	  (push jvm::*register* registers))
	(jvm::allocate-register :int)
	(push jvm::*register* registers)
        (jvm::emit 'return))
      (jvm::finalize-class-file file)
      (nreverse registers))
  (1 2 3 4 5))

(deftest with-code-to-method.2
    (let* ((class (jvm::make-jvm-class-name "org/armedbear/lisp/gm_7"))
           (file (jvm::make-class-file class jvm::+lisp-object+ '(:public)))
           (method1 (jvm::make-jvm-method :static-initializer :void nil
				       :flags '(:static)))
	   (method2 (jvm::make-jvm-method "method2" :void nil))
	   (registers nil))
      (jvm::class-add-method file method1)
      (jvm::class-add-method file method2)
      (jvm::with-code-to-method (file method1)
	(jvm::allocate-register :int)
	(push jvm::*register* registers)
	(jvm::with-code-to-method (file method2)
	  (jvm::allocate-register :int)
	  (push jvm::*register* registers)
	  (jvm::with-code-to-method (file method1)
	    (jvm::allocate-register :int)
	    (push jvm::*register* registers))
	  (jvm::allocate-register :int)
	  (push jvm::*register* registers))
	(jvm::allocate-register :int)
	(push jvm::*register* registers)
        (jvm::emit 'return))
      (jvm::finalize-class-file file)
      (nreverse registers))
  (1 1 2 2 3))

;; ;;  generation of an ABCL-like function, with mixed output to constructor,
;; ;;  static initializer and function method(s)
;; (deftest generate-method.6
;;     (let* ((class (jvm::make-jvm-class-name "org.armedbear.lisp.gm_6"))
;;            (file (jvm::make-class-file class jvm::+lisp-primitive+ '(:public)))
;;            )
;;       (let ((method (jvm::make-method :constructor :void nil)))
;;         (jvm::class-add-method file method)
;;         (jvm::with-code-to-method (file method)
;;           (jvm::emit 'aload 0)
;;           (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-object+)
;;           (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-object+)
;;           (jvm::emit-invokespecial-init jvm::+lisp-primitive+
;;                                         (list jvm::+lisp-object+
;;                                               jvm::+lisp-object+))
;;           (jvm::emit 'return)))
;;       (let ((method (jvm::make-method "execute" jvm::+lisp-object+ nil)))
;;         (jvm::class-add-method file method)
;;         (jvm::with-code-to-method (file method)
;;           (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-object+)
;;           (jvm::emit 'jvm::areturn)))
;;       (jvm::finalize-class-file file)
;;       (with-open-stream (stream (sys::%make-byte-array-output-stream))
;;         (jvm::write-class-file file stream)
;;         (ignore-errors (sys::load-compiled-function nil))
;;         (funcall (sys::load-compiled-function (sys::%get-output-stream-bytes stream))))
;;       T
;;       )
;;   T)

