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


;; *** Parametrized instances ***


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


(define bind-type-vars2-fwd '())


(define gl-flag1? #f)


(define (bind-type-vars-for-field-list1 binder al-bindings lst-fields)
  (let ((old-type-check? (hfield-ref binder 'type-check?)))
    (hfield-set! binder 'type-check? #t)
    (let ((result
	   (car (bind-type-vars-for-field-list binder al-bindings
					       lst-fields '()))))
      (hfield-set! binder 'type-check? old-type-check?)
      result)))


;; Procedure make-constructor! is called from compute-instantion.
;; Type parameters of the parametrized class are assigned
;; type-var-values. The type-var-values may not contain any
;; type modifiers.
(define (make-parametrized-class-instance binder address
					  param-class type-var-values
					  make-ctr?)
  (assert (hrecord-is-instance? binder <binder>))
  (assert (or (null? address) (hrecord-is-instance? address <address>)))
  (assert (is-target-object? param-class))
  (assert (list? type-var-values))
  (assert (and-map? is-target-object? type-var-values))
  (assert (boolean? make-ctr?))
  (let ((immutable? (tno-field-ref param-class 'instances-immutable?))
	(inheritable? (tno-field-ref param-class 'instances-inheritable?))
	(eq-by-value? (tno-field-ref param-class 'instances-eq-by-value?))
	(ctr-access (tno-field-ref param-class 's-instance-ctr-access))
	(superclass (tno-field-ref param-class 'cl-instance-superclass))
	(has-zero? (tno-field-ref param-class 'instance-has-zero?))
	(module (tno-field-ref param-class 'module))
	(fields (tno-field-ref param-class 'l-instance-fields))
	(all-fields (tno-field-ref param-class 'l-instance-all-fields))
	(type-vars (tno-field-ref param-class 'l-tvars)))
					; HUOM. union ja tuple
    (assert (boolean? inheritable?))
    (assert (boolean? immutable?))
    (assert (boolean? eq-by-value?))
    (assert (memq ctr-access gl-access-specifiers))
    (assert (and-map? is-t-type-variable? type-vars))
    (if (not (= (length type-vars) (length type-var-values)))
	(raise 'invalid-number-of-type-parameters))
    (let* ((type-var-bindings (map cons type-vars type-var-values))
	   (r-superclass
	    (bind-type-vars binder type-var-bindings
			    superclass))
	   (r-fields
	    (bind-type-vars-for-field-list1 binder
					    type-var-bindings fields))
	   (r-all-fields
	    (bind-type-vars-for-field-list1 binder
					    type-var-bindings all-fields))
	   (param-class-name (tno-field-ref param-class 'str-name))
	   (instance-class-name (string-append "(" param-class-name " ...)")))
      (cond
       ((not (tno-field-ref r-superclass 'inheritable?))
	(raise 'noninheritable-superclass))
       ((contains-duplicate-field-names-fwd? r-superclass r-fields)
	(raise 'param-duplicate-field-name))
       (else
	(let* ((to
		(make-target-object
		 param-class #t #f '()
		 #f #f
		 (list 
		  (cons 'cl-superclass r-superclass)
		  (cons 'l-fields r-fields)
		  (cons 'l-all-fields r-all-fields)
		  (cons 'inheritable? inheritable?)
		  (cons 'immutable? immutable?)
		  (cons 'eq-by-value? eq-by-value?)
		  (cons 's-ctr-access ctr-access)
		  (cons 'type-constructor '())
		  (cons 'proc-constructor '())
		  (cons 'goops? #f)
		  (cons 'has-zero? has-zero?)
		  (cons 'zero-prim? #f)
		  (cons 'x-zero-value '())
		  (cons 'module module)
		  (cons 'str-name instance-class-name)
		  (cons 'l-tvar-values type-var-values)
		  (cons 'l-param-exprs type-var-values))
		 '())))
	  (if (and immutable?
		   (not (is-valid-immutable-class? to)))
	      (raise 'invalid-immutable-param-class-instance))
	  to))))))


(define (bind-param-sgn-member binder bindings r-member)
  (let* ((r-type (cdr r-member))
	 (r-new-type (bind-type-vars binder bindings r-type))
	 (result (cons (car r-member) r-new-type)))
    result))


(define (make-param-sgn-instance binder address
				 param-sgn type-var-values)
  (assert (hrecord-is-instance? binder <binder>))
  (assert (or (null? address) (hrecord-is-instance? address <address>)))
  (assert (is-target-object? param-sgn))
  (assert (list? type-var-values))
  (assert (and-map? is-target-object? type-var-values))
  (let ((tvars (tno-field-ref param-sgn 'l-tvars)))
    (if (not (= (length tvars) (length type-var-values)))
	(raise 'invalid-number-of-type-parameters)
	(let* ((lst-members (tno-field-ref param-sgn 'l-members))
	       (bindings (map cons tvars type-var-values))
	       (lst-new-members (map* (lambda (r-member)
					(bind-param-sgn-member
					 binder bindings r-member))
				      lst-members))
	       (to (make-signature-object address lst-new-members)))
	  to))))


(define (make-parametrized-proc-instance binder address param-proc
					 type-var-values)
  (assert (hrecord-is-instance? binder <binder>))
  (assert (or (null? address) (hrecord-is-instance? address <address>)))
  (assert (is-target-object? param-proc))
  (assert (list? type-var-values))
  (assert (and-map? is-target-object? type-var-values))
  (let ((type-vars (tno-field-ref param-proc 'l-tvars)))
    (if (not (= (length type-var-values) (length type-vars)))
	(raise 'invalid-number-of-type-parameters)
	(let* ((type-var-bindings (map cons type-vars type-var-values))
	       (inst-type (bind-type-vars
			   binder type-var-bindings
			   (tno-field-ref param-proc 'type-contents)))
	       (obj (make-procedure inst-type #t #f '()
				    '()
				    '())))
	  (dwl4 "make-parametrized-proc-instance EXIT")
      obj))))


(define (create-fwd-ref-for-instance r-param-class address)
  (assert (is-target-object? r-param-class))
  (make-target-object
   r-param-class #t #f address
   #f #t #f '()))


(set! create-fwd-ref-for-instance-fwd create-fwd-ref-for-instance)


(define (binder-get-instance binder
			     param-type
			     type-params
			     make-ctr?)
  (assert (hrecord-is-instance? binder <binder>))
  (assert (is-target-object? param-type))
  (assert (and (list? type-params)
	       (and-map? is-target-object? type-params)))
  (assert (boolean? make-ctr?))
  (let* ((param-cache (hfield-ref binder 'param-cache))
	 (binding (param-cache-fetch param-cache
				     param-type type-params))
	 (param-def-type (get-param-def-type param-type)))
    (let ((result
	   (if binding
	       (begin
		 (cdr binding))
	       (if (memq param-def-type (list 'class 'procedure 'signature))
		   (begin
		     (let* ((alloc (hfield-ref binder 'allocate-variable))
			    (address (if (hfield-ref binder 'make-instances?)
					 (alloc 'b2 #t) '()))
			    (instance (create-fwd-ref-for-instance
				       param-type address))
			    (l-old-overwrite (hfield-ref binder 'l-overwrite)))
		       (hfield-set! binder 'l-overwrite
				    (cons instance l-old-overwrite))
		       (param-cache-add-binding! param-cache param-type
						 type-params
						 instance)
		       (let ((new-instance
			      (case param-def-type
				((class)
				 (make-parametrized-class-instance
				  binder
				  address
				  param-type type-params make-ctr?))
				 ;; (car (do-bind-type-vars1-fwd
				 ;;       binder
				 ;;       '()
				 ;;       (make-apti param-type type-params)
				 ;;       '())))
				((procedure)
				 (make-parametrized-proc-instance
				  binder
				  address
				  param-type type-params))
				((signature)
				 (make-param-sgn-instance
				  binder
				  address
				  param-type type-params))
				(else (raise 'internal-invalid-param-def-2)))))
			 (set-object! instance new-instance)
			 (if (and (eq? param-def-type 'class)
				  make-ctr?
				  (tno-field-ref param-type
						 'instance-has-constructor?))
			     (make-constructor-fwd!
			      binder
			      instance))
			 (hfield-set! binder 'l-overwrite
				      l-old-overwrite)
			 instance)))
		   (begin
		     (let* ((alloc (hfield-ref binder 'allocate-variable))
			    (address (if (hfield-ref binder 'make-instances?)
					 (alloc 'b2 #t) '()))
			    (instance (create-fwd-ref-for-instance
				       param-type address)))
		       (param-cache-add-binding! param-cache param-type
						 type-params
						 instance)
		       (let ((result2
			      (car (translate-param-ltype-instance-expr2
				    binder param-type type-params
				    '()))))
			 (set-object! instance result2)
			 instance)))))))
      result)))


(set! binder-get-instance-fwd binder-get-instance)


(define (make-parametrized-class-object
	 binder
	 module
	 name
	 address
	 type-variables
	 instance-superclass
	 instance-fields
	 inh? imm? ebv?
	 ctr-access)
  (assert (is-binder? binder))
  (assert (is-module-name? module))
  (assert (string? name))
  (assert (and (list? type-variables)
	       (and-map? is-t-type-variable? type-variables)))
  (assert (is-entity? instance-superclass))
  (assert (list? instance-fields))
  (assert (boolean? inh?))
  (assert (boolean? imm?))
  (assert (boolean? ebv?))
  (assert (memq ctr-access gl-access-specifiers))
  (let* ((param-cache (hfield-ref binder 'param-cache))
	 (instance-superclass-fields
	  (if (is-t-param-class-instance? instance-superclass)
	      (let* ((param-class (get-entity-type instance-superclass))
		     (superclass-type-vars
		      (tno-field-ref param-class 'l-tvars))
		     ;; CORRECT THE FOLLOWING (?)
;;		     (superclass-type-var-values (hfield-ref instance-superclass 'params))
		     (superclass-args (tno-field-ref instance-superclass
						     'l-tvar-values))
		     (superclass-type-arg-list
		      (construct-toplevel-type-repr binder
						    superclass-args))
		     (superclass-type-var-values
		      (tuple-type->list-reject-cycles superclass-type-arg-list))
		     (original-superclass-fields
		      (tno-field-ref param-class 'l-instance-all-fields)))
		(assert (= (length superclass-type-vars)
			   (length superclass-type-var-values)))
		(let ((superclass-tvar-bindings
		       (map cons superclass-type-vars
			    superclass-type-var-values)))
		   (bind-type-vars-for-field-list1
		    binder
		    superclass-tvar-bindings
		    original-superclass-fields)))
	      (begin
		(strong-assert (and (is-t-instance?
				     binder
				     instance-superclass
				     tc-class)))
		(tno-field-ref instance-superclass 'l-all-fields))))
	 (instance-all-fields (append instance-superclass-fields
				      instance-fields)))
    (make-parametrized-class-object0
     module name address type-variables instance-superclass instance-fields
     instance-all-fields inh? imm? ebv? #t ctr-access)))
