;; Copyright (C) 2008-2013 Tommi Höynälänmaa
;; Distributed under GNU General Public License version 3,
;; see file doc/GPL-3.



;; *** Procedures with special type checking ***


(import (rnrs exceptions)
	(srfi srfi-1)
	(th-scheme-utilities stdutils)
	(th-scheme-utilities hrecord))


;; The purity of the procedure expression (first expression in the
;; procedure application) does not need to be checked here,
;; because the procedure expression is always a variable reference
;; with special procedures.


(define (make-t-simple-proc t-name tt)
  (assert (symbol? t-name))
  (assert (is-target-object? tt))
  (assert (is-tc-simple-proc? tt))
  (let* ((address (alloc-builtin-loc t-name))
	 (addr-raw-proc (alloc-builtin-raw-loc t-name))
	 (to (make-procedure tt #t #f address
			     t-name addr-raw-proc)))
    to))


(define (make-t-param-proc t-name tt)
  (assert (symbol? t-name))
  (assert (is-target-object? tt))
  (assert (is-tc-param-proc? tt))
  (let* ((address (alloc-builtin-loc t-name))
	 (to
	  (make-param-proc-object t-name
				  tt
				  '()
				  address)))
    to))


(define tp-equal-values
  (make-t-simple-proc
   'equal-values?
   (make-tpti-general-proc
    #t
    (make-tuple-type tc-object tc-object)
    tc-boolean
    #t #f #f #f)))


(define tp-equal-objects
  (make-t-simple-proc
   'equal-objects?
   (make-tpti-general-proc
    #t
    (make-tuple-type tc-object tc-object)
    tc-boolean
    #t #f #f #f)))


(define tp-equal-contents
  (make-t-simple-proc
   'equal-contents?
   (make-tpti-general-proc
    #t
    (make-tuple-type tc-object tc-object)
    tc-boolean
    #t #f #f #f)))


(define tp-tuple-type-with-tail
  (make-t-simple-proc
   'make-tuple-type-with-tail
   (make-tpti-general-proc
    #t
    (make-tuple-type tt-type tt-type)
    tt-type
    #t #f #f #f)))


(define tp-field-ref
  (make-t-simple-proc
   'field-ref
   (make-tpti-general-proc
    #t
    (make-tuple-type tc-object tc-symbol)
    tc-object
    #t #f #f #f)))


(define tp-field-set
  (make-t-simple-proc
   'field-set!
   (make-tpti-general-proc
    #t
    (make-tuple-type tc-object tc-symbol tc-object)
    tt-none
    #f #f #f #f)))


(define tp-class-of
  (make-t-simple-proc
   'class-of
   (make-tpti-general-proc
    #t
    (make-tuple-type tc-object)
    tc-class
    #t #t #f #f)))


(define tp-is-subtype
  (make-t-simple-proc
   'is-subtype?
   (make-tpti-general-proc
    #t
    (make-tuple-type tt-type tt-type)
    tc-boolean
    #t #f #f #f)))


(define tp-is-instance
  (make-t-simple-proc
   'is-instance?
   (make-tpti-general-proc
    #t
    (make-tuple-type tc-object tt-type)
    tc-boolean
    #t #f #f #f)))


(define tp-tuple-ref
  (make-t-simple-proc
   'tuple-ref
   (make-tpti-general-proc
    #t
    (make-tuple-type tc-object tc-integer)
    tc-object
    #t #f #f #f)))


(define tp-apply
  (make-t-param-proc
   'apply
   (let ((tvar-arglist (make-builtin-tvar 'arglist1))
	 (tvar-result (make-builtin-tvar 'result1)))
     (make-param-proc-class-object
      "instance of :param-proc"
      (list tvar-arglist tvar-result)
      (make-tpti-general-proc
       #t
       (make-tuple-type
	(make-tpti-general-proc
	 #f
	 tvar-arglist
	 tvar-result
	 #t #f #f #f)
	tvar-arglist)
       tvar-result
       #t #f #f #f)))))


(set! tp-apply-fwd tp-apply)


(define tp-apply-nonpure
  (make-t-param-proc
   'apply-nonpure
   (let ((tvar-arglist (make-builtin-tvar 'arglist2))
	 (tvar-result (make-builtin-tvar 'result2)))
     (make-param-proc-class-object
      "instance of :param-proc"
      (list tvar-arglist tvar-result)
      (make-tpti-general-proc
       #t
       (make-tuple-type
	(make-tpti-general-proc
	 #f
	 tvar-arglist
	 tvar-result
	 #f #f #f #f)
	tvar-arglist)
       tvar-result
       #f #f #f #f)))))


(set! tp-apply-nonpure-fwd tp-apply-nonpure)


;; The following four procedures raise an exception
;; if the vector length is negative.


(define tp-make-vector
  (make-t-simple-proc
   'make-vector
   (make-tpti-general-proc
    #t
    (make-tuple-type tt-type tc-integer tc-object)
    tc-object
    #t #f #f #f)))


(define tp-make-mutable-vector
  (make-t-simple-proc
   'make-mutable-vector
   (make-tpti-general-proc
    #t
    (make-tuple-type tt-type tc-integer tc-object)
    tc-object
    #t #f #f #f)))


(define tp-make-value-vector
  (make-t-simple-proc
   'make-value-vector
   (make-tpti-general-proc
    #t
    (make-tuple-type tt-type tc-integer tc-object)
    tc-object
    #t #f #f #f)))


(define tp-make-mutable-value-vector
  (make-t-simple-proc
   'make-mutable-value-vector
   (make-tpti-general-proc
    #t
    (make-tuple-type tt-type tc-integer tc-object)
    tc-object
    #t #f #f #f)))


(define tp-vector
  (make-t-simple-proc
   'vector
   (make-tpti-general-proc
    #t
    (translate-tuple-type-with-tail (make-tuple-type tt-type)
				    (make-tt-uniform-list tc-object))
    tc-object
    #t #t #f #f)))


(define tp-value-vector
  (make-t-simple-proc
   'value-vector
   (make-tpti-general-proc
    #t
    (translate-tuple-type-with-tail (make-tuple-type tt-type)
				    (make-tt-uniform-list tc-object))
    tc-object
    #t #t #f #f)))


(define tp-mutable-vector
  (make-t-simple-proc
   'mutable-vector
   (make-tpti-general-proc
    #t
    (translate-tuple-type-with-tail (make-tuple-type tt-type)
				    (make-tt-uniform-list tc-object))
    tc-object
    #t #t #f #f)))


(define tp-mutable-value-vector
  (make-t-simple-proc
   'mutable-value-vector
   (make-tpti-general-proc
    #t
    (translate-tuple-type-with-tail (make-tuple-type tt-type)
				    (make-tt-uniform-list tc-object))
    tc-object
    #t #t #f #f)))


(define tp-cast-vector
  (make-t-simple-proc
   'cast-vector
   (make-tpti-general-proc
    #t
    (make-tuple-type tt-type tc-object)
    tc-object
    #t #f #f #f)))


(define tp-cast-vector0
  (make-t-simple-proc
   'cast-vector0
   (make-tpti-general-proc
    #t
    (make-tuple-type tt-type tc-object)
    tc-object
    #t #f #f #f)))


(define tp-cast-mutable-vector
  (make-t-simple-proc
   'cast-mutable-vector
   (make-tpti-general-proc
    #t
    (make-tuple-type tt-type tc-object)
    tc-object
    #t #f #f #f)))


(define tp-cast-mutable-vector0
  (make-t-simple-proc
   'cast-mutable-vector0
   (make-tpti-general-proc
    #t
    (make-tuple-type tt-type tc-object)
    tc-object
    #t #f #f #f)))


(define tp-cast-value-vector
  (make-t-simple-proc
   'cast-value-vector
   (make-tpti-general-proc
    #t
    (make-tuple-type tt-type tc-object)
    tc-object
    #t #f #f #f)))


(define tp-cast-value-vector0
  (make-t-simple-proc
   'cast-value-vector0
   (make-tpti-general-proc
    #t
    (make-tuple-type tt-type tc-object)
    tc-object
    #t #f #f #f)))


(define tp-cast-mutable-value-vector
  (make-t-simple-proc
   'cast-mutable-value-vector
   (make-tpti-general-proc
    #t
    (make-tuple-type tt-type tc-object)
    tc-object
    #t #f #f #f)))


(define tp-cast-mutable-value-vector0
  (make-t-simple-proc
   'cast-mutable-value-vector0
   (make-tpti-general-proc
    #t
    (make-tuple-type tt-type tc-object)
    tc-object
    #t #f #f #f)))


(define tp-cast-vector-metaclass
  (make-t-simple-proc
   'cast-vector-metaclass
   (make-tpti-general-proc
    #t
    (make-tuple-type tc-object)
    tc-object
    #t #f #f #f)))


(define tp-cast-mutable-vector-metaclass
  (make-t-simple-proc
   'cast-mutable-vector-metaclass
   (make-tpti-general-proc
    #t
    (make-tuple-type tc-object)
    tc-object
    #t #f #f #f)))


(define tp-cast-value-vector-metaclass
  (make-t-simple-proc
   'cast-value-vector-metaclass
   (make-tpti-general-proc
    #t
    (make-tuple-type tc-object)
    tc-object
    #t #f #f #f)))


(define tp-cast-mutable-value-vector-metaclass
  (make-t-simple-proc
   'cast-mutable-value-vector-metaclass
   (make-tpti-general-proc
    #t
    (make-tuple-type tc-object)
    tc-object
    #t #f #f #f)))


;; For field-ref and field-set! only the procedures
;; needed by both the compiler and the linker
;; are defined here. The procedures needed by
;; only the compiler are in theme-d-fields.scm.


(define (translate-const-field-ref binder obj-expr field-name)
  (assert (is-binder? binder))
  (assert (is-entity? obj-expr))
  (strong-assert (symbol? field-name))
  (strong-assert (not (entity-type-is-none1? binder obj-expr)))
  (strong-assert (is-t-instance? binder (get-entity-type obj-expr) tc-class))
  (let* ((type (get-entity-type obj-expr))
	 (field (get-field-spec type field-name)))
    (if (not-null? field)
	(let* ((field-type (tno-field-ref field 'type))
	       (exact-type?
		(and (is-t-instance? binder field-type tc-class)
		     (not (tno-field-ref field-type 'inheritable?))))
	       (pure-args? (is-pure-entity? obj-expr)))
	  (make-hrecord
	   <field-ref-expr>
	   field-type
	   #t
	   exact-type?
	   '()
	   pure-args?
	   #f
	   (null? field-type)
	   '()

	   ;; The existence of the field is checked statically.
	   (entity-always-returns? obj-expr)
	   (entity-never-returns? obj-expr)
	   #t
	   obj-expr
	   field-name))
	(raise (list 'field-ref:nonexistent-field
		     (cons 's-field-name field-name))))))


(set! translate-const-field-ref-fwd translate-const-field-ref)


(define (translate-const-field-set binder obj-expr field-name
				   value type-check? inside-param-def?)
  (assert (is-binder? binder))
  (assert (is-entity? obj-expr))
  (strong-assert (symbol? field-name))
  (assert (is-entity? value))
  (assert (boolean? type-check?))
  (strong-assert (and (not (entity-type-is-none1? binder obj-expr))
		      (not (entity-type-is-none1? binder value))))
  (let* ((type-expr (get-entity-type obj-expr))
	 (type-dispatched? (entity-type-dispatched? obj-expr))
	 (always-returns?
	  (and (entity-always-returns? obj-expr)
	       (entity-always-returns? value)))
	 (never-returns?
	  (or (entity-never-returns? obj-expr)
	      (entity-never-returns? value))))
    (cond
     ((and type-check? (not inside-param-def?) (not type-dispatched?))
      (raise 'illegal-undispatched-type))
     ((or (not type-dispatched?) (contains-free-tvars-fwd? type-expr))
      (make-hrecord <field-set-expr>
		    tt-none
		    #t
		    #t
		    '()
		    #f
		    #f
		    #t
		    '()
		    always-returns?
		    never-returns?
		    #t
		    obj-expr
		    field-name
		    value))
     ((is-t-instance? binder type-expr tc-class)
      (let ((field (get-field-spec type-expr field-name)))
	(if (not-null? field)
	    (let* ((field-type (tno-field-ref field 'type))
		   (value-type (get-entity-type value)))
	      (if (or
		   (not type-check?)
		   (is-t-subtype? binder value-type field-type))
		  (begin
		    (make-hrecord <field-set-expr>
				  tt-none
				  #t
				  #t
				  '()

				  #f
				  #f
				  (or (not type-check?)
				      inside-param-def?)
				  '()

				  always-returns?
				  never-returns?
				  #t
				  obj-expr
				  field-name
				  value))
		  (begin
		    (dvar1-set! obj-expr)
		    (dvar2-set! field-type)
		    (dvar3-set! field-name)
		    (dvar4-set! value)
		    (raise 'field-set!:type-mismatch))))
	    (raise (list 'field-set!:nonexistent-field
			 (cons 's-field-name field-name))))))
     (else (raise 'field-set!:invalid-class)))))


(set! translate-const-field-set-fwd translate-const-field-set)


(define (translate-tuple-type-with-tail-appl binder
					     proc arguments inside-param-def?)
  (assert (is-binder? binder))
  (assert (is-entity? proc))
  (assert (and (list? arguments)
	       (and-map? is-entity? arguments)))
  (check-no-none-arguments binder arguments 'tuple-type-with-tail)
  (if (= (length arguments) 2)
      ;; What about purity?
      (let ((tuple-part (car arguments))
	    (tail-part (cadr arguments)))
	(if (or inside-param-def?
		(contains-free-tvars-general-fwd? tuple-part)
		(contains-free-tvars-general-fwd? tail-part)
		(and (is-t-instance? binder tuple-part tt-type)
		     (is-t-instance? binder tail-part tt-type)))
	    (translate-tuple-type-with-tail tuple-part tail-part)
	    (raise 'tuple-with-tail-invalid-args)))
      (raise 'invalid-number-of-arguments-for-tuple-with-tail)))


(define (translate-class-of-appl binder proc arguments)
  (assert (is-binder? binder))
  (assert (is-entity? proc))
  (assert (and (list? arguments)
	       (and-map? is-entity? arguments)))
  (check-no-none-arguments binder arguments 'class-of)
  (if (= (length arguments) 1)
      (let* ((r-value (car arguments))
	     (r-type (get-entity-type r-value)))
	(if (and (not-null? r-type)
		 (is-known-pure-entity? r-value)
		 (entity-type-dispatched? r-value)
		 ;; (not (contains-free-tvars-general-fwd? r-type))
		 (is-t-instance? binder r-type tc-class)
		 (not (tno-field-ref r-type 'inheritable?)))
	    r-type
	    (let ((pure-args? (is-pure-entity? r-value))
		  (type-dispatched? (entity-type-dispatched? r-value))
		  (always-returns? (entity-always-returns? r-value))
		  (never-returns? (entity-never-returns? r-value))
		  (static-arg-types (list (get-entity-type r-value))))
	      (make-hrecord <proc-appl>
			    tc-class
			    ;; Should we set type-dispatched? = #t?
			    type-dispatched?
			    ;; Should we set exact-type? = #t?
			    #f
			    '()
			    pure-args?
			    #f
			    (not type-dispatched?)
			    '()
			    always-returns?
			    never-returns?
			    tp-class-of
			    arguments
			    '()
			    static-arg-types
			    #f
			    '()))))
      (raise 'class-of:invalid-number-of-arguments)))


(define (translate-is-subtype-appl binder proc arguments type-check?
				   inside-param-def?)
  (assert (is-binder? binder))
  (assert (is-entity? proc))
  (assert (and (list? arguments)
	       (and-map? is-entity? arguments)))
  (assert (boolean? inside-param-def?))
  (check-no-none-arguments binder arguments 'is-subtype?)
  (if (= (length arguments) 2)
      (let* ((r-type1 (car arguments))
	     (r-type2 (cadr arguments))
	     (free-tvars?
	      (or
	       (contains-free-tvars-general-fwd? r-type1)
	       (contains-free-tvars-general-fwd? r-type2))))
	(cond
	 ((and type-check? (not inside-param-def?) free-tvars?)
	  (raise 'illegal-free-type-variables))
	 ((and (not free-tvars?) 
	       (and-map? is-known-pure-entity? arguments))
	  ;; TBD: use get-entity-value in the following statement.
	  (if (and (is-type2? binder r-type1)
		   (is-type2? binder r-type2))
	      (make-primitive-object
	       tc-boolean
	       (is-t-subtype? binder r-type1 r-type2))
	      (raise 'is-subtype?:not-a-type)))
	 (else
	  (let ((pure-args? (and-map? is-pure-entity? arguments))
		(static-arg-types (map get-entity-type arguments))
		(correct-types? 
		 (and (is-type-repr2? binder r-type1)
		      (is-type-repr2? binder r-type2))))
	    (make-hrecord <proc-appl>
			  tc-boolean
			  #t
			  #t
			  '()
			  pure-args?
			  #f
			  (not correct-types?)
			  '()
			  ;; No need to check proc here for
			  ;; special procedures.
			  (and (entity-always-returns? r-type1)
			       (entity-always-returns? r-type2))
			  (or (entity-never-returns? r-type1)
			      (entity-never-returns? r-type2))
			  tp-is-subtype
			  arguments
			  '()
			  static-arg-types
			  (not correct-types?)
			  '())))))
      (raise 'is-subtype?:invalid-number-of-arguments)))


(define (translate-is-instance-appl binder proc arguments
				    type-check? inside-param-def?)
  (assert (is-binder? binder))
  (assert (is-entity? proc))
  (assert (and (list? arguments)
	       (and-map? is-entity? arguments)))
  (check-no-none-arguments binder arguments 'is-instance?)
  (if (= (length arguments) 2)
      (let* ((r-object (car arguments))
	     (r-type (cadr arguments))
	     (r-object-type (get-entity-type r-object))
	     (type-dispatched? (entity-type-dispatched? r-object))
	     ;; TBD: should we change this: 
	     ;; (contains-free-tvars?
	     ;;  (or (contains-free-tvars-general-fwd? r-object-type)
	     ;; 	  (contains-free-tvars-general-fwd? r-type))))
	     (free-tvars?
	      (contains-free-tvars-fwd? r-type)))
	(cond
	 ((and type-check? (not inside-param-def?) (not type-dispatched?))
	  (raise 'is-instance:invalid-object-type))
	 ((and type-check? (not inside-param-def?) free-tvars?)
	  (raise 'invalid-free-type-variables))
	 ((and
	   (and-map? is-known-pure-entity? arguments)
	   type-dispatched?
	   (not free-tvars?))
	  ;; The following check should never fail.	
	  (assert (is-type2? binder r-object-type))
	  ;; TBD: use the value of r-type in the following.
	  (if (is-type2? binder r-type)
	      (make-primitive-object
	       tc-boolean
	       (is-t-subtype? binder
			      r-object-type
			      r-type))
	      (raise 'is-instance?:not-a-type)))
	 (else
	  (let ((pure-args? (and-map? is-pure-entity? arguments))
		(static-arg-types (map get-expr-type arguments))
		(correct-type? (is-type-repr2? binder r-type)))
	    (make-hrecord <proc-appl>
			  tc-boolean
			  #t
			  #t
			  '()
			  ;; TBD: Change the following to pure-args?.
			  #t
			  #f
			  (not correct-type?)
			  '()
			  (and (entity-always-returns? r-object)
			       (entity-always-returns? r-type))
			  (or (entity-never-returns? r-object)
			      (entity-never-returns? r-type))
			  tp-is-instance
			  arguments
			  '()
			  static-arg-types
			  (not correct-type?)
			  '())))))
      (raise 'is-instance?:invalid-number-of-arguments)))


(define (translate-tuple-ref-appl binder arguments
				  type-check? inside-param-def?)
  (assert (is-binder? binder))
  (strong-assert (and (list? arguments)
		      (and-map? is-entity? arguments)
		      (= (length arguments) 2)))
  (check-no-none-arguments binder arguments 'tuple-ref)
  (let* ((r-tuple (car arguments))
	 (r-type (get-entity-type r-tuple))
	 (r-index (cadr arguments))
	 (tuple-type? (is-tuple-type? binder r-type))
	 (pure-args? (and-map? is-pure-entity? arguments))
	 (static-arg-types (map get-entity-type arguments))
	 (type-dispatched? (hfield-ref r-tuple 'type-dispatched?)))
;;	 (contains-free-tvars? (contains-free-tvars-fwd? r-type)))
    (cond
     ((and type-check? (not inside-param-def?)
	   ;;	   (not contains-free-tvars?)
	   type-dispatched?
	   (not tuple-type?))
      (raise (list 'tuple-ref:not-a-tuple (cons 'tt r-type))))
     ((and type-check? (not inside-param-def?)
	   (not (and (is-t-subtype? binder (get-entity-type r-index)
				    tc-integer)
		     (is-t-primitive-object? r-index))))
      (raise 'tuple-ref:index-not-an-integer-constant))
     ;;     ((or (not type-check?) contains-free-tvars?)
     ((or (not type-dispatched?)
	  (and inside-param-def?
	       (or (contains-free-tvars-fwd? r-type)
		   (contains-free-tvars-fwd? (get-entity-type r-index)))))
      (make-hrecord <proc-appl>
		    tc-object
		    #f
		    #f
		    '()
		    pure-args?
		    #f
		    #t
		    '()
		    (and (entity-always-returns? r-tuple)
			 (entity-always-returns? r-index))
		    (or (entity-never-returns? r-tuple)
			(entity-never-returns? r-index))
		    tp-tuple-ref
		    arguments
		    '()
		    '()
		    #t
		    '()))
     (else
      (let ((index (hfield-ref r-index 'obj-prim-contents)))
	;; assert might be sufficient.
	(strong-assert (integer? index))
	(let ((r-element-type (tuple-type-ref r-type index)))
	  (make-hrecord <proc-appl>
			r-element-type
			#t
			(is-final-class? binder r-element-type)
			'()
			pure-args?
			#f
			#f
			'()
			(and (entity-always-returns? r-tuple)
			     (entity-always-returns? r-index))
			(or (entity-never-returns? r-tuple)
			    (entity-never-returns? r-index))
			tp-tuple-ref
			arguments
			'()
			static-arg-types
			#f
			'())))))))


(define (translate-make-vector-appl binder
				    proc arguments mutable? eq-by-value?
				    type-check? inside-param-def?)
  (assert (is-binder? binder))
  (assert (is-entity? proc))
  (assert (and (list? arguments)
	       (and-map? is-entity? arguments)))
  (assert (boolean? mutable?))
  (assert (boolean? eq-by-value?))
  (assert (boolean? type-check?))
  (assert (boolean? inside-param-def?))
  (check-no-none-arguments binder arguments
			   (if mutable?
			       (if eq-by-value?
				   'make-mutable-value-vector
				   'make-mutable-vector)
			       (if eq-by-value?
				   'make-value-vector
				   'make-vector)))
  (if (= (length arguments) 3)
      (let* ((r-type (car arguments))
	     (r-element-value (caddr arguments))
	     (r-value-type (get-entity-type r-element-value))
	     (r-size (cadr arguments))
	     (r-size-type (get-entity-type r-size))
	     (free-tvars-type? (contains-free-tvars-general-fwd? r-type))
	     (free-tvars-size? (contains-free-tvars-general-fwd? r-size-type))
	     (element-type-dispatched?
	      (entity-type-dispatched? r-element-value)))
	(cond
	 ((and type-check? (entity-is-none1? binder r-type))
	  (raise 'make-x-vector:none-element-type))
	 ;; ((entity-is-none1? binder r-value-type)
	 ;;  (raise 'make-x-vector:none-value-type))
	 ((and type-check? (not inside-param-def?)
	       (not (is-t-instance? binder r-type tt-type)))
	  (raise 'make-x-vector:invalid-type))
	 ((and type-check? (not inside-param-def?)
	       (not (is-t-subtype? binder r-size-type tc-integer)))
	  (dvar1-set! r-size-type)
	  (dvar2-set! arguments)
	  (raise 'make-x-vector:invalid-size))
	 ((and type-check? (not inside-param-def?)
	       (not element-type-dispatched?))
	  (raise 'illegal-undispatched-type))
	 ((and type-check? (not inside-param-def?)
	       (not (is-t-subtype? binder r-value-type r-type)))
	  (raise 'make-x-vector:element-type-mismatch))
	 (else
	  (let ((pure-args? (and-map? is-pure-entity? arguments))
		(static-arg-types (map get-entity-type arguments))
		(result-type
		 (if eq-by-value?
		     (if mutable?
			 (translate-mutable-value-vector-expression0 r-type)
			 (translate-value-vector-expression0 r-type))
		     (if mutable?
			 (translate-mutable-vector-expression0 r-type)
			 (translate-vector-expression0 r-type))))
		(correct-types?
		 (or (not inside-param-def?)
		     (and
		      element-type-dispatched?
		      (not free-tvars-type?)
		      (not free-tvars-size?)
		      (is-t-instance? binder r-type tt-type)
		      (is-t-subtype? binder r-size-type tc-integer)
		      (is-t-subtype? binder r-value-type r-type)))))
	    (make-hrecord <proc-appl>
			  result-type
			  #t
			  (is-final-class? binder result-type)
			  '()
			  pure-args?
			  #f
			  (not correct-types?)
			  '()
			  (and-map? entity-always-returns? arguments)
			  (or-map? entity-never-returns? arguments)
			  (if eq-by-value?
			      (if mutable?
				  tp-make-mutable-value-vector
				  tp-make-value-vector)
			      (if mutable?
				  tp-make-mutable-vector
				  tp-make-vector))
			  arguments
			  '()
			  static-arg-types
			  (not correct-types?)
			  '())))))
      (raise 'make-x-vector:invalid-number-of-arguments)))


(define (translate-vector-appl binder
			       proc arguments mutable? eq-by-value?
			       type-check? inside-param-def?)
  (assert (is-binder? binder))
  (assert (is-entity? proc))
  (assert (and (list? arguments)
	       (and-map? is-entity? arguments)))
  (assert (boolean? mutable?))
  (assert (boolean? eq-by-value?))
  (assert (boolean? type-check?))
  (assert (boolean? inside-param-def?))
  (check-no-none-arguments binder arguments
			   (if mutable?
			       (if eq-by-value?
				   'mutable-value-vector
				   'mutable-vector)
			       (if eq-by-value?
				   'value-vector
				   'vector)))
  (if (null? arguments)
      (raise 'x-vector:invalid-number-of-arguments)
      (let* ((element-types (map get-entity-type (cdr arguments)))
	     (type-dispatched?
	      (and-map? entity-type-dispatched? (cdr arguments)))
	     (result-element-type (car arguments))
	     (free-tvars-type?
	      (contains-free-tvars-general-fwd? result-element-type)))
	(cond
	 ((and type-check? (entity-is-none1? binder result-element-type))
	  (raise 'x-vector:none-element-type))
	 ;; ((or-map? (lambda (type)
	 ;; 	     (entity-is-none1? binder type))
	 ;; 	   element-types)
	 ;;  (raise 'x-vector:none-value))
	 ((and type-check? (not inside-param-def?)
	       (not type-dispatched?))
	  (raise 'illegal-undispatched-type))
	 ((and type-check? (not inside-param-def?)
	       (not (is-t-instance? binder result-element-type tt-type)))
	  (raise 'x-vector:invalid-type))
	 ((and type-check? (not inside-param-def?)
	       (not (and-map? (lambda (type)
				(is-t-subtype?
				 binder
				 type
				 result-element-type))
			      element-types)))
	  (dvar1-set! binder)
	  (dvar2-set! result-element-type)
	  (dvar3-set! element-types)
	  (raise 'x-vector:type-mismatch))
	 (else
	  (let ((result-type
		 (if eq-by-value?
		     (if mutable?
			 (translate-mutable-value-vector-expression0
			  result-element-type)
			 (translate-value-vector-expression0
			  result-element-type))
		     (if mutable?
			 (translate-mutable-vector-expression0
			  result-element-type)
			 (translate-vector-expression0
			  result-element-type))))
		(static-arg-types (map get-entity-type arguments))
		(pure-args? (and-map? is-pure-entity? arguments))
		(correct-types?
		 (or (not inside-param-def?)
		     (and
		      type-dispatched?
		      (not free-tvars-type?)
		      (is-t-instance? binder result-element-type tt-type)
		      (and-map? (lambda (type)
				  (is-t-subtype?
				   binder
				   type
				   result-element-type))
				element-types)))))
	    (make-hrecord <proc-appl>
			  result-type
			  #t
			  #t
			  '()
			  pure-args?
			  #f
			  (not correct-types?)
			  '()
			  (and-map? entity-always-returns? arguments)
			  (or-map? entity-never-returns? arguments)
			  (if eq-by-value?
			      (if mutable?
				  tp-mutable-value-vector
				  tp-value-vector)
			      (if mutable?
				  tp-mutable-vector
				  tp-vector))
			  arguments
			  '()
			  static-arg-types
			  (not correct-types?)
			  '())))))))


(define (get-cast-target-type mutable? value-vector? element-type)
  (assert (boolean? mutable?))
  (assert (boolean? value-vector?))
  (cond
   ((and (not mutable?) (not value-vector?))
    (translate-vector-expression0 element-type))
   ((and (not mutable?) value-vector?)
    (translate-value-vector-expression0 element-type))
   ((and mutable? (not value-vector?))
    (translate-mutable-vector-expression0 element-type))
   ((and mutable? value-vector?)
    (translate-mutable-value-vector-expression0 element-type))
   (else
    ;; We should never arrive here.
    (raise 'internal-error))))


(define (get-cast-obj mutable? value-vector? opt?)
  (assert (boolean? mutable?))
  (assert (boolean? value-vector?))
  (assert (boolean? opt?))
  (if (not opt?)
      (cond
       ((and (not mutable?) (not value-vector?))
	tp-cast-vector)
       ((and (not mutable?) value-vector?)
	tp-cast-value-vector)
       ((and mutable? (not value-vector?))
	tp-cast-mutable-vector)
       ((and mutable? value-vector?)
	tp-cast-mutable-value-vector)
       (else
	;; We should never arrive here.
	(raise 'internal-error)))
      (cond
       ((and (not mutable?) (not value-vector?))
	tp-cast-vector0)
       ((and (not mutable?) value-vector?)
	tp-cast-value-vector0)
       ((and mutable? (not value-vector?))
	tp-cast-mutable-vector0)
       ((and mutable? value-vector?)
	tp-cast-mutable-value-vector0)
       (else
	;; We should never arrive here.
	(raise 'internal-error)))))


(define (get-metacast-obj mutable? value-vector?)
  (assert (boolean? mutable?))
  (assert (boolean? value-vector?))
  (cond
   ((and (not mutable?) (not value-vector?))
    tp-cast-vector-metaclass)
   ((and (not mutable?) value-vector?)
    tp-cast-value-vector-metaclass)
   ((and mutable? (not value-vector?))
    tp-cast-mutable-vector-metaclass)
   ((and mutable? value-vector?)
    tp-cast-mutable-value-vector-metaclass)
   (else
    ;; We should never arrive here.
    (raise 'internal-error))))


(define (is-vector-metaclass? binder to-clas)
  (or (is-t-instance? binder to-clas tpc-vector)
      (is-t-instance? binder to-clas tpc-mutable-vector)
      (is-t-instance? binder to-clas tpc-value-vector)
      (is-t-instance? binder to-clas tpc-mutable-value-vector)))


(define (translate-cast-vector-appl binder
				    proc arguments mutable? value-vector?
				    type-check? inside-param-def?)
  (assert (is-binder? binder))
  (assert (is-entity? proc))
  (assert (and (list? arguments)
	       (and-map? is-entity? arguments)))
  (assert (boolean? type-check?))
  (assert (boolean? inside-param-def?))
  (check-no-none-arguments binder arguments
			   (if mutable?
			       (if value-vector?
				   'cast-mutable-value-vector
				   'cast-mutable-vector)
			       (if value-vector?
				   'cast-value-vector
				   'cast-vector)))
  (if (= (length arguments) 2)
      (let* ((source-vector (cadr arguments))
	     (source-vector-type (get-entity-type source-vector))
	     (vec? (is-vector-metaclass? binder source-vector-type))
	     (target-element-type (car arguments))
	     (type-dispatched?
	      (and (entity-type-dispatched? source-vector)
		   (entity-type-dispatched? target-element-type))))
	(cond
	 ((and type-check? (not inside-param-def?) (not type-dispatched?))
	  (raise 'illegal-undispatched-type))
	 ((and type-check? (not inside-param-def?) (not vec?))
	  (raise 'cast-x-vector:not-a-vector))
	 ((and type-check? (not inside-param-def?)
	       (not (is-t-instance? binder target-element-type tt-type)))
	  (raise 'cast-x-vector:invalid-target-type))
	 (else
	  (let* ((target-type (get-cast-target-type mutable? value-vector?
						    target-element-type))
		 (pure-args? (and-map? is-pure-entity? arguments))
		 (static-arg-types (map get-entity-type arguments))
		 (opt? (and vec?
			    (is-t-subtype? binder
					   (get-vector-class-element-type
					    source-vector-type)
					   target-element-type)))
		 (target-procedure (get-cast-obj mutable? value-vector?
						 opt?))
		 (correct-types?
		  (or (not inside-param-def?)
		      (and type-dispatched?
			   vec?
			   (not (contains-free-tvars-general-fwd?
				 target-element-type))
			   (is-t-subtype? binder target-element-type
					  tt-type)))))
	    (make-hrecord <proc-appl>
			  target-type
			  #t
			  ;; Think about exact-type?
			  ;; The runtime type of the target shall be
			  ;; (:vector target-element-type)
			  ;; even though the runtime types of the vector
			  ;; elements may be subtypes of target-element-type.
			  #t
			  '()
			  pure-args?
			  #f
			  (not correct-types?)
			  '()
			  (and-map? entity-always-returns? arguments)
			  (or-map? entity-never-returns? arguments)
			  target-procedure
			  arguments
			  '()
			  static-arg-types
			  (not correct-types?)
			  '())))))
      (begin
	(dvar1-set! proc)
	(dvar2-set! arguments)
	(raise 'cast-x-vector:invalid-number-of-arguments))))


(define (translate-cast-vector-metaclass binder
					 proc arguments mutable? value-vector?
					 type-check? inside-param-def?)
  (assert (is-binder? binder))
  (assert (is-entity? proc))
  (assert (and (list? arguments)
	       (and-map? is-entity? arguments)))
  (assert (boolean? type-check?))
  (assert (boolean? inside-param-def?))
  (check-no-none-arguments binder arguments
			   (if mutable?
			       (if value-vector?
				   'cast-mutable-value-vector-metaclass
				   'cast-mutable-vector-metaclass)
			       (if value-vector?
				   'cast-value-vector-metaclass
				   'cast-vector-metaclass)))
  (if (= (length arguments) 1)
      (let* ((source-vector (car arguments))
	     (source-vector-type (get-entity-type source-vector))
	     (type-dispatched? (entity-type-dispatched? source-vector))
	     (vec? (is-vector-metaclass? binder source-vector-type))
	     (target-procedure (get-metacast-obj mutable? value-vector?))
	     (static-arg-types (map get-entity-type arguments))
	     (pure-args? (is-pure-entity? source-vector)))
	(cond
	 ((and type-check? (not inside-param-def?) (not vec?))
	  (raise 'cast-vector-metaclass:not-a-vector))
	 ((and type-check? (not inside-param-def?) (not type-dispatched?))
	  (raise 'illegal-undispatched-type))
	 (else
	  (let ((target-type
		 (if vec?
		     (let ((element-type (get-vector-class-element-type
					  source-vector-type)))
		       (get-cast-target-type mutable? value-vector?
					     element-type))
		     tc-object))
		(correct-types?
		 (or (not inside-param-def?)
		     (and type-dispatched?
			  vec?
			  (not (contains-free-tvars-fwd?
				source-vector-type))))))
	    (make-hrecord <proc-appl>
			  target-type
			  type-dispatched?
			  ;; Think about exact-type?
			  ;; The runtime type of the target shall be
			  ;; (:vector target-element-type)
			  ;; even though the runtime types of the vector
			  ;; elements may be subtypes of target-element-type.
			  #t
			  '()
			  pure-args?
			  #f
			  (not correct-types?)
			  '()
			  (and-map? entity-always-returns? arguments)
			  (or-map? entity-never-returns? arguments)
			  target-procedure
			  arguments
			  '()
			  static-arg-types
			  (not correct-types?)
			  '())))))
      (raise 'cast-x-vector-metaclass:invalid-number-of-arguments)))

