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


;; *** Expression rebinding ***


(import (th-scheme-utilities stdutils))


(define	(rebind-match-type-expr binder repr
				expr-to-match-new
				lst-repr-clauses-new
				expr-else-new)
  (assert (is-binder? binder))
  (assert (hrecord-is-instance? repr <match-type-expression>))
  (let* ((lst-types (map cadr lst-repr-clauses-new))
	 (tt-value (get-entity-type expr-to-match-new))
	 (x-opt (optimize-match-type binder tt-value lst-types
				     lst-repr-clauses-new))
	 (opt? (car x-opt))
	 (l-processed-clauses (cdr x-opt)))
    (make-hrecord <match-type-expression>
		  (hfield-ref repr 'type)
		  (hfield-ref repr 'type-dispatched?)
		  (hfield-ref repr 'exact-type?)
		  '()
		  (hfield-ref repr 'pure?)
		  (hfield-ref repr 'static?)
		  (hfield-ref repr 'need-revision?)
		  ;; Should we give the old value here?
		  '()
		  (hfield-ref repr 'always-returns?)
		  (hfield-ref repr 'never-returns?)
		  (hfield-ref repr 'strong?)
		  expr-to-match-new
		  l-processed-clauses
		  expr-else-new
		  opt?)))
