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


;; *** Linker environment ***


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


(define gl-i-address-env-size 10000)
(define gl-i-local-address-env-size 50)

(define-hrecord-type <address-environment> ()
  address-env-parent
  ht-bindings)


(define (construct-address-environment ae-parent i-size)
  (let ((ht-bindings (make-hash-table i-size)))
    (make-hrecord <address-environment> ae-parent ht-bindings)))


(define (check-binding sym obj-value)
  (if (and (symbol? sym)
	   (or (hrecord-is-instance? obj-value <normal-variable>)
	       (hrecord-is-instance? obj-value <keyword>)
	       (is-target-object? obj-value))
	   (is-address? (hfield-ref obj-value 'address))
	   (check-address (hfield-ref obj-value 'address)))
      #t
      (raise 'invalid-binding)))


(define (make-address-environment compiler-root-env)
  (assert (hrecord-is-instance? compiler-root-env <environment>))
  (assert (null? (hfield-ref compiler-root-env 'parent)))
  (let* ((address-env
	  (construct-address-environment '() gl-i-address-env-size))
	 (ht-bindings (hfield-ref address-env 'ht-bindings)))
    (hash-for-each
     (lambda (sym-key obj-value)
       (dvar1-set! sym-key)
       (dvar2-set! obj-value)
       (check-binding sym-key obj-value)
       (let ((address (hfield-ref obj-value 'address)))
	 (hashx-set! address-hash address-assoc ht-bindings
		     address obj-value)))
     (hfield-ref compiler-root-env 'ht))
    address-env))


(define (address-env-bindings-search ht-bindings address)
  (assert (hash-table? ht-bindings))
  (assert (hrecord-is-instance? address <address>))
  (hashx-ref address-hash address-assoc ht-bindings address))


(define (address-env-get-item address-env address)
  (assert (hrecord-is-instance? address-env <address-environment>))
  (assert (hrecord-is-instance? address <address>))
  (let ((x (address-env-bindings-search
	    (hfield-ref address-env 'ht-bindings)
	    address)))
    (if x
	x
	(let ((address-env-parent (hfield-ref address-env 'address-env-parent)))
	  (if (not-null? address-env-parent)
	      (address-env-get-item address-env-parent address)
	      #f)))))


(define (address-env-address-exists? address-env address)
  (assert (hrecord-is-instance? address-env <address-environment>))
  (assert (hrecord-is-instance? address <address>))
  (if (address-env-get-item address-env address) #t #f))


(define (address-env-bindings-search-general ht-bindings pred)
  (assert (hash-table? ht-bindings))
  (assert (procedure? pred))
  (let ((var-result #f))
    (hash-for-each
     (lambda (address var)
       (if (pred address var)
	   (set! var-result var)))
     ht-bindings)
    var-result))


(define (address-env-get-item-general address-env pred)
  (assert (hrecord-is-instance? address-env <address-environment>))
  (assert (procedure? pred))
  (let ((x (address-env-bindings-search-general
	    (hfield-ref address-env 'ht-bindings)
	    pred)))
    (if x
	x
	(let ((address-env-parent (hfield-ref address-env 'address-env-parent)))
	  (if (not-null? address-env-parent)
	      (address-env-get-item-general address-env-parent pred)
	      #f)))))


(define (address-env-add-binding! address-env location)
  (assert (hrecord-is-instance? address-env <address-environment>))
  (assert (or (is-target-object? location) (is-normal-variable? location)))
  (let ((ht-bindings (hfield-ref address-env 'ht-bindings))
	(address (hfield-ref location 'address)))
    (hashx-set! address-hash address-assoc ht-bindings address location)))


(define (address-env-add-binding2! address-env address location)
  (assert (hrecord-is-instance? address-env <address-environment>))
  (assert (or (is-target-object? location) (is-normal-variable? location)))
  (let ((ht-bindings (hfield-ref address-env 'ht-bindings)))
    (hashx-set! address-hash address-assoc ht-bindings address location)))


;; HUOM: tarkistetaan vain lähin ympäristö hierarkiassa
(define (address-env-bind-object! binder address-env rebind? to)
  (if rebind?
      (let ((to-old (address-env-bindings-search
		     (hfield-ref address-env 'ht-bindings)
		     (hfield-ref to 'address))))
	(assert (not (eq? to-old #f)))
	(let ((old-type (get-entity-type to-old))
	      (new-type (get-entity-type to)))
	  (if (and
	       (is-t-subtype-fwd? binder new-type old-type)
	       (= (length (tno-field-ref new-type 'l-all-fields))
		  (length (tno-field-ref old-type 'l-all-fields))))
	      (begin
		(set-object1! to-old to)
		to-old)
	      (begin
		(dvar1-set! to)
		(dvar2-set! to-old)
		(dvar3-set! binder)
		(let ((address (hfield-ref to 'address)))
		  (raise (list 'forward-definition-type-mismatch
			       (cons 's-name
				     (hfield-ref address 'source-name))
			       (cons 'module
				     (hfield-ref address 'module))
			       (cons 'tt-actual new-type)
			       (cons 'tt-declared old-type))))))))
      (begin
	(address-env-add-binding! address-env to)
	to)))


;; HUOM: tarkistetaan vain lähin ympäristö hierarkiassa
(define (address-env-bind-object2! binder address-env rebind? address to)
  (if rebind?
      (let ((to-old (address-env-bindings-search
		     (hfield-ref address-env 'ht-bindings)
		     address)))
	(assert (not (eq? to-old #f)))
	(let ((old-type (get-entity-type to-old))
	      (new-type (get-entity-type to)))
	  (if (and
	       (is-t-subtype-fwd? binder new-type old-type)
	       (= (length (tno-field-ref new-type 'l-all-fields))
		  (length (tno-field-ref old-type 'l-all-fields))))
	      (begin
		(set-object1! to-old to)
		to-old)
	      (begin
		(dvar1-set! to)
		(dvar2-set! to-old)
		(dvar3-set! binder)
		(raise 'forward-definition-type-mismatch-4)))))
      (begin
	(address-env-add-binding2! address-env address to)
	to)))


;; HUOM: tarkistetaan vain lähin ympäristö hierarkiassa
(define (address-env-bind-variable! binder address-env rebind? variable)
  (if rebind?
      (let* ((old-variable
	      (address-env-bindings-search
	       (hfield-ref address-env 'ht-bindings)
	       (hfield-ref variable 'address))))
	(assert (not (eq? old-variable #f)))
	(let ((old-type (get-entity-type old-variable))
	      (new-type (get-entity-type variable)))
	  (if (is-t-subtype-fwd? binder new-type old-type)
	      (begin
		;; Should we update old-variable.address, too?
		(hfield-set! old-variable 'type new-type)
		(hfield-set! old-variable 'exact-type?
			     (hfield-ref variable 'exact-type?))
		(hfield-set! old-variable 'read-only?
			     (hfield-ref variable 'read-only?))
		(hfield-set! old-variable 'forward-decl?
			     (hfield-ref variable 'forward-decl?))
		(hfield-set! old-variable 'value '())
		(hfield-set! old-variable 'value-expr
			     (hfield-ref variable 'value-expr))
		old-variable)
	      (begin
		(dvar1-set! variable)
		(dvar2-set! old-type)
		(dvar3-set! new-type)
		(dvar4-set! binder)
		(raise 'forward-definition-type-mismatch-1)))))
      (begin
	(address-env-add-binding! address-env variable)
	variable)))


(define (construct-local-address-env parent-env local-bindings)
  (assert (hrecord-is-instance? parent-env <address-environment>))
  (assert (list? local-bindings))
  (let* ((address-env
	  (construct-address-environment
	   parent-env gl-i-local-address-env-size))
	 (ht-bindings (hfield-ref address-env 'ht-bindings)))
    (for-each
     (lambda (var)
       (let ((address (hfield-ref var 'address)))
	 (hashx-set! address-hash address-assoc ht-bindings
		     address var)))
     local-bindings)
    address-env))

(define (construct-local-address-env2 parent-env local-bindings)
  (assert (hrecord-is-instance? parent-env <address-environment>))
  (assert (list? local-bindings))
  (let* ((address-env
	  (construct-address-environment
	   parent-env gl-i-local-address-env-size))
	 (ht-bindings (hfield-ref address-env 'ht-bindings)))
    (for-each
     (lambda (p-binding)
       (hashx-set! address-hash address-assoc ht-bindings
		   (car p-binding) (cdr p-binding)))
     local-bindings)
    address-env))


