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


;; *** Translation of expressions ***


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


(define contains-only-specified-unbound-tvars-fwd? '())


;;define bind-type-vars1-fwd '())


(define gl-stop? #f)


(define gl-flag6? #f)


(define gl-counter2 0)


(define (translate-if-expression
	 binder
	 condition-expr then-expr else-expr
	 boolean-cond?
	 do-type-check?)
  (assert (is-binder? binder))
  (let ((pure-cond? (is-pure-entity? condition-expr)))
    (cond
     ((and boolean-cond? pure-cond? (is-t-true? condition-expr))
      then-expr)
;;     ((and (not boolean-cond?) pure-cond? (not (is-t-false? condition-expr)))
;;      then-expr)
     ((and pure-cond? (is-t-false? condition-expr))
      else-expr)
     ((or (not do-type-check?)
	  (or (not boolean-cond?)
	      (target-type=? (get-entity-type condition-expr)
			     tc-boolean)))
      (let* ((type1 (get-entity-type then-expr))
	     (type2 (get-entity-type else-expr))
	     (type
	      (cond
	       ((target-type=? type1 type2) type1)
	       (else (get-union-type-from-expressions
		      binder
		      (list then-expr else-expr)))))
	     (exact-type?
	      (and
	       do-type-check?
	       (is-t-instance? binder type tc-class)
	       (not (tno-field-ref type 'inheritable?))))
	     (pure?
	      (and
	       pure-cond?
	       (is-pure-entity? then-expr)
	       (is-pure-entity? else-expr)))
	     (value '())
	     (type-dispatched?
	      (and (entity-type-dispatched? then-expr)
		   (entity-type-dispatched? else-expr)))
	     (always-returns?
	      (and (entity-always-returns? condition-expr)
		   (and (entity-always-returns? then-expr)
			(entity-always-returns? else-expr))))
	     (never-returns?
	      (or (entity-never-returns? condition-expr)
		  (and (entity-never-returns? then-expr)
		       (entity-never-returns? else-expr)))))
	(make-hrecord
	 <if-form>
	 type
	 type-dispatched?
	 exact-type?
	 '()
	 pure? #f
	 (not do-type-check?)
	 value
	 always-returns?
	 never-returns?
	 condition-expr then-expr else-expr
	 boolean-cond?)))
     (else (begin (dvar1-set! condition-expr) (raise 'invalid-if-condition))))))


;; The following procedure should also work for general procedure
;; applications.
(define (translate-simple-proc-appl-expression binder
					       proc arg-list static-arg-types
					       type-check?
					       inside-param-def?
					       runtime-arglist-typecheck?)
  (assert (is-binder? binder))
  (assert (is-entity? proc))
  (assert (list? arg-list))
  (assert (and-map? is-entity? arg-list))
  (assert (or (eq? static-arg-types #f)
	      (and (list? static-arg-types)
		   (and-map? is-entity? static-arg-types))))
  (assert (boolean? type-check?))
  (assert (boolean? inside-param-def?))
  (assert (boolean? runtime-arglist-typecheck?))
  (let* ((proc-type (get-entity-type proc))
	 (static-arg-types1
	  (if (eq? static-arg-types #f)
	      (map get-expr-type arg-list)
	      static-arg-types))
	 ;; (type-dispatched?
	 ;;  (and (entity-type-dispatched? proc)
	 ;;       (and-map? entity-type-dispatched? arg-list)))
	 (type-dispatched? (entity-type-dispatched? proc))
	 (arg-list-type-dispatched?
	  (and-map? entity-type-dispatched? arg-list))
	 (always-returns?
	  (and
	   (tno-field-ref proc-type 'appl-always-returns?)
	   (entity-always-returns? proc)
	   (and-map? entity-always-returns? arg-list)))
	 (never-returns?
	  (or
	   (tno-field-ref proc-type 'appl-never-returns?)
	   (entity-never-returns? proc)
	   (or-map? entity-never-returns? arg-list)))
	 (pure-proc? (tno-field-ref proc-type 'pure-proc?))
	 (pure-args?
	  (and-map? is-pure-entity? arg-list))
	 (pure? (and pure-proc? pure-args?)))
    (let* ((arg-list-type (tno-field-ref proc-type 'type-arglist))
	   (l-arg-types (map get-entity-type arg-list))
	   (l-sgn (pick-signatures l-arg-types))
	   (contains-sgn? (not-null? l-sgn))
	   (arg-free-tvars? (contains-free-tvars-general? l-arg-types))
	   (correct-sgn?
	    (if contains-sgn?
		(if arg-free-tvars?
		    ;; Argument list types are checked runtime
		    ;; in case they contain free type variables.
		    #t
		    (if (is-target-object? proc)
			(let ((p-match (match-call-with-signatures binder proc
								   l-arg-types
								   l-sgn)))
			  (cond
			   ((not-null? (car p-match)) #t)
			   ((not (cdr p-match)) #f)
			   (else
			    (raise 'type-mismatch-with-signatures))))
			#f))
		#f))
	   (result-type (tno-field-ref proc-type 'type-result))
	   (tt-actual-arglist
	    (translate-actual-arglist-type arg-list)))
      (cond
       ((and type-check? (not inside-param-def?)
	     (or (not type-dispatched?)
		 (not arg-list-type-dispatched?)))
	(raise 'illegal-nondispatched-proc-appl))
       ((not type-dispatched?)
	(make-hrecord <proc-appl>
		      result-type
		      #f
		      #f
		      '()
		      pure?
		      #f
		      (not type-check?)
		      '()
		      always-returns?
		      never-returns?
		      proc
		      arg-list
		      '()
		      '()
		      #t
		      '()))
       ((and contains-sgn? arg-free-tvars?)
	(make-hrecord <proc-appl>
		      result-type
		      #t
		      #f
		      '()
		      pure?
		      #f
		      (not type-check?)
		      '()
		      always-returns?
		      never-returns?
		      proc
		      arg-list
		      '()
		      static-arg-types1
		      #t
		      '()))
       ((or (not type-check?)
	    correct-sgn?
	    (not arg-list-type-dispatched?)
	    (and inside-param-def?
	    	 (or
	    	  (contains-free-tvars-fwd? tt-actual-arglist)
	    	  (contains-free-tvars-fwd? arg-list-type))))
	;; Maybe we could omit the runtime typecheck in case correct-sgn?
	;; is #t.
	(let ((final?
	       (and (is-t-instance? binder result-type
				    tc-class)
		    (not
		     (tno-field-ref result-type 'inheritable?)))))
	  (make-hrecord <proc-appl>
			result-type
			#t
			final?
			'()
			pure?
			#f
			(not type-check?)
			'()
			always-returns?
			never-returns?
			proc
			arg-list
			'()
			static-arg-types1
			runtime-arglist-typecheck?
			'())))	
       ((check-arglist-types? binder
			      tt-actual-arglist arg-list-type)
	(let ((final?
	       (and (is-t-instance? binder result-type
				    tc-class)
		    (not
		     (tno-field-ref result-type 'inheritable?)))))
	  (make-hrecord <proc-appl>
			result-type
			#t
			final?
			'()
			pure?
			#f
			(not type-check?)
			'()
			always-returns?
			never-returns?
			proc
			arg-list
			'()
			static-arg-types1
			#f
			'())))
       (else
	(raise
	 (let* ((to-proc (get-entity-value proc))
		(s-proc-name
		 (if (not-null? to-proc)
		     (let ((s-name1
			    (if (is-known-object? to-proc)
				(tno-field-ref to-proc 's-u-name)
				'())))
		       (if (not-null? s-name1)
			   s-name1
			   (let ((address (hfield-ref to-proc 'address)))
			     (if (and (not-null? address)
				      (not-null? (hfield-ref address
							     'source-name)))
				 (hfield-ref address 'source-name)
				 '()))))
		     '())))
	   (list 'type-mismatch-in-proc-appl s-proc-name
		 (cons 'actual-type tt-actual-arglist)
		 (cons 'declared-type arg-list-type)))))))))


(define (translate-simple-proc-appl-expression1 binder
						proc arg-list static-arg-types
						type-check?
						inside-param-def?
						runtime-arglist-typecheck?)
  (if (and (not-null? arg-list)
	   (contains-none-value? binder arg-list))
      (raise (list
	      'procedure-argument-with-type-none
	      (cons 's-proc-name
		    (let ((address (hfield-ref proc 'address)))
		      (if (not-null? address)
			  (hfield-ref address 'source-name)
			  '())))))
      (translate-simple-proc-appl-expression binder proc arg-list
					     static-arg-types
					     type-check?
					     inside-param-def?
					     runtime-arglist-typecheck?)))


(set! translate-simple-proc-appl-expression1-fwd
      translate-simple-proc-appl-expression1)


(define (get-type-var-values-from-deductions type-vars deductions)
  (let* ((bindings (hfield-ref deductions 'bindings))
	 (result
	  (map* (lambda (tvar) (cdr (assoc tvar bindings type-variable=?)))
		type-vars)))
;;    (check-no-none-types result)
    result))


(set! get-type-var-values-from-deductions-fwd
      get-type-var-values-from-deductions)


(define (get-type-var-values-from-deductions2 type-vars deductions)
  (let* ((bindings (hfield-ref deductions 'bindings))
	 (result
	  (map*
	   (lambda (tvar)
	     (let ((b (assoc tvar bindings type-variable=?)))
	       (if (not (eqv? b #f))
		   (cdr b)
		   tvar)))
	   type-vars)))
;;    (check-no-none-types result)
    result))


(set! get-type-var-values-from-deductions2-fwd
      get-type-var-values-from-deductions2)


(define	(make-tvars-unique binder type-vars inst-type)
  (assert (hrecord-is-instance? binder <binder>))
  (assert (and (list? type-vars) (and-map? is-t-type-variable? type-vars))) 
  (assert (is-entity? inst-type))
  (let ((old-debug? gl-show-indented-debug-info?))
;;    (set! gl-show-indented-debug-info? #f
    ;; We can use same name for the generated type variables
    ;; since they will get distinct addresses, though.
    (let* ((alloc-loc (hfield-ref binder 'allocate-variable))
	   (bindings (map (lambda (old-tvar)
			    (cons old-tvar
				  (let ((new-tvar
					 (make-type-variable
					  (alloc-loc 'g1 #f))))
				    new-tvar)))
			  type-vars)))
      (let ((result
	     (cons
	      (bind-type-vars-no-check binder bindings inst-type)
	      (map cdr bindings))))
	(set! gl-show-indented-debug-info? old-debug?)
      result))))


(set! make-tvars-unique-fwd make-tvars-unique)


(define (translate-normal-param-proc-appl2 binder
					   e-proc arglist
					   r-inst-type r-arg-types
					   r-type-var-values
					   pure?
					   always-returns?
					   never-returns?
					   l-default-params)
  (assert (is-binder? binder))
  (assert (is-entity? r-inst-type))
  (assert (and (list? r-type-var-values)
	       (and-map? is-entity? r-type-var-values)))
  (assert (boolean? pure?))
  (assert (boolean? always-returns?))
  (assert (boolean? never-returns?))
  (let ((result-type (tno-field-ref r-inst-type 'type-result))
	(arg-list-type (tno-field-ref r-inst-type 'type-arglist))
	(tt-actual-arglist (get-arglist-type-from-list r-arg-types)))
    (cond
     ((null? tt-actual-arglist)
      (raise 'internal-null-argument-list))
     ((check-arglist-types?
       binder tt-actual-arglist arg-list-type)
      ;;    (let ((static-arg-types (map get-expr-type arglist))
      (let ((exact-type?
	     (and
	      (not (is-t-type-variable? result-type))
	      (is-t-instance? binder result-type tc-class)
	      (not (tno-field-ref result-type 'inheritable?)))))
	;; need-revision? = #f
	(make-hrecord <proc-appl>
		      result-type
		      #t exact-type? '()
		      pure? #f #f '()
		      always-returns? never-returns?
		      e-proc arglist r-type-var-values
		      ;; static-arg-types
		      r-arg-types
		      #f
		      l-default-params)))
     (else
      (dvar1-set! tt-actual-arglist)
      (dvar2-set! arg-list-type)
      (dvar3-set! e-proc)
      (dvar4-set! arglist)
      (raise (list 'type-mismatch-in-param-proc-appl-1
		   (cons 'actual-type tt-actual-arglist)
		   (cons 'declared-type arg-list-type)))))))


(define (translate-param-proc-appl-inside-param binder
						e-proc arglist
						type-dispatched?
						r-inst-type r-arg-types
						r-type-var-values
						pure?
						always-returns?
						never-returns?
						l-default-params)
  (assert (is-binder? binder))
  (assert (is-entity? r-inst-type))
  (assert (and (list? r-type-var-values)
	       (and-map? is-entity? r-type-var-values)))
  (assert (boolean? pure?))
  (assert (boolean? always-returns?))
  (assert (boolean? never-returns?))
  (assert (and (list? l-default-params)
	       (and-map? is-entity? l-default-params)))
  (let* ((arg-list-type (tno-field-ref r-inst-type 'type-arglist))
	 (tt-actual-arglist (get-arglist-type-from-list r-arg-types))
	 (result-type (tno-field-ref r-inst-type 'type-result))
	 (exact-type? (is-final-class? binder result-type))
	 (free-tvars?
	  (or
	   (contains-type-variables-fwd? arg-list-type)
	   (contains-type-variables-fwd? tt-actual-arglist))))
    (cond
     ((and
       type-dispatched?
       (not free-tvars?)
       (not (check-arglist-types?
	     binder tt-actual-arglist arg-list-type)))
      (raise 'param-proc-appl-type-mismatch))
     (type-dispatched?
      (make-hrecord
       <proc-appl>
       result-type
       type-dispatched? exact-type? '()
       pure? #f #t
       '() always-returns? never-returns?
       e-proc arglist '()
       ;; (map get-entity-type arglist)
       r-arg-types
       #f
       l-default-params))
     (else
      (make-hrecord
       <proc-appl>
       result-type
       type-dispatched? exact-type? '()
       pure? #f #t
       '() always-returns? never-returns?
       e-proc arglist '()
       (map get-entity-type arglist)
       #t
       l-default-params)))))


(define (make-general-gen-proc-appl binder gen-proc
				    arglist result-type
				    type-dispatched?
				    pure?
				    always-returns?
				    never-returns?
				    type-check?)
  (assert (is-binder? binder))
  (assert (is-entity? gen-proc))
  (assert (and (list? arglist)
	       (and-map? is-entity? arglist)))
  (assert (is-entity? result-type))
  (assert (boolean? type-dispatched?))
  (assert (boolean? pure?))
  (assert (boolean? type-check?))
  (let ((static-arg-types (map get-expr-type arglist)))
    (make-hrecord <proc-appl>
		  result-type
		  type-dispatched?
		  (is-final-class? binder result-type)
		  '()
		  pure?
		  #f
		  (not type-check?)
		  '()
		  always-returns?
		  never-returns?
		  gen-proc
		  arglist
		  '()
		  static-arg-types
		  #f
		  '())))


(define (make-dynamic-param-proc-appl binder to-param-proc
				      arglist result-type
				      type-dispatched?
				      pure?
				      always-returns?
				      never-returns?
				      type-check?)
  (assert (is-binder? binder))
  (assert (is-entity? to-param-proc))
  (assert (and (list? arglist)
	       (and-map? is-entity? arglist)))
  (assert (is-entity? result-type))
  (assert (boolean? type-dispatched?))
  (assert (boolean? pure?))
  (assert (boolean? type-check?))
  (make-hrecord <proc-appl>
		result-type
		type-dispatched?
		(is-final-class? binder result-type)
		'()
		pure?
		#f
		(not type-check?)
		'()
		always-returns?
		never-returns?
		to-param-proc
		arglist
		'()
		'()
		#t
		'()))


(define (translate-matched-proc-appl-with-sgn binder to-proc arglist
					      tt-match param?)
  (let* ((expr-result-type (tno-field-ref tt-match 'type-result))
	 (type-dispatched? (and-map? entity-type-dispatched?
				     arglist))
	 (pure-args? (and-map? is-pure-entity? arglist))
	 (pure-proc? (tno-field-ref tt-match 'pure-proc?))
	 (pure? (and pure-args? pure-proc?))
	 (always-returns?
	  (and (tno-field-ref tt-match 'appl-always-returns?)
	       (and-map? entity-always-returns? arglist)))
	 (never-returns?
	  (or (tno-field-ref tt-match 'appl-never-returns?)
	      (or-map? entity-never-returns? arglist))))
    ((if param?
	 make-dynamic-param-proc-appl
	 make-general-gen-proc-appl)
     binder
     to-proc
     arglist
     expr-result-type
     type-dispatched?
     pure?
     always-returns?
     never-returns?
     #t)))


(define (translate-unresolved-proc-appl-with-sgn binder to-proc arglist param?)
  ((if param?
       make-dynamic-param-proc-appl
       make-general-gen-proc-appl)
   binder
   to-proc
   arglist
   tc-object
   #f
   #f
   #f
   #f
   #t))


(define (get-proc-name2 e-proc)
  (let ((address (hfield-ref e-proc 'address)))
    (if (not-null? address)
	(hfield-ref address 'source-name)
	'())))


(define (do-translate-param-proc-appl0 binder inside-param-def?
				       type-dispatched?
				       e-proc arglist l-default-params
				       ppc inst-type
				       pure? always-returns? never-returns?)
  (assert (not-null? inst-type))
  (let* ((arg-types (map get-entity-type arglist))
	 (type-vars (tno-field-ref ppc 'l-tvars))
	 ;; We make sure that the type variables in the instance
	 ;; type are unique, i.e. they don't appear in the
	 ;; procedure expression or in the arguments.
	 ;; Does calling contains-specified-tvars-fwd? have
	 ;; any reason?
	 (uniq
	  (if (contains-specified-tvars-fwd? inst-type
					     type-vars)
	      (make-tvars-unique binder type-vars inst-type)
	      (cons inst-type type-vars)))
	 (inst-type1 (car uniq))
	 (new-type-vars (cdr uniq))
	 (new-arg-types (make-tvars-unique2 binder arg-types))
	 (src-tvars (get-all-tvars new-arg-types))
	 (arg-list-type0
	  (tno-field-ref inst-type1 'type-arglist))
	 (all-tvars0 (append src-tvars new-type-vars))
	 (fixed-tvars (hfield-ref binder 'fixed-tvars))
	 (all-tvars
	  (get-nonfixed-tvars all-tvars0 fixed-tvars)))
    (let ((deductions (get-new-type-var-assoc-table)))
      (deduce-argument-types binder deductions
			     all-tvars
			     new-arg-types arg-list-type0)
      (if (not inside-param-def?)
	  (cond
	   ((all-tvars-correct? deductions new-type-vars)
	    (let* ((tvar-bindings
		    (hfield-ref deductions 'bindings))
		   (r-inst-type
		    (bind-type-vars binder tvar-bindings
				    inst-type1))
		   (r-type-var-values
		    (get-type-var-values-from-deductions2
		     new-type-vars deductions))
		   (r-arg-types
		    (bind-type-vars binder tvar-bindings
				    new-arg-types)))
	      (translate-normal-param-proc-appl2
	       binder e-proc arglist r-inst-type
	       r-arg-types
	       r-type-var-values pure? always-returns?
	       never-returns?
	       l-default-params)))
	   ((not-null? l-default-params)
	    (let* ((tvar-bindings
		    (map cons new-type-vars l-default-params))
		   (r-inst-type
		    (bind-type-vars binder tvar-bindings
				    inst-type1))
		   (r-arg-types
		    (bind-type-vars binder tvar-bindings
				    new-arg-types)))
	      (translate-normal-param-proc-appl2
	       binder e-proc arglist r-inst-type
	       r-arg-types
	       l-default-params pure? always-returns?
	       never-returns?
	       l-default-params)))
	   (else
	    (let ((s-name
		   (if (not-null? (hfield-ref e-proc 'address))
		       (hfield-ref (hfield-ref e-proc 'address)
				   'source-name)
		       '())))
	      (raise (list 'did-not-deduce-all-type-vars
			   s-name
			   (cons 'actual-type new-arg-types)
			   (cons 'declared-type arg-list-type0)
			   (cons
			    'bindings
			    (hfield-ref deductions 'bindings))
			   (cons 'needed new-type-vars))))))
	  (cond
	   ((all-tvars-correct? deductions new-type-vars)
	    (let* ((tvar-bindings
		    (hfield-ref deductions 'bindings))
		   (r-inst-type
		    (bind-type-vars binder tvar-bindings
				    inst-type1))
		   (r-type-var-values
		    (get-type-var-values-from-deductions2
		     new-type-vars deductions))
		   (r-arg-types
		    (bind-type-vars binder tvar-bindings
				    new-arg-types)))
	      (translate-param-proc-appl-inside-param
	       binder e-proc arglist type-dispatched?
	       r-inst-type
	       r-arg-types
	       r-type-var-values pure?
	       always-returns? never-returns?
	       l-default-params)))
	   ((not-null? l-default-params)
	    (let* ((tvar-bindings
		    (map cons new-type-vars l-default-params))
		   (r-inst-type
		    (bind-type-vars binder tvar-bindings
				    inst-type1))
		   (r-arg-types
		    (bind-type-vars binder tvar-bindings
				    new-arg-types)))
	      (translate-param-proc-appl-inside-param
	       binder e-proc arglist type-dispatched?
	       r-inst-type
	       r-arg-types
	       l-default-params pure?
	       always-returns? never-returns?
	       l-default-params)))
	   (else
	    (let* ((tvar-bindings
		    (hfield-ref deductions 'bindings))
		   (r-inst-type
		    (bind-type-vars binder tvar-bindings
				    inst-type1))
		   (result-type
		    (tno-field-ref r-inst-type
				   'type-result))
		   (static-arg-types (map get-expr-type arglist)))
	      (if (contains-only-specified-unbound-tvars-fwd?
		   result-type
		   fixed-tvars)
		  (begin
		    (make-hrecord
		     <proc-appl>
		     result-type
		     #t #f '()
		     pure? #f #t
		     '() always-returns? never-returns?
		     e-proc arglist '() static-arg-types
		     #t
		     l-default-params))
		  (begin
		    (make-hrecord
		     <proc-appl>
		     tc-object
		     #f #f '()
		     pure? #f #t
		     '() always-returns? never-returns?
		     e-proc arglist '() static-arg-types
		     #t
		     l-default-params))))))))))


(define (do-translate-param-proc-appl1 binder inside-param-def?
				       e-proc arglist l-default-params)
  (assert (is-binder? binder))
  (assert (boolean? inside-param-def?))
  (assert (is-entity? e-proc))
  (assert (and (list? arglist)
	       (and-map? is-entity? arglist)))
  (assert (and (list? l-default-params)
	       (and-map? is-entity? l-default-params)))
  (if (and (not-null? arglist)
	   (contains-none-value? binder arglist))
      (raise (list
	      'procedure-argument-with-type-none
	      (cons 's-proc-name
		    (get-proc-name2 e-proc))))
      (let ((t-proc (get-entity-value e-proc)))
	;; Maybe we should remove the following test.
	(if (null? t-proc)
	    (raise 'internal-invalid-procedure-1)
	    (let* ((ppc (get-entity-type e-proc))
		   (inst-type (tno-field-ref ppc 'type-contents))
		   (arg-list-type00
		    (tno-field-ref inst-type 'type-arglist))
		   (type-dispatched?
		    (and
		     (entity-type-dispatched? e-proc)
		     (and-map? entity-type-dispatched? arglist)))
		   (always-returns?
		    (and
		     (tno-field-ref inst-type 'appl-always-returns?)
		     (entity-always-returns? e-proc)
		     (and-map? entity-always-returns? arglist)))
		   (never-returns?
		    (or
		     (tno-field-ref inst-type 'appl-never-returns?)
		     (entity-never-returns? e-proc)
		     (or-map? entity-never-returns? arglist)))
		   (pure-proc? (tno-field-ref inst-type 'pure-proc?))
		   (pure-args? (and-map? is-pure-entity? arglist))
		   (pure? (and pure-proc? pure-args?)))
	      (cond
	       ((is-tuple-type? binder arg-list-type00)
		(if (not (= (length arglist)
			    (tuple-type-length binder arg-list-type00)))
		    (raise (list 'invalid-number-of-args
				 (cons 's-proc-name (get-proc-name2 e-proc))
				 (cons 'variable-length? #f)
				 (cons 'i-desired-args
				       (tuple-type-length binder
							  arg-list-type00))
				 (cons 'i-actual-args
				       (length arglist))))))
	       ((is-general-tuple-type? binder arg-list-type00)
	       	(if (< (length arglist)
	       	       (general-tuple-type-length binder arg-list-type00))
	       	    (raise (list 'invalid-number-of-args
	       			 (cons 's-proc-name (get-proc-name2 e-proc))
	       			 (cons 'variable-length? #t)
	       			 (cons 'i-desired-args
	       			       (general-tuple-type-length
	       				binder
	       				arg-list-type00))
	       			 (cons 'i-actual-args
	       			       (length arglist))))))
	       ((is-t-type-list? arg-list-type00)
		(let ((i-actual (length arglist))
		      (i-desired
		       (count (lambda (tt)
				(not (or (is-t-rest? tt) (is-t-splice? tt))))
			      (tno-field-ref arg-list-type00 'l-subtypes))))
		  (if (< i-actual i-desired)
		      ;; We don't include the argument counts because
		      ;; the desired argument count may be misleading.
		      (raise (list 'invalid-number-of-args-2
				   (cons 's-proc-name
					 (get-proc-name2 e-proc))))))))
	      (if (not type-dispatched?)
		  (if (not inside-param-def?)
		      (raise 'illegal-nondispatched-type)
		      (make-hrecord
		       <proc-appl>
		       tc-object
		       #f #f '()
		       pure? #f #t
		       '() always-returns? never-returns?
		       e-proc arglist '()
		       (map get-expr-type arglist)
		       #t
		       l-default-params))
		  (do-translate-param-proc-appl0 binder inside-param-def?
						 type-dispatched?
						 e-proc arglist
						 l-default-params
						 ppc inst-type
						 pure? always-returns?
						 never-returns?)))))))


(define (do-translate-param-proc-appl binder inside-param-def?
				      e-proc arglist l-default-params)
  (let* ((l-arg-types (map get-entity-type arglist))
	 (l-signatures (pick-signatures l-arg-types)))
    (if (null? l-signatures)
	(do-translate-param-proc-appl1 binder inside-param-def?
				       e-proc arglist l-default-params)
	(if (not (contains-free-tvars-general? arglist))
	    (if (is-target-object? e-proc)
		(let* ((p-match (match-call-with-signatures binder
							    e-proc
							    l-arg-types
							    l-signatures))
		       (tt-match (car p-match))
		       (proc-encountered? (cdr p-match)))
		  (cond
		   ((not-null? tt-match)
		    (translate-matched-proc-appl-with-sgn binder e-proc
							  arglist
							  tt-match #t))
		   (proc-encountered?
		    (raise 'type-mismatch-with-signatures))
		   (else
		    (do-translate-param-proc-appl1 binder inside-param-def?
						   e-proc arglist
						   l-default-params))))
		(do-translate-param-proc-appl1 binder inside-param-def?
					       e-proc arglist
					       l-default-params))
	    (translate-unresolved-proc-appl-with-sgn binder e-proc
						     arglist #t)))))


(define (check-param-proc-type binder e-proc arglist l-default-params)
  (assert (hrecord-is-instance? binder <binder>))
  (assert (is-entity? e-proc))
  (assert (and (list? arglist)
	       (and-map? is-entity? arglist)))
  (if (and (not-null? arglist)
	   (contains-none-value? binder arglist))
      (raise (list
	      'procedure-argument-with-type-none
	      (cons 's-proc-name
		    (let ((address (hfield-ref e-proc 'address)))
		      (if (not-null? address)
			  (hfield-ref address 'source-name)
			  '())))))
      ;; TBR: flag1? is to be removed.
      (let* ((flag1? (= gl-counter7 1))
	     (ppc (get-entity-type e-proc))
	     (inst-type (tno-field-ref ppc 'type-contents)))
	(assert (not-null? inst-type))
	(let* ((arg-types (map (lambda (repr)
				 (get-entity-type repr))
			       arglist))
	       (type-vars (tno-field-ref ppc 'l-tvars))
	       ;; We make sure that the type variables in the
	       ;; instance type are unique, i.e. they don't
	       ;; appear in the procedure expression
	       ;; or in the arguments.
	       ;; Does calling contains-specified-tvars-fwd?
	       ;; have any reason?
	       (uniq
		(if (contains-specified-tvars-fwd?
		     inst-type type-vars)
		    (make-tvars-unique binder type-vars inst-type)
		    (cons inst-type type-vars)))
	       (inst-type1 (car uniq))
	       (new-type-vars (cdr uniq))
	       (new-arg-types (make-tvars-unique2 binder arg-types))
	       (src-tvars (get-all-tvars new-arg-types))
	       (arg-list-type0
		(tno-field-ref inst-type1 'type-arglist))
	       (all-tvars (append src-tvars new-type-vars)))
	  (let ((deductions (get-new-type-var-assoc-table))
		(l-old-fixed-tvars (hfield-ref binder 'fixed-tvars)))
;;	    (hfield-set! binder 'fixed-tvars src-tvars)
	    (deduce-argument-types binder deductions
				   all-tvars
				   new-arg-types arg-list-type0)
;;	    (hfield-set! binder 'fixed-tvars l-old-fixed-tvars)
	    (cond
	     ((all-tvars-correct? deductions new-type-vars)
	      (let* ((tvar-bindings (hfield-ref deductions 'bindings))
		     (r-inst-type
		      (bind-type-vars binder tvar-bindings
				      inst-type1))
		     (r-type-var-values
		      (get-type-var-values-from-deductions2
		       new-type-vars deductions))
		     (r-arg-types
		      (bind-type-vars binder tvar-bindings
				      new-arg-types))
		     (pure-args? (and-map? is-pure-entity? arglist))
		     (result-type
		      (tno-field-ref r-inst-type 'type-result))
		     (arg-list-type
		      (tno-field-ref r-inst-type 'type-arglist))
		     (tt-actual-arglist
		      (get-arglist-type-from-list r-arg-types)))
		(cond
		 ((null? tt-actual-arglist)
		  (raise 'internal-null-argument-list))
		 ((check-arglist-types?
		   binder tt-actual-arglist arg-list-type)
		  result-type)
		 (else
		  (dvar1-set! binder)
		  (dvar2-set! tt-actual-arglist)
		  (dvar3-set! arg-list-type)
		  (dvar4-set! (list e-proc arglist))
		  (raise 'type-mismatch-in-param-proc-appl-2)))))
	     ((not-null? l-default-params)
	      (let* ((tvar-bindings (map cons new-type-vars l-default-params))
		     (r-inst-type
		      (bind-type-vars binder tvar-bindings
				      inst-type1))
		     (r-type-var-values l-default-params)
		     (r-arg-types
		      (bind-type-vars binder tvar-bindings
				      new-arg-types))
		     (pure-args? (and-map? is-pure-entity? arglist))
		     (result-type
		      (tno-field-ref r-inst-type 'type-result))
		     (arg-list-type
		      (tno-field-ref r-inst-type 'type-arglist))
		     (tt-actual-arglist
		      (get-arglist-type-from-list r-arg-types)))
		(cond
		 ((null? tt-actual-arglist)
		  (raise 'internal-null-argument-list))
		 ((check-arglist-types?
		   binder tt-actual-arglist arg-list-type)
		  result-type)
		 (else
		  (dvar1-set! binder)
		  (dvar2-set! tt-actual-arglist)
		  (dvar3-set! arg-list-type)
		  (dvar4-set! (list e-proc arglist))
		  (raise 'type-mismatch-in-param-proc-appl-3)))))
	     (else
	       (dvar1-set! new-arg-types)
	       (dvar2-set! arg-list-type0)
	       (dvar3-set! deductions)
	       (dvar4-set! new-type-vars)
	       (raise 'could-not-deduce-all-tvars))))))))


(define (get-arg-type-list arglist)
  (map (lambda (arg) (get-entity-type arg)) arglist))


(define (method-always-returns? mtc)
  (cond
   ((is-tc-simple-proc? mtc) (tno-field-ref mtc 'appl-always-returns?))
   ((is-tc-param-proc? mtc)
    (tno-field-ref (tno-field-ref mtc 'type-contents) 'appl-always-returns?))
   (else (raise 'internal-error))))


(define (method-never-returns? mtc)
  (cond
   ((is-tc-simple-proc? mtc) (tno-field-ref mtc 'appl-never-returns?))
   ((is-tc-param-proc? mtc)
    (tno-field-ref (tno-field-ref mtc 'type-contents) 'appl-never-returns?))
   (else (raise 'internal-error))))


(define (make-gen-proc-appl-best-match binder method
				       arglist result-type pure?)
  (assert (is-binder? binder))
  (assert (is-target-object? method))
  (let* ((type-dispatched?
	  (and-map? entity-type-dispatched? arglist))
	 (mtc (get-entity-type method))
	 (always-returns?
	  (and (method-always-returns? mtc)
	       (and-map? entity-always-returns? arglist)))
	 (never-returns?
	  (or (method-never-returns? mtc)
	      (or-map? entity-never-returns? arglist)))
	 (static-arg-types (map get-expr-type arglist)))
    (make-hrecord <proc-appl>
		  result-type
		  type-dispatched?
		  (is-final-class? binder result-type)
		  '()
		  pure?
		  #f
		  #f
		  '()
		  always-returns?
		  never-returns?
		  method
		  arglist
		  '()
		  static-arg-types
		  #f
		  '())))


(define (clone-gen-proc-appl binder repr l-new-arglist)
  (let ((result-type (get-entity-type repr))
	(pure? (hfield-ref repr 'pure?))
	(always-returns? (hfield-ref repr 'always-returns?))
	(never-returns? (hfield-ref repr 'never-returns?))
	(static-arg-types (hfield-ref repr 'static-arg-types)))
    (make-hrecord <proc-appl>
		  result-type
		  (hfield-ref repr 'type-dispatched?)
		  #f
		  '()
		  pure?
		  #f
		  #t
		  '()
		  always-returns?
		  never-returns?
		  (hfield-ref repr 'proc)
		  l-new-arglist
		  '()
		  static-arg-types
		  #f
		  '())))


(define (make-general-generic-proc-dispatch binder
					    generic-proc arg-types proc-type
					    with-result?
					    appl-pure?
					    appl-always-returns?
					    appl-never-returns?
					    regular? type-check?)
  (let ((to-result-type
	 (cond
	  ((is-tc-simple-proc? proc-type)
	   (tno-field-ref proc-type 'type-result))
	  ((is-tc-param-proc? proc-type)
	   (tno-field-ref (tno-field-ref proc-type 'type-contents)
			  'type-result))
	  (else
	   (dvar1-set! proc-type)
	   (raise 'internal-error)))))
    (if (and with-result? (entity-is-none1? binder to-result-type))
	(raise 'illegal-generic-dispatch-result-none))
    ;; Not sure about type-dispatched? and need-revision? here.
    (make-hrecord <generic-proc-dispatch>
		  proc-type
		  #t
		  #f
		  '()
		  #t
		  #f
		  (not type-check?)
		  '()
		  generic-proc
		  arg-types
		  with-result?
		  appl-pure?
		  appl-always-returns?
		  appl-never-returns?
		  regular?)))


;; Generic procedure application with no signatures
;; as argument types
(define (do-translate-normal-genproc-appl binder
					  gen-proc arglist arg-types)
  (let ((selection (select-best-method
		    binder
		    arg-types
		    (tno-field-ref gen-proc 'l-methods))))
    ;; MIETI puhtauden periytyminen metodeilla.
    (cond
     ((null? selection)
      (if (or-map? contains-free-tvars-fwd? arg-types)
	  (make-general-gen-proc-appl binder gen-proc arglist
				      tc-object #f #f #f #f #f)
	  (begin
	    (raise (list 'generic-static-dispatch-error-1
			 (cons 'gen-proc gen-proc)
			 (cons 'arg-types arg-types))))))
     ((= (length selection) 1)
      (let ((best-match (car selection)))
	(assert (and (pair? best-match) (is-method-record? (car best-match))))
	(let ((mtc (cdr best-match)))
	  (if (not (is-tc-simple-proc? mtc))
	      (raise 'invalid-procedure-1)
	      (let ((result-type (tno-field-ref mtc 'type-result))
		    (pure?
		     (and (tno-field-ref mtc 'pure-proc?)
			  (and-map? is-pure-entity? arglist)))
		    (method (car best-match)))
		(if (or (cdr method)
			(is-exact-match? binder arg-types mtc))
		    (make-gen-proc-appl-best-match
		     binder
		     (car method) arglist result-type pure?)
		    (let ((always-returns?
			   (and (tno-field-ref mtc 'appl-always-returns?)
				(and-map? entity-always-returns? arglist)))
			  (never-returns?
			   (or (tno-field-ref mtc 'appl-never-returns?)
			       (or-map? entity-never-returns? arglist))))
		      (make-general-gen-proc-appl
		       binder
		       gen-proc arglist result-type
		       #t
		       pure? always-returns? never-returns? #t))))))))
     (else
      ;; Method ambiguity is not a compile time error (?).
      ;; Methods defined after calling the generic procedure
      ;; may remove the (run time) ambiguity.
      (let* ((method-classes (map cdr selection))
	     (result-types
	      (map (lambda (mtc) (tno-field-ref mtc 'type-result))
		   method-classes))
	     (pure-proc?
	      (and-map? (lambda (mtc) (tno-field-ref mtc 'pure-proc?))
			method-classes))
	     (pure-args?
	      (and-map? is-pure-entity? arglist))
	     (pure-appl? (and pure-proc? pure-args?))
	     (always-returns?
	      (and
	       (and-map? (lambda (to-mtc)
			   (tno-field-ref to-mtc 'appl-always-returns?))
			 method-classes)
	       (and-map? entity-always-returns? arglist)))
	     (never-returns?
	      (or
	       (and-map? (lambda (to-mtc)
			   (tno-field-ref to-mtc 'appl-never-returns?))
			 method-classes)
	       (or-map? entity-never-returns? arglist)))
	     (result-type (get-union-of-types0 binder result-types)))
	(make-general-gen-proc-appl
	 binder
	 gen-proc arglist
	 result-type #t pure-appl? always-returns? never-returns? #t))))))


(define (do-translate-genproc-appl binder
				   gen-proc arglist arg-types)
  (assert (is-binder? binder))
  (strong-assert (is-target-object? gen-proc))
  (assert (list? arglist))
  (assert (and-map? is-entity? arglist))
  (assert (list? arg-types))
  (assert (and-map? is-entity? arg-types))
  (if (not (and-map? entity-type-dispatched? arglist))
      ;; Should we set type-check? = #t here?
      (make-general-gen-proc-appl binder gen-proc arglist
				  tc-object #f #f #f #f #f)
      (let ((l-signatures (pick-signatures arg-types)))
	(if (null? l-signatures)
	    (do-translate-normal-genproc-appl binder gen-proc arglist arg-types)
	    (begin
	      (if (not (contains-free-tvars-general? arglist))
		  (let* ((p-match (match-call-with-signatures binder
							      gen-proc
							      arg-types
							      l-signatures))
			 (tt-match (car p-match))
			 (proc-encountered? (cdr p-match)))
		    (cond
		     ((not-null? tt-match)
		      (translate-matched-proc-appl-with-sgn binder gen-proc
							    arglist
							    tt-match #f))
		     (proc-encountered?
		      (raise 'type-mismatch-with-signatures))
		     (else
		      (do-translate-normal-genproc-appl binder gen-proc
							arglist arg-types))))
		  (translate-unresolved-proc-appl-with-sgn binder gen-proc
							   arglist #f)))))))


(define (get-general-generic-class with-result? appl-pure?)
  (cond
   ((and with-result? appl-pure?) tt-general-simple-func-with-value)
   ((and with-result? (not appl-pure?)) tt-general-simple-proc-with-value)
   ((and (not with-result?) appl-pure?) tt-general-simple-func)
   ((and (not with-result?) (not appl-pure?)) tt-general-simple-proc)
   (else (raise 'internal-error))))


(define (translate-generic-proc-dispatch binder generic-proc arg-types
					 with-result?
					 appl-pure?
					 appl-always-returns?
					 appl-never-returns?
					 type-check?)
  (assert (is-binder? binder))
  (assert (is-entity? generic-proc))
  (assert (list? arg-types))
  (assert (and-map? is-entity? arg-types))
  (cond
   ((not (hrecord-is-instance? generic-proc <target-object>))
    (raise 'invalid-generic-procedure))
   ((or (not type-check?) (or-map? contains-free-tvars-fwd? arg-types))
    (make-general-generic-proc-dispatch binder generic-proc arg-types
					(get-general-generic-class
					 with-result? appl-pure?)
					with-result?
					appl-pure?
					appl-always-returns?
					appl-never-returns?
					#f #f))
   ((is-simple-arg-list? arg-types)
    (let ((selection (select-best-method
		      binder
		      arg-types
		      (tno-field-ref generic-proc 'l-methods))))
      ;; MIETI puhtauden periytyminen metodeilla.
      (cond
       ((null? selection)
	(raise 'generic-static-dispatch-error-2))
       ((= (length selection) 1)
	(let ((best-match (car selection)))
	  (assert
	   (and (pair? best-match) (is-method-record? (car best-match))))
	  (let* ((mtc0 (cdr best-match))
		 (pure-proc-match? (tno-field-ref mtc0 'pure-proc?))
		 (always-returns-match?
		  (tno-field-ref mtc0 'appl-always-returns?))
		 (never-returns-match?
		  (tno-field-ref mtc0 'appl-never-returns?))
		 (mtc
		  (if with-result?
		      mtc0
		      (make-tpti-general-proc
		       #t
		       (tno-field-ref mtc0 'type-arglist)
		       tt-none
		       pure-proc-match?
		       always-returns-match?
		       never-returns-match?
		       #f))))
	    (cond
	     ((not (proc-attr-inherit?
		    pure-proc-match?
		    always-returns-match?
		    never-returns-match?
		    #f
		    appl-pure?
		    appl-always-returns?
		    appl-never-returns?
		    #f))
	      (raise 'invalid-attributes-in-dispatch))
	     ;; mtc should always be a simple procedure class
	     ((not (is-tc-simple-proc? mtc))
	      (raise 'invalid-procedure-2))
	     ((or (cdar best-match)
		  (is-exact-match? binder arg-types mtc))
	      (caar best-match))
	     (else
	      (make-general-generic-proc-dispatch
	       binder
	       generic-proc arg-types mtc with-result?
	       appl-pure?
	       appl-always-returns?
	       appl-never-returns?
	       #t #t))))))
       (else
	;; Method ambiguity is not a compile time error.
	;; Methods defined after calling the generic procedure
	;; may remove the (run time) ambiguity.
	(let* ((method-classes (map cdr selection))
	       (result-types
		(map (lambda (mtc) (hfield-ref mtc 'result-type))
		     method-classes))
	       (pure-proc?
		(and-map? (lambda (mtc) (hfield-ref mtc 'pure-proc?))
			  method-classes))
	       (always-returns?
		(and-map? (lambda (mtc) (hfield-ref mtc 'always-returns?))
			  method-classes))
	       (never-returns?
		(and-map? (lambda (mtc) (hfield-ref mtc 'never-returns?))
			  method-classes))
	       (result-type
		(if with-result?
		    (get-union-of-types0 binder result-types)
		    tt-none))
	       (proc-type (translate-general-proc-type-expression
			   binder #t arg-types result-type
			   pure-proc? always-returns? never-returns? #f)))
	  (if (not (proc-attr-inherit?
		    pure-proc?
		    always-returns?
		    never-returns?
		    #f
		    appl-pure?
		    appl-always-returns?
		    appl-never-returns?
		    #f))
	      (raise 'invalid-attributes-in-dispatch))
	  (make-general-generic-proc-dispatch
	   binder
	   generic-proc arg-types proc-type with-result?
	   appl-pure?
	   appl-always-returns?
	   appl-never-returns?
	   #t #t))))))
   (else
    (make-general-generic-proc-dispatch binder generic-proc arg-types
					(get-general-generic-class
					 with-result? appl-pure?)
					with-result?
					appl-pure?
					appl-always-returns?
					appl-never-returns?
					#f #f))))


(define (translate-general-genproc-appl binder
					gen-proc arglist type-check?)
  (assert (hrecord-is-instance? binder <binder>))
  (if (and (not-null? arglist)
	   (contains-none-value? binder arglist))
      (raise (list 'generic-procedure-argument-with-type-none
		   (cons 's-proc-name
			 (let ((address (hfield-ref gen-proc 'address)))
			   (if (not-null? address)
			       (hfield-ref address 'source-name)
			       '())))))
      (let ((arg-types (get-arg-type-list arglist)))
	;;	(if (and type-check?
	;;		 (not (or-map? contains-free-tvars-fwd? arg-types)))
	(if type-check?
	    (do-translate-genproc-appl binder
				       gen-proc arglist arg-types)
	    ;; Should we have type-dispatched? = #f in the following?
	    (make-general-gen-proc-appl binder gen-proc arglist
					tc-object #t #f #f #f #f)))))


(define (myeq1? obj variable)
  (eq? obj (hfield-ref variable 'value)))


(define (do-translate-simple-proc-appl proc arguments static-arg-types
				       binder
				       type-check? inside-param-def?
				       runtime-arglist-typecheck?)
  (assert (hrecord-is-instance? proc <entity>))
  (assert (and (list? arguments) (and-map? is-entity? arguments)))
  (assert (or (eq? static-arg-types #f)
	      (and (list? static-arg-types)
		   (and-map? is-entity? static-arg-types))))
  (assert (is-binder? binder))
  (assert (boolean? type-check?))
  (cond
   ((and (not-null? arguments)
	 (contains-none-value? binder arguments))
    (raise (list
	    'procedure-argument-with-type-none
	    (cons 's-proc-name
		  (let ((address (hfield-ref proc 'address)))
		    (if (not-null? address)
			(hfield-ref address 'source-name)
			'()))))))
   ;; TBD: Change eqv? to eq?
   ((eqv? proc tp-class-of)
    (translate-class-of-appl binder proc arguments))
   ((eqv? proc tp-is-subtype)
    (translate-is-subtype-appl binder proc arguments
			       type-check? inside-param-def?))
   ((eqv? proc tp-is-instance)
    (translate-is-instance-appl binder proc arguments
				type-check? inside-param-def?))
   ((eqv? proc tp-tuple-ref)
    (translate-tuple-ref-appl binder arguments
			      type-check? inside-param-def?))
   ((eqv? proc tp-tuple-type-with-tail)
    (translate-tuple-type-with-tail-appl binder
					 proc arguments inside-param-def?))
   ((eqv? proc tp-make-vector)
    (translate-make-vector-appl binder proc arguments
				#f #f type-check? inside-param-def?))
   ((eqv? proc tp-make-mutable-vector)
    (translate-make-vector-appl binder proc arguments
				#t #f type-check? inside-param-def?))
   ((eqv? proc tp-make-value-vector)
    (translate-make-vector-appl binder proc arguments
				#f #t type-check? inside-param-def?))
   ((eqv? proc tp-make-mutable-value-vector)
    (translate-make-vector-appl binder proc arguments
				#t #t type-check? inside-param-def?))
   ((eqv? proc tp-vector)
    (translate-vector-appl binder proc arguments #f #f
			   type-check? inside-param-def?))
   ((eqv? proc tp-value-vector)
    (translate-vector-appl binder proc arguments #f #t
			   type-check? inside-param-def?))
   ((eqv? proc tp-mutable-vector)
    (translate-vector-appl binder proc arguments #t #f
			   type-check? inside-param-def?))
   ((eqv? proc tp-mutable-value-vector)
    (translate-vector-appl binder proc arguments #t #t
			   type-check? inside-param-def?))
   ((eqv? proc tp-cast-vector)
    (translate-cast-vector-appl binder proc arguments #f #f
				type-check? inside-param-def?))
   ((eqv? proc tp-cast-mutable-vector)
    (translate-cast-vector-appl binder proc arguments #t #f
				type-check? inside-param-def?))
   ((eqv? proc tp-cast-value-vector)
    (translate-cast-vector-appl binder proc arguments #f #t
				type-check? inside-param-def?))
   ((eqv? proc tp-cast-mutable-value-vector)
    (translate-cast-vector-appl binder proc arguments #t #t
				type-check? inside-param-def?))
   ((eqv? proc tp-cast-vector-metaclass)
    (translate-cast-vector-metaclass binder proc arguments #f #f
				     type-check? inside-param-def?))
   ((eqv? proc tp-cast-mutable-vector-metaclass)
    (translate-cast-vector-metaclass binder proc arguments #t #f
				     type-check? inside-param-def?))
   ((eqv? proc tp-cast-value-vector-metaclass)
    (translate-cast-vector-metaclass binder proc arguments #f #t
				     type-check? inside-param-def?))
   ((eqv? proc tp-cast-mutable-value-vector-metaclass)
    (translate-cast-vector-metaclass binder proc arguments #t #t
				     type-check? inside-param-def?))
   ((eqv? proc tp-field-ref)
    (raise 'internal-invalid-field-ref))
   ((eqv? proc tp-field-set)
    (raise 'internal-invalid-field-set!))
   (else
    (translate-simple-proc-appl-expression binder
					   proc arguments
					   static-arg-types
					   type-check?
					   inside-param-def?
					   runtime-arglist-typecheck?))))


(define (translate-param-proc-instance binder to-param-proc
				       r-type-var-values
				       type-check?)
  (assert (is-binder? binder))
;;  (assert (is-static-entity? to-param-proc))
  (assert (and (list? r-type-var-values)
	       (and-map? is-entity? r-type-var-values)))
  (strong-assert (not-null? to-param-proc))
  (if (not
       (or (not type-check?)
	   (is-t-instance? binder
			   (get-entity-type to-param-proc)
			   tpc-param-proc)))
      (raise 'not-a-param-proc))
  (let* ((to-ppc (get-entity-type to-param-proc))
	 (inst-type (tno-field-ref to-ppc 'type-contents)))
    (strong-assert (and (not-null? inst-type)
			(is-entity? inst-type)))
    (let* ((type-variables (tno-field-ref to-ppc 'l-tvars))
	   (tvar-bindings (map cons type-variables r-type-var-values))
	   (r-inst-type
	    (bind-type-vars binder tvar-bindings inst-type)))
      (make-hrecord <expr-param-proc-instance>
		    r-inst-type
		    #t
		    ;; MIETI eksaktius
		    #f
		    '()
		    #t
		    #t
		    ;; Formerly we had
		    ;; (hfield-ref compiler 'inside-param-def?)
		    ;; in the following.
		    #f
		    '()
		    to-param-proc
		    r-type-var-values))))


(define (translate-param-proc-dispatch binder to-param-proc
				       r-argument-types
				       type-check?)
  ;; Not sure if incomplete objects work here.
  (assert (is-target-object? to-param-proc))
  (assert (and (list? r-argument-types)
	       (and-map? is-entity? r-argument-types)))
  (strong-assert (not-null? to-param-proc))
  (strong-assert (or (not type-check?)
		     (not (hfield-ref to-param-proc 'incomplete?))))
  (strong-assert
   (or (not type-check?)
       (is-t-instance? binder
		       (get-entity-type to-param-proc)
		       tpc-param-proc)))
  (let* ((to-ppc (get-entity-type to-param-proc))
	 (inst-type (tno-field-ref to-ppc 'type-contents)))
    (strong-assert (and (not-null? inst-type) (is-entity? inst-type)))
    (let* ((type-variables (tno-field-ref to-ppc 'l-tvars))
	   (arg-list-type0 (tno-field-ref inst-type 'type-arglist))
	   (deductions (get-new-type-var-assoc-table))
	   (l-all-arg-tvars (get-all-tvars r-argument-types))
	   (l-old-fixed (hfield-ref binder 'fixed-tvars)))
      (hfield-set! binder 'fixed-tvars l-all-arg-tvars)
      ;; Should we have make-src-unique? = #t?
      (deduce-argument-types binder deductions
			     type-variables
			     r-argument-types arg-list-type0)
      (hfield-set! binder 'fixed-tvars l-old-fixed)
      ;; Is it OK not to check that all type variables have been
      ;; deduced correctly?
      (let* ((tvar-bindings (hfield-ref deductions 'bindings))
	     (bound-inst-type (bind-type-vars binder
					      tvar-bindings
					      inst-type))
	     (r-type-var-values (get-type-var-values-from-deductions2
				 type-variables deductions)))
	(if type-check?
	    (let* ((tt-actual-arglist
		    (apply make-tuple-type
			   r-argument-types))
		   (tt-declared-arglist (tno-field-ref bound-inst-type
						       'type-arglist)))
	      (if (check-arglist-types? binder tt-actual-arglist
					tt-declared-arglist)
		  ;; Should we use r-argument-types instead of
		  ;; r-argument-types1 in the following?
		  ;; MIETI eksaktius
		  (make-hrecord <expr-param-proc-dispatch>
				bound-inst-type #t #f '()
				#t #t #t '()
				to-param-proc
				r-type-var-values
				r-argument-types)
		  (raise 'param-proc-dispatch-type-mismatch)))
	    (begin
	      (make-hrecord <expr-param-proc-dispatch>
			    bound-inst-type
			    #t
			    ;; MIETI eksaktius
			    #f
			    '()
			    #t
			    #t
			    #t
			    '()
			    to-param-proc
			    r-type-var-values
			    r-argument-types)))))))


(define (make-prevent-stripping-expr address)
  (make-hrecord <prevent-stripping-expr>
		tt-none #t #t '() #f #f #f '()
		address))


(define (optimize-match-type binder tt-value l-types l-proper-clauses)
  (let* ((n-clauses (length l-types))
	 (tt-cur '())
	 (found? #f)
	 (l-result '()))
    (do ((i 0 (+ i 1)) (l-cur l-types (cdr l-cur)))
	((or (>= i n-clauses) found?))
      (if (= i 0)
	  (set! tt-cur (car l-cur))
	  (set! tt-cur
		(get-union-of-types0 binder
				     (list
				      tt-cur
				      (car l-cur)))))
      (let ((opt? (is-t-subtype? binder tt-value tt-cur))
	    (l-clause (list-ref l-proper-clauses i)))
	(set! l-result
	      (append l-result
		      (list (list (list-ref l-clause 0)
				  (list-ref l-clause 1)
				  (list-ref l-clause 2)
				  opt?))))
	(if opt? (set! found? #t))))
    (cons found? l-result)))


(define (translate-match-type-expr0 binder strong? expr-to-match
				    opt?
				    lst-proper-clauses
				    expr-else type-check?)
  (let* ((lst-subexprs
	  (if opt?
	      (map caddr lst-proper-clauses)
	      (append (map caddr lst-proper-clauses) (list expr-else))))
	 (type-dispatched?
	  (and-map? entity-type-dispatched? lst-subexprs))
	 (always-returns?
	  (and-map? entity-always-returns? lst-subexprs))
	 (never-returns?
	  (and-map? entity-never-returns? lst-subexprs))
	 (pure? (and type-check?
		     (and-map? is-pure-entity? lst-subexprs)))
	 (expr-result-type
	  (if type-check?
	      (get-union-type-from-expressions binder lst-subexprs)
	      tc-object))
	 (exact-type? (is-final-class? binder expr-result-type)))
    (make-hrecord <match-type-expression>
		  expr-result-type
		  type-dispatched?
		  exact-type?
		  '()
		  pure?
		  #f
		  (not type-check?)
		  '()
		  always-returns?
		  never-returns?
		  strong?
		  expr-to-match
		  lst-proper-clauses
		  expr-else
		  opt?)))


(define (translate-match-type-expr binder strong? expr-to-match
				   lst-proper-clauses
				   expr-else type-check?)
  (let* ((lst-types (map cadr lst-proper-clauses))
	 (tt-value (get-entity-type expr-to-match))
	 (x-opt (optimize-match-type binder tt-value lst-types
				     lst-proper-clauses))
	 (opt? (car x-opt))
	 (l-processed-clauses (cdr x-opt)))
    (if (and type-check?
	     strong?
	     (is-empty-expr? expr-else)
	     (not opt?))
	(raise 'match-type-strong:not-covered)
	(translate-match-type-expr0 binder strong? expr-to-match opt?
				    l-processed-clauses
				    expr-else type-check?))))


(define (translate-force-pure-expr repr-component)
  ;; Formerly we had is-expression? here.
  (assert (is-entity? repr-component))
  (let ((to-value (get-entity-value repr-component)))
    (make-hrecord <force-pure-expr>
		  (hfield-ref repr-component 'type)
		  (hfield-ref repr-component 'type-dispatched?)
		  (hfield-ref repr-component 'exact-type?)
		  (hfield-ref repr-component 'address)
		  ;; The result expression is forced to be pure.
		  #t
		  (not-null? to-value)
		  (if (hrecord-is-instance? repr-component <expression>)
		      (hfield-ref repr-component 'need-revision?)
		      #f)
		  to-value
		  (entity-always-returns? repr-component)
		  (entity-never-returns? repr-component)
		  repr-component)))
