;; -*-scheme-*-

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


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


(define rebind-variable-fwd! '())
(define make-tpci-pair-fwd '())
(define theme-class-of-fwd '())
(define contains-free-tvars-fwd? '())


(define-hrecord-type <entity> ()
  type type-dispatched? exact-type? address)


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


(define-hrecord-type <expression> (<entity>)
  pure? static? need-revision? to-value)


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


(define-hrecord-type <target-object> (<entity>)
  primitive?
  incomplete?
  al-field-values
  obj-prim-contents
  l-opt-contents)


(define is-target-object? (get-hrecord-type-predicate
			   <target-object>))


;; Luultavasti eq? kävisi.
(define target-object=? eqv?)


;; Field al-field-values is #f for a primitive object
;; whose value is not known.
(define (is-t-primitive-object? obj)
  (and (is-target-object? obj)
       (hfield-ref obj 'primitive?)
       (not (eqv? (hfield-ref obj 'al-field-values) #f))))


(define-hrecord-type <address> ()
  module number source-name toplevel?)


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


;; Field number of <address>:
;;   >= 0  allocated variable or constant
;;   -1    a built-in definition
;;   -2    target primitive variable


(define address-number-builtin -1)

(define address-number-target -2)


(define address-number-keyword -3)


(define (make-keyword-address s-kw)
  (assert (symbol? s-kw))
  (make-hrecord <address> '() address-number-keyword s-kw #t))

  
(define (check-address? address)
  (let ((module (hfield-ref address 'module))
	(number (hfield-ref address 'number))
	(source-name (hfield-ref address 'source-name))
	(toplevel? (hfield-ref address 'toplevel?)))
    (and (boolean? toplevel?)
	 (cond
	  ((>= number 0)
	   (and
	    (list? module)
	    (and-map? symbol? module)
	    (or (null? source-name) (symbol? source-name))))
	  ((= number address-number-builtin)
	   (and
	    (eq? module 'builtins)
	    (symbol? source-name)))
	  ((= number address-number-target)
	   (and (null? module) (not-null? source-name)))
	  ((= number address-number-keyword)
	   (eq? module '()))
	  (else (raise 'invalid-address-number))))))


(define (check-address address)
  (if (not (check-address? address))
      (begin
	(dvar1-set! address)
	(raise 'invalid-address))))

     
(define (address=? addr1 addr2)
  (and
   ;; Formerly there was "eqv?" here.
   (eq? (hfield-ref addr1 'source-name) (hfield-ref addr2 'source-name))
   ;; All address numbers should be unique within same module
   ;; so the following test may not be necessary.
   (eq? (hfield-ref addr1 'toplevel?) (hfield-ref addr2 'toplevel?))
   (= (hfield-ref addr1 'number) (hfield-ref addr2 'number))
   (equal? (hfield-ref addr1 'module) (hfield-ref addr2 'module))))


(define (alloc-builtin-loc s-name)
  (assert (symbol? s-name))
  (make-hrecord <address>
		'builtins
		address-number-builtin
		s-name
		#t))


(define (alloc-builtin-raw-loc s-name)
  (assert (symbol? s-name))
  (make-hrecord <address>
		'builtins
		address-number-builtin
		(string->symbol
		 (string-append
		  "raw_"
		  (symbol->string s-name)))
		#t))


(define (alloc-target-prim-loc t-name)
  (assert (symbol? t-name))
  (make-hrecord <address>
		'()
		address-number-target
		t-name
		#t))


(define-hrecord-type <variable> (<entity>))


;; We could move field value to <variable>.
(define-hrecord-type <normal-variable> (<variable>)
  read-only?
  volatile?
  forward-decl?
  letrec-variable?
  value
  value-expr
  exported?
  changed-in-inst?)


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


(define is-normal-variable? (get-hrecord-type-predicate
			     <normal-variable>))



(define (is-forward-decl? var)
  (hfield-ref var 'forward-decl?))


(define (variable-addresses-equal? var1 var2)
  (assert (hrecord-is-instance? var1 <variable>))
  (assert (hrecord-is-instance? var2 <variable>))
  (address=? (hfield-ref var1 'address) (hfield-ref var2 'address)))


(define (get-var-ref-source-name var-ref)
  (hfield-ref (hfield-ref (hfield-ref var-ref 'variable)
			  'address)
	      'source-name))


(define (var-ref-to-sym? var-ref sym)
   (eq? (hfield-ref (hfield-ref (hfield-ref var-ref 'variable) 'address)
		    'source-name)
        sym))


(define (tno-field-ref to fld)
  (assert (hrecord-is-instance? to <target-object>))
  (assert (not (hfield-ref to 'incomplete?)))
  (assert (symbol? fld))
  (let ((binding
	 (assv fld (hfield-ref to 'al-field-values))))
    (if binding
	(cdr binding)
	(begin
	  (write-error-info fld)
	  (raise 'field-does-not-exist-ref)))))


(define (tno-field-set! to fld value)
  (assert (hrecord-is-instance? to <target-object>))
  (assert (not (hfield-ref to 'incomplete?)))
  (assert (symbol? fld))
  (let ((binding
	 (assv fld (hfield-ref to 'al-field-values))))
    (if binding
	(set-cdr! binding value)
	(begin
	  (write-error-info fld)
	  (raise 'field-does-not-exist-set)))))


(define (make-normal-variable0 address type type-dispatched?
			       exact-type? read-only?
			       volatile?
			       forward-decl?
			       letrec-variable?
			       value value-expr exported?
			       changed-in-inst?)

  (assert (hrecord-is-instance? address <address>))
  ;; Is it necessary to accept null types?
  (assert 
   (or (null? type)
       (is-target-object? type)))
  (assert (boolean? type-dispatched?))
  (assert (boolean? exact-type?))
  (assert (boolean? read-only?))
  (assert (boolean? volatile?))
  (assert (boolean? forward-decl?))
  (assert (boolean? letrec-variable?))
  (assert (or (null? value)
	      (hrecord-is-instance? value <target-object>)))
  (assert (or (null? value-expr) (is-entity? value-expr)))
  (assert (boolean? exported?))
  (assert (boolean? changed-in-inst?))
  (make-hrecord <normal-variable>
		type
		type-dispatched?
		exact-type?
		address
		read-only?
		volatile?
		forward-decl?
		letrec-variable?
		value
		value-expr
		exported?
		changed-in-inst?))


(define (make-normal-variable address type exact-type? read-only?
			      forward-decl?
			      value exported?)
  (make-normal-variable0
   address
   type
   #t
   exact-type?
   read-only?
   #f
   forward-decl?
   #f
   value
   '()
   exported?
   #f))


(define (make-normal-variable1 address type exact-type? read-only?
			       value)
  (make-normal-variable address type exact-type? read-only? #f value #f))


(define (make-normal-variable2 address type exact-type? read-only?
			       forward-decl?
			       value value-expr exported?)
  (make-normal-variable0
   address
   type
   #t
   exact-type?
   read-only?
   #f
   forward-decl?
   #f
   value
   value-expr
   exported?
   #f))


(define (make-normal-variable3 address type type-dispatched? exact-type?
			       read-only? forward-decl?
			       value value-expr)
  (make-normal-variable0
   address
   type
   type-dispatched?
   exact-type?
   read-only?
   #f
   forward-decl?
   #f
   value
   value-expr
   #f
   #f))


(define (make-normal-variable4 address type exact-type? read-only?
			       volatile?
			       forward-decl?
			       value exported?)
  (make-normal-variable0
   address
   type
   #t
   exact-type?
   read-only?
   volatile?
   forward-decl?
   #f
   value
   '()
   exported?
   #f))


(define (make-normal-variable5 address type exact-type? read-only?
			       volatile? value)
  (make-normal-variable4 address type exact-type?
			 read-only? volatile? #f value #f))


(define (make-normal-variable6 address type type-dispatched? exact-type?
			       read-only? volatile? forward-decl?
			       value value-expr)
  (make-normal-variable0
   address
   type
   type-dispatched?
   exact-type?
   read-only?
   volatile?
   forward-decl?
   #f
   value
   value-expr
   #f
   #f))


(define (make-normal-variable7 address type exact-type? read-only? volatile?
			       forward-decl?
			       value value-expr exported?)
  (make-normal-variable0
   address
   type
   #t
   exact-type?
   read-only?
   volatile?
   forward-decl?
   #f
   value
   value-expr
   exported?
   #f))


(define (make-normal-variable8 address type exact-type? read-only?
			       volatile?
			       forward-decl?
			       value exported?)
  (make-normal-variable0
   address
   type
   #t
   exact-type?
   read-only?
   volatile?
   forward-decl?
   #f
   value
   '()
   exported?
   #f))


(define (make-normal-variable9 address type type-dispatched? exact-type?
			       read-only? value)
  (make-normal-variable0 address type type-dispatched? exact-type? read-only?
			 #f #f #f value '() #f #f))


(define (make-normal-variable10 address type type-dispatched?
				exact-type? read-only?
				volatile?
				forward-decl?
				value exported?)
  (make-normal-variable0
   address
   type
   type-dispatched?
   exact-type?
   read-only?
   volatile?
   forward-decl?
   #f
   value
   '()
   exported?
   #f))


(define (get-entity-value entity)
  (cond
   ((is-target-object? entity) entity)
   ((is-expression? entity) (hfield-ref entity 'to-value))
   ((is-normal-variable? entity) (hfield-ref entity 'value))
   (else (raise 'get-entity-value:type-mismatch))))


(define (get-and-check-value ent)
  (assert (is-entity? ent))
  (let ((result (get-entity-value ent)))
    (assert (not-null? result))
    result))


(define (is-pure-entity? ent)
  (or (is-target-object? ent)
      (and (is-expression? ent)
	   (hfield-ref ent 'pure?))))


(define (is-known-object? to)
  (and (is-target-object? to)
       (not (eq? (hfield-ref to 'al-field-values) #f))))


(define (is-known-pure-entity? ent)
  ;; TBD: if ent is an expression check that it is pure.
  (let ((to (get-entity-value ent)))
    (and (not-null? to) (is-known-object? to))))

	 
(define (entity-type-dispatched? ent)
  (assert (hrecord-is-instance? ent <entity>))
  (hfield-ref ent 'type-dispatched?))


(define (entity-type-dispatched2? ent)
  (assert (hrecord-is-instance? ent <entity>))
  (and (hfield-ref ent 'type-dispatched?)
       (not (contains-free-tvars-fwd? ent))))


(define (is-forward-decl-entity? ent)
  (or
   (and (is-target-object? ent) (hfield-ref ent 'incomplete?))
   (and (is-normal-variable? ent) (hfield-ref ent 'forward-decl?))))


(define (entity-needs-revision? ent)
  (or
   (and (is-expression? ent) (hfield-ref ent 'need-revision?))
   (and (is-target-object? ent) (not (hfield-ref ent 'type-dispatched?)))))


(define (make-target-object
	 type type-dispatched? exact-type? address
	 primitive? incomplete? al-field-values obj-prim-contents)
  ;; The type may be null only for internal use (theme-d-representation.scm).
  (assert (or (null? type) (is-target-object? type)))
  (assert (boolean? type-dispatched?))
  (assert (boolean? exact-type?))
  (assert (or (null? address) (is-address? address)))
  (assert (boolean? primitive?))
  (assert (boolean? incomplete?))
  ;; Maybe the following test has to be simplified in order to optimize
  ;; the code.
  ;; Value #f for al-field-values means an object for which only 
  ;; location and type are known.
  (assert (or (and (list? al-field-values)
		   (and-map? pair? al-field-values)
		   (and-map? symbol? (map car al-field-values)))
	      (eq? al-field-values #f)))
  ;; (assert (or
  ;; 	   (null? obj-prim-contents)
  ;; 	   (is-primitive-value? obj-prim-contents)
  ;; 	   (is-pair-class? (get-entity-type obj-prim-contents))))
  (make-hrecord <target-object>
		type type-dispatched? exact-type? address
		primitive? incomplete? al-field-values obj-prim-contents
		'()))


(define (make-target-object-w-opt
	 type type-dispatched? exact-type? address
	 primitive? incomplete? al-field-values obj-prim-contents
	 l-opt-contents)
  ;; The type may be null only for internal use (theme-d-representation.scm).
  (assert (or (null? type) (is-target-object? type)))
  (assert (boolean? type-dispatched?))
  (assert (boolean? exact-type?))
  (assert (or (null? address) (is-address? address)))
  (assert (boolean? primitive?))
  (assert (boolean? incomplete?))
  ;; Maybe the following test has to be simplified in order to optimize
  ;; the code.
  ;; Value #f for al-field-values means an object for which only 
  ;; location and type are known.
  (assert (or (and (list? al-field-values)
		   (and-map? pair? al-field-values)
		   (and-map? symbol? (map car al-field-values)))
	      (eq? al-field-values #f)))
  (assert (or
	   (null? obj-prim-contents)
	   (is-primitive-value? obj-prim-contents)
	   (is-pair-class? (get-entity-type obj-prim-contents))))
  (make-hrecord <target-object>
		type type-dispatched? exact-type? address
		primitive? incomplete? al-field-values obj-prim-contents
		l-opt-contents))


(define (make-object-with-address to-src address)
  (assert (is-target-object? to-src))
  (assert (or (null? address) (is-address? address)))
  (make-target-object
   (hfield-ref to-src 'type)
   (hfield-ref to-src 'type-dispatched?)
   (hfield-ref to-src 'exact-type?)
   address
   (hfield-ref to-src 'primitive?)
   (hfield-ref to-src 'incomplete?)
   (hfield-ref to-src 'al-field-values)
   (hfield-ref to-src 'obj-prim-contents)))


(define (set-object! dest src)
  (assert (is-target-object? dest))
  (assert (is-target-object? src))
  (hfield-set! dest 'type (hfield-ref src 'type))
  (hfield-set! dest 'type-dispatched? (hfield-ref src 'type-dispatched?))
  (hfield-set! dest 'exact-type? (hfield-ref src 'exact-type?))
  (hfield-set! dest 'address (hfield-ref src 'address))
  (hfield-set! dest 'primitive? (hfield-ref src 'primitive?))
  (hfield-set! dest 'incomplete? (hfield-ref src 'incomplete?))
  (hfield-set! dest 'al-field-values (hfield-ref src 'al-field-values))
  (hfield-set! dest 'obj-prim-contents (hfield-ref src 'obj-prim-contents)))


;; Copies a <target-object> excluding address.
(define (set-object1! dest src)
  (assert (is-target-object? dest))
  (assert (is-target-object? src))
  (hfield-set! dest 'type (hfield-ref src 'type))
  (hfield-set! dest 'type-dispatched? (hfield-ref src 'type-dispatched?))
  (hfield-set! dest 'exact-type? (hfield-ref src 'exact-type?))
  (hfield-set! dest 'primitive? (hfield-ref src 'primitive?))
  (hfield-set! dest 'incomplete? (hfield-ref src 'incomplete?))
  (hfield-set! dest 'al-field-values (hfield-ref src 'al-field-values))
  (hfield-set! dest 'obj-prim-contents (hfield-ref src 'obj-prim-contents)))


(define (clone-object src)
  ;; Note that the field values are not cloned.
  (make-target-object
   (hfield-ref src 'type)
   (hfield-ref src 'type-dispatched?)
   (hfield-ref src 'exact-type?)
   (hfield-ref src 'address)
   (hfield-ref src 'primitive?)
   (hfield-ref src 'incomplete?)
   (hfield-ref src 'al-field-values)
   (hfield-ref src 'obj-prim-contents)))


(define (set-object2! dest src)
  (assert (is-target-object? dest))
  (assert (or (pair? src) (is-target-object? src)))
  (if (pair? src)
      (let ((type-new (make-tpci-pair-fwd (theme-class-of-fwd (car src))
					  (theme-class-of-fwd (cdr src))))
	    (al-field-values (list (cons 'first (car src))
				   (cons 'second (cdr src)))))
	(hfield-set! dest 'type type-new)
	(hfield-set! dest 'type-dispatched? (hfield-ref src 'type-dispatched?))
	;; Not completely sure about the following.
	(hfield-set! dest 'exact-type? #t)
	(hfield-set! dest 'address (hfield-ref src 'address))
	(hfield-set! dest 'primitive? #f)
	(hfield-set! dest 'incomplete? #f)
	(hfield-set! dest 'al-field-values al-field-values)
	(hfield-set! dest 'obj-prim-contents '())))
      (set-object! dest src))


;; Copies a <target-object> excluding address.
(define (set-object3! dest src)
  (assert (is-target-object? dest))
  (assert (or (pair? src) (is-target-object? src)))
  (if (pair? src)
      (let ((type-new (make-tpci-pair-fwd (theme-class-of-fwd (car src))
					  (theme-class-of-fwd (cdr src))))
	    (al-field-values (list (cons 'first (car src))
				   (cons 'second (cdr src)))))
	(hfield-set! dest 'type type-new)
	(hfield-set! dest 'type-dispatched? (hfield-ref src 'type-dispatched?))
	(hfield-set! dest 'exact-type? #f)
	(hfield-set! dest 'primitive? #f)
	(hfield-set! dest 'incomplete? #f)
	(hfield-set! dest 'al-field-values al-field-values)
	(hfield-set! dest 'obj-prim-contents '())))
      (set-object1! dest src))


(define (rebind-variable! var new-var)
  (assert (is-normal-variable? var))
  (assert (is-forward-decl? var))
  (assert (is-normal-variable? new-var))
  (if (not (eq? (hfield-ref var 'read-only?)
		(hfield-ref new-var 'read-only?)))
      (raise 'declaration-immutability-mismatch-2))
  (hfield-set! var 'type (hfield-ref new-var 'type))
  (hfield-set! var 'type-dispatched? (hfield-ref new-var 'type-dispatched?))
  (hfield-set! var 'exact-type? (hfield-ref new-var 'exact-type?))
  (hfield-set! var 'read-only? (hfield-ref new-var 'read-only?))
  (hfield-set! var 'forward-decl?
	       (hfield-ref new-var 'forward-decl?))
  (hfield-set! var 'letrec-variable? (hfield-ref new-var 'letrec-variable?))
  (hfield-set! var 'value-expr (hfield-ref new-var 'value-expr))
  (hfield-set! var 'exported? (hfield-ref new-var 'exported?))
  (hfield-set! var 'changed-in-inst? (hfield-ref new-var 'changed-in-inst?))
  (let ((new-value (hfield-ref new-var 'value))
	(old-value (hfield-ref var 'value)))
    (cond
     ((null? old-value)
      (hfield-set! var 'value new-value))
     ((null? new-value)
      (hfield-set! var 'value '()))
     (else
      (set-object! old-value new-value)))))


(set! rebind-variable-fwd! rebind-variable!)

