(in-package "JVM")
(include-book "../M6-DJVM-shared/jvm-class-table")

(include-book "ordinals/e0-ordinal" :dir :system)
(set-well-founded-relation e0-ord-<)

(acl2::set-verify-guards-eagerness 2)

;----------------------------------------------------------------------

;; (defconst *primitive-types* '(char int float double long boolean byte))


;; (defun primitive-type? (type)
;;   (mem type *primitive-types*))


;; (defun array-type? (type-sig)
;;   (and (true-listp type-sig)
;;        (equal (length type-sig) 2)
;;        (equal (car type-sig) 'ARRAY)))


;; (defun reference-type (type)
;;   (or (stringp type)
;;       (array-type? type)))


;; (defun default-value (type)
;;   (cond ((equal type 'BYTE)  0)
;;         ((equal type 'SHORT) 0)
;;         ((equal type 'INT)   0)
;;         ((equal type 'LONG)  0)
;;         ((equal type 'FLOAT) "0.0")
;;         ((equal type 'DOUBLE) "0.0");
;;         ((equal type 'CHAR)   0)
;;         ((equal type 'BOOLEAN) nil)
;;         ((reference-type type) -1) ;; use -1 as null pointer.
;;         ((array-type? type) -1)    ;;
;;         (t 'NOT-DEFINED))) 

;; ;----------------------------------------------------------------------

;; (defun array-base-type (array-type)
;;   (declare (xargs :guard (array-type? array-type)))
;;   (nth 1 array-type))


;; (defun type-size (type-desc)
;;   (if (or (equal type-desc 'LONG)
;;           (equal type-desc 'DOUBLE))
;;       2
;;     1))

;; ;----------------------------------------------------------------------
;; ;; (acl2::set-verify-guards-eagerness 0)

;; (defun wff-type-rep (type-rep)
;;   (or (primitive-type? type-rep)
;;       (and (consp type-rep)
;;            (or (and (equal (car type-rep) 'class)
;;                     (equal (len type-rep) 2)
;;                     (stringp (cadr type-rep))) 
;;                ;; Tue Apr  6 18:33:46 2004. Modified to 
;;                ;; prevent (class 'uninitializedThis. 
;;                (and (array-type? type-rep)
;;                     (wff-type-rep (array-base-type type-rep)))))))
               

;; (defun normalize-type-rep (type-rep)
;;   (declare (xargs :guard (wff-type-rep type-rep)))
;;   (if (primitive-type? type-rep)
;;       type-rep
;;     (if (consp type-rep)
;;         (cond ((equal (car type-rep) 'class)
;;                (cadr type-rep))
;;               ((Array-Type? type-rep) 
;;                (make-array-type (normalize-type-rep 
;;                                  (array-base-type type-rep))))
;;               (t type-rep))
;;       type-rep)))

;; (defun wff-type-reps (type-reps)
;;   (if (not (consp type-reps)) t
;;     (and (wff-type-rep (car type-reps))
;;          (wff-type-reps (cdr type-reps)))))

;; (defun normalize-type-reps (types)
;;   (declare (xargs :guard (wff-type-reps types)))
;;   (if (not (consp types))
;;       nil
;;     (cons (normalize-type-rep (car types))
;;           (cdr types))))

;;; moved to jvm-class-table.lisp

;; Wed Mar 31 11:33:50 2004

;;
;; Wed Mar 31 11:39:52 2004. fixed to add guard and so that it guard verifies!!
;;

;; transform the type generated by jvm2acl2 into runtime type specific
;; used in the class-loader constant-pool primitives. 
;----------------------------------------------------------------------

(acl2::set-verify-guards-eagerness 2)

(defun primitive-array? (array-type)
  (declare (xargs :guard (array-type? array-type)))
  (primitive-type? (array-base-type array-type)))

;----------------------------------------------------------------------


;; (defconst *array-implemented-interfaces* 
;;   '("java.lang.Clone" "java.lang.Serializeable"))

;; Tue Mar  8 12:10:52 2005. in CLDC JVM array implement no interfaces. 

(defconst *array-implemented-interfaces* '())


;----------------------------------------------------------------------

(defun isClassType (t1)
  (stringp t1)) 
;; FIXED  10/28/03 for the wrong assumption in isJavaAssignmentCompatible
;; originally t1 was expected to be (class <something>)
;; 

(defun isArrayType (t1)
  (and (true-listp t1) 
       ;;; to match with array-type? definition !! Thu Oct 21 17:05:38 2004
       (equal (len t1) 2)
       (equal (car t1) 'array)))


;; (defun isArrayType (t1)
;;   (and (consp t1)
;;        (equal (len t1) 2)
;;        (equal (car t1) 'array)))


;----------------------------------------------------------------------

;;; anything relate to expressing some guard of the shared operations ends up
;;; here. 

;;;; however we will not move 


;; (defun wff-tagged-value (tagged-value)
;;   (declare (xargs :verify-guards t))
;;   (and (consp tagged-value)
;;        (equal (len tagged-value) 1))) 

;; (defun tag-of (tagged-value)
;;   (declare (xargs :guard (wff-tagged-value tagged-value)))
;;   (car tagged-value)) 

;; (defun value-of (tagged-value)
;;   (declare (xargs :guard (wff-tagged-value tagged-value)))
;;   (cdr tagged-value))

;; ;----------------------------------------------------------------------

;; ;; Need a reference type predicate: 
;; (defun wff-REFp (ref)
;;   (declare (xargs :verify-guards t))
;;   ;; when we assert globally syntax correct.  we need assert wff-tagged-value
;;   ;; and appropriate wff-REFp like predicate.
;;   (and (wff-tagged-value ref)
;;        (equal (tag-of ref) 'REF)
;;        (integerp (value-of ref))))
;;        ;; we probably do not to assert (integerp (value-of ref))
;;        ;; because we never only use those as key into heap. 


;; (defun rREF (ref)
;;   (declare (xargs :guard (wff-REFp ref)))
;;   ;; make sure it is only called after we can establish ref is a wff-REFp
;;   (cdr ref))

;; ;; only called on wff-REFp

;; (defun NULLp (ref)
;;   (declare (xargs :verify-guards t))
;;   (and (wff-REFp ref)
;;        (equal (rREF ref) -1)))

;;;; things like above over. because they are concerned with value being
;;;; properly tagged!!

;----------------------------------------------------------------------

(defun wff-array-type (arraytype)
  (declare (xargs :verify-guards t))
  (and (true-listp arraytype) 
       ;; modified to match isArrayType and array-type?
       ;; Thu Oct 21 17:06:34 2004
       (equal (car arraytype) 'ARRAY)
       (equal (len arraytype) 2)))


;; (defun wff-array-type (arraytype)
;;   (declare (xargs :verify-guards t))
;;   (and (consp arraytype)
;;        (equal (car arraytype) 'ARRAY)
;;        (equal (len arraytype) 2)))


(defun array-component-type (arraytype)
  (declare (xargs :guard (wff-array-type arraytype)))
  (cadr arraytype))



;; (defun primitive-type (type)
;;   (declare (xargs :verify-guards t))
;;   (or (equal type 'INT)
;;       (equal type 'ADDR) ;; different from jvm's definition. WHY?
;;       (equal type 'BYTE) 
;;       (equal type 'LONG)
;;       (equal type 'SHORT)
;;       (equal type 'CHAR)));; ARRAY-type MAY NEED THIS
;;                              ;; need to deal with LONG, etc.  

(defun primitive-opvalue-type (type) 
  (declare (xargs :verify-guards t))
   (or (equal type 'INT)
       (equal type 'ADDR)
       (equal type 'LONG)))


;----------------------------------------------------------------------


;; (mutual-recursion 
;;  (defun reference-type-s (type cl)
;;    ;; why reference-type-s should it just be reference-type
;;    ;; this recursive.
;;    (declare (xargs :guard (wff-instance-class-table cl)
;;                    :measure (cons (+ (acl2-count type) 1) 1)))
;;    (or (equal type 'NULL) ;; never used. ;; we represent NULL with (REF . -1)
;;        (array-type-s type cl)
;;        (class-exists? type cl)))
 
;;  (defun array-type-s (type cl)
;;    (declare (xargs :guard (wff-instance-class-table cl)
;;                    :measure (cons (+ (acl2-count type) 1) 0)))
;;    (and (wff-array-type type)
;;         (or (primitive-type (array-component-type type))
;;             ^^^^^^^^^^^^^^^^ ??? primitive-type? 
;;             (reference-type-s (array-component-type type) cl))
;;;            ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
;;; We also need to assert that array-component-type is not null!! 
;;;


(mutual-recursion 
 (defun reference-type-s (type cl)
   ;; why reference-type-s should it just be reference-type
   ;; this recursive.
   (declare (xargs :guard (wff-instance-class-table cl)
                   :measure (cons (+ (acl2-count type) 1) 1)))
   (or (equal type 'NULL) ;; never used. ;; we represent NULL with (REF . -1)
       (array-type-s type cl)
       (class-exists? type cl)))
 
 (defun array-type-s (type cl)
   (declare (xargs :guard (wff-instance-class-table cl)
                   :measure (cons (+ (acl2-count type) 1) 0)))
   (and (wff-array-type type)
        (or (primitive-type? (array-component-type type))
            (and (reference-type-s (array-component-type type) cl)
                 (not (equal (array-component-type type) 'NULL)))))))

;----------------------------------------------------------------------

(defun wff-type-desc (type-desc)
  (or ;; (primitive-type? type-desc)
      ;; Fri Oct 22 11:26:14 2004
      ;; Only used in wff-class-obj
      (isClassType type-desc)
      (isArrayType type-desc)))
;;


;; (defun wff-type-desc (type-desc)
;;   (or ;; (primitive-type? type-desc)
;;       (isClassType type-desc)
;;       (isArrayType type-desc)))
;; ;;

(defun classname-classtype (ctype)
  (declare (xargs :guard (isClassType ctype)))
  ctype) ;; FIXED  10/28/03. see above fix for isClassType

(defun compound (x)
  (consp x))

;; (defun isJavaLangObject (type)
;;   (equal type '(class  "java.lang.Object")))


(defun isJavaLangObject (type)
   (equal type "java.lang.Object"))

; -- used only on arrayType
(defun component-type (aArrayType)
  (declare (xargs :guard (isArrayType aArrayType)))
  (cadr aArrayType))


;;; from consistent-state.lisp

;----------------------------------------------------------------------

;----------------------------------------------------------------------
