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



;; *** Parametrized class instance cache ***


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


;; (define gl-ctr7 0)
(define gl-flag8? #f)


(define equal-reprs-fwd? '())


(define-hrecord-type <param-cache> ()
  cache)


(define is-param-cache? (get-hrecord-type-predicate <param-cache>))


(define (param-cache-init) '())


;;(define (param-classes-equal? t1 t2)
;;  (address=? (hfield-ref t1 'address) (hfield-ref t2 'address)))


(define (param-classes-equal? t1 t2)
  ;; Probably eq? would work, too.
  (eqv? t1 t2))


(define (param-cache-fetch-param-class param-cache param-class)
  (assert (is-param-cache? param-cache))
  (assert (is-target-object? param-class))
  (let ((result
	 (assoc param-class (hfield-ref param-cache 'cache)
		param-classes-equal?)))
    result))


(define (type-params-equal? tp1 tp2)
  (and (= (length tp1) (length tp2))
       (and-map? eqv? tp1 tp2)))


(define (param-cache-fetch param-cache param-class type-params)
  (assert (is-param-cache? param-cache))
  (assert (is-target-object? param-class))
  (assert (list? type-params))
  (assert (and-map? is-target-object? type-params))
  (let ((class-bindings (param-cache-fetch-param-class param-cache
						       param-class)))
    (let* ((eq-pred? (lambda (tp1 tp2)
		       (type-params-equal? tp1 tp2)))
	   (result
	    (if (not (eqv? class-bindings #f))
		(assoc type-params (cdr class-bindings) eq-pred?)
		#f)))
      result)))


(define (param-cache-fetch2 param-cache binder param-class type-params)
  (assert (is-param-cache? param-cache))
  (assert (is-target-object? param-class))
  (assert (list? type-params))
  (assert (and-map? is-target-object? type-params))
  (let ((class-bindings (param-cache-fetch-param-class param-cache
						       param-class)))
    (let* ((eq-pred? (lambda (tp1 tp2)
		       (equal-reprs1? binder tp1 tp2)))
	   (result
	    (if (not (eqv? class-bindings #f))
		(assoc type-params (cdr class-bindings) eq-pred?)
		#f)))
      result)))


(define (param-cache-add-binding! param-cache param-class
				  type-params new-instance)
  (assert (is-param-cache? param-cache))
  (assert (is-target-object? param-class))
  (assert (list? type-params))
  (assert (and-map? is-target-object? type-params))
  (assert (is-target-object? new-instance))
  (let ((class-bindings (param-cache-fetch-param-class param-cache
						       param-class)))
    (if (not (eqv? class-bindings #f))
	(set-cdr! class-bindings
		  (cons (cons type-params new-instance) 
			(cdr class-bindings)))
	(hfield-set! param-cache 'cache
		     (append
		      (list (cons param-class
				  (list (cons type-params new-instance))))
		      (hfield-ref param-cache 'cache))))))


;; Voitanee käyttää eq?.
(define (param-cache-bind-declared! param-cache param-class type-params
				    new-instance)
  (assert (is-param-cache? param-cache))
  (assert (is-target-object? param-class))
  (assert (list? type-params))
  (assert (and-map? is-target-object type-params))
  (assert (is-target-object? new-instance))
  (let ((class-bindings (param-cache-fetch-param-class
			 param-cache param-class)))
    (if (not (eqv? class-bindings #f))
	(let* ((eq-pred? (lambda (tp1 tp2)
			   (type-params-equal? tp1 tp2)))
	       (binding (assoc type-params (cdr class-bindings)
			       eq-pred?)))
	  (if (not (eqv? binding #f))
	      (begin
		;; Vanha (cdr binding) voi aiheuttaa ongelmia.
		;; Vanhoissa versioissa asetettiin sen fw-val-kenttä.
		(set-cdr! binding new-instance))
	      (raise 'variable-not-found-1)))
	(raise 'variable-not-found-2))))


(define (param-cache-bind-declared2! param-cache param-class type-params
				     new-instance)
  (assert (is-param-cache? param-cache))
  (assert (is-target-object? param-class))
  (assert (list? type-params))
  (assert (and-map? is-target-object? type-params))
  (assert (is-target-object? new-instance))
  (let ((class-bindings (param-cache-fetch-param-class
			 param-cache param-class)))
    (if (not (eqv? class-bindings #f))
	(let* ((eq-pred? (lambda (tp1 tp2)
			   (type-params-equal? tp1 tp2)))
	       (binding (assoc type-params (cdr class-bindings)
			       eq-pred?)))
	  (if (not (eqv? binding #f))
	      (begin
		(assert (is-target-object? (cdr binding)))
		(set-object! (cdr binding) new-instance))
	      (raise 'variable-not-found-3)))
	(raise 'variable-not-found-4))))


(define (param-cache-bind-declared3! param-cache binder param-class type-params
				     new-instance)
  (assert (is-param-cache? param-cache))
  (assert (is-target-object? param-class))
  (assert (list? type-params))
  (assert (and-map? is-target-object? type-params))
  (assert (is-target-object? new-instance))
  (let ((class-bindings (param-cache-fetch-param-class
			 param-cache param-class)))
    (if (not (eqv? class-bindings #f))
	(let* ((eq-pred? (lambda (tp1 tp2)
			   (equal-reprs1? binder tp1 tp2)))
	       (binding (assoc type-params (cdr class-bindings)
			       eq-pred?)))
	  (if (not (eqv? binding #f))
	      (begin
		(assert (is-target-object? (cdr binding)))
		(set-object! (cdr binding) new-instance))
	      (raise 'variable-not-found-3)))
	(raise 'variable-not-found-4))))

