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


;; *** Translation utility functions for the compiler ***


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


(define gl-ctr10 0)


(define-hrecord-type <proc-attr> ()
  pure? force-pure? always-returns? never-returns? static-method?)


(define (check-env env)
  (assert (hrecord-is-instance? env <environment>))
  (let ((par (hfield-ref env 'parent))
	(ht (hfield-ref env 'ht)))
    (cond ((and (not-null? ht) (not (hash-table? ht)))
	   (raise 'invalid-env-hash-table))
	  ((null? par) #t)
	  ((hrecord-is-instance? par <environment>)
	   (check-env par))
	  (else
	   (raise 'invalid-parent-env)))))


;; Optimizes the expression in case there are 0 or 1 subexpressions.
(define (make-compound-expression subexprs)
  (let ((len (length subexprs)))
    (cond
     ((= len 0)
      empty-expression)
     ((= len 1)
      (car subexprs))
     (else
      (let* ((last-expr (last subexprs))
	     (last-type (get-entity-type last-expr))
	     (last-value (get-entity-value last-expr))
	     (exact-type? (hfield-ref last-expr 'exact-type?))
	     (pure? (and-map? is-pure-entity? subexprs))
	     (need-revision?
	      (or-map? entity-needs-revision?
		       subexprs))
	     (type-dispatched? (entity-type-dispatched? last-expr))
	     (always-returns?
	      (and-map? entity-always-returns? subexprs))
	     (never-returns?
	      (or-map? entity-never-returns? subexprs)))
	(make-hrecord
	 <compound-expression>
	 last-type
	 type-dispatched?
	 exact-type?
	 '()
	 pure?
	 #f
	 need-revision?
	 last-value
	 always-returns?
	 never-returns?
	 subexprs))))))


(define (do-wrap-compound-expression s-subexprs translate)
  (assert (list? s-subexprs))
  (assert (procedure? translate))
  (let* ((t-subexprs (map* translate s-subexprs))
	 (result
	  (make-compound-expression t-subexprs)))
    result))


(define (source-code-element? expr) (not (hrecord? expr)))


;; Result value:
;;  #t:  bind the declaration
;;  #f:  add new declaration
(define (check-existing-binding? compiler bound-value)
  (cond
   ((hrecord-is-instance? bound-value <keyword>)
    (raise 'trying-to-define-keyword))
   ((not bound-value) #f)
   ((and (not (is-target-object? bound-value))
	 (not (is-normal-variable? bound-value)))
    (raise 'trying-to-define-nonvariable))
   ((is-forward-decl-entity? bound-value)
    (let ((module (hfield-ref
		 (hfield-ref bound-value 'address)
		 'module)))
      (if (or (null? module)
	      (equal? module
		      (hfield-ref compiler 'toplevel-unit-name)))
	  #t
	  (begin
	    (set-error-info! compiler bound-value)
	    (raise 'invalid-redefinition)))))
   (else
    (set-error-info! compiler bound-value)
    (raise 'duplicate-definition))))


(define (bind-variable-with-object! compiler symtbl rebind? read-only? s-name
				    type value)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (boolean? rebind?))
  (assert (symbol? s-name))
  (assert (hrecord-is-instance? type <target-object>))
  (assert (or (null? value) (hrecord-is-instance? value <target-object>)))
  (if rebind?
      (let ((variable (get-symbol symtbl s-name))
	    (binder (compiler-get-binder compiler)))
	(strong-assert (is-normal-variable? variable))
	(let ((decl-read-only? (hfield-ref variable 'read-only?))
	      (old-type (get-entity-type variable)))
	  (if (not (eq? read-only? decl-read-only?))
	      (raise 'declaration-immutability-mismatch))
	  (strong-assert (is-t-instance? binder type tc-class))
	  (strong-assert (is-t-instance? binder old-type tc-class))
	  ;; The actual class has to be a subtype of
	  ;; the declared class and the both types
	  ;; must have equal number of fields.
	  (if (and
	       (is-t-subtype? binder type old-type)
	       (= (length (tno-field-ref type 'l-all-fields))
		  (length (tno-field-ref old-type 'l-all-fields))))
	      ;; TBR: tmp1 setting
	      (let* ((tmp1 (begin (dvar1-set! variable)
				  (dwl3 "bind-variable-with-object!/4") 0))
		     (old-value (hfield-ref variable 'value))
		     (new-value
		      (cond
		       ((null? old-value) value)
		       ((hfield-ref old-value 'incomplete?)
			(if (not-null? value)
			    (begin
			      (set-object1! old-value value)
			      old-value)
			    (raise 'invalid-redefinition-of-incomplete-value-2)))
		       (else (raise 'invalid-value-redefinition-2)))))
		(begin
		  (hfield-set! variable 'type type)
		  (hfield-set! variable 'type-dispatched? #t)
		  ;; (hfield-set! variable 'type-dispatched?
		  ;; 	       (and (not-null? new-value)
		  ;; 		    (hfield-ref new-value 'type-dispatched?)))
		  (hfield-set! variable 'exact-type?
			       (and (not-null? new-value)
				    (hfield-ref new-value 'exact-type?)))
		  (hfield-set! variable 'read-only? read-only?)
		  (hfield-set! variable 'forward-decl? #f)
		  (hfield-set! variable 'value new-value)
		  variable))
	      (raise 'forward-definition-type-mismatch-2))))
      (let* ((address (compiler-alloc-loc compiler s-name #t))
	     (variable
	      (make-normal-variable
	       address
	       type
	       (if (not-null? value)
		   (hfield-ref value 'exact-type?)
		   #f)
	       read-only?
	       #f
	       value
	       #f)))
	(add-symbol! symtbl s-name variable)
	variable)))


(define (translate-define-gen-proc compiler symtbl name)
  (assert (symbol? name))
  (let* ((address (compiler-alloc-loc compiler name #t))
	 (var (make-new-gen-proc address #f))
	 (to (make-object-with-address (hfield-ref var 'value) address)))
    (add-symbol! symtbl name to)
    ;; MIETI declared?
    (cons
     (make-hrecord <generic-procedure-definition>
		   tt-none #t #t '()
		   #f #f #f '()
		   var tmc-gen-proc '() #f #f #f)
     to)))


(define (get-method-definition-var-def compiler t-method s-name)
  (let* ((address (compiler-alloc-loc compiler s-name #t))
	 (var (make-normal-variable2
	      address
	      (get-entity-type t-method)
	      #t
	      #t
	      #f
	      (get-entity-value t-method)
	      t-method
	      #f)))
    (make-normal-var-def
     (get-entity-type t-method)
     var
     t-method
     #f)))


(define (translate-forward-declaration compiler symtbl var-name r-type
				       read-only? volatile?)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (symbol? var-name))
  (assert (is-target-object? r-type))
  (assert (boolean? read-only?))
  (assert (boolean? volatile?))
  (let ((binder (compiler-get-binder compiler)))
    (cond
     ((not (symbol? var-name))
      (raise 'syntax-error-in-forward-declaration))
     ((symbol-exists? symtbl var-name)
      (let ((old-ent (get-symbol symtbl var-name)))
	(if (hrecord-is-instance? old-ent <keyword>)
	    (raise (list 'cannot-declare-keyword (cons 's-name var-name)))
	    (begin
	      (assert (hrecord-is-instance? old-ent <entity>))
	      (let ((old-type (get-entity-type old-ent)))
		(cond
		 ((and (is-normal-variable? old-ent)
		       (not (is-forward-decl? old-ent)))
		  (raise (list 'cannot-declare-existing-variable-1
			       (cons 's-name var-name))))
		 ((and (is-target-object? old-ent)
		       (not (hfield-ref old-ent 'incomplete?)))
		  (raise (list 'cannot-declare-existing-variable-2
			       (cons 's-name var-name))))
		 ((let ((address (hfield-ref old-ent 'address)))
		    (and (not-null? address)
			 (not-null? (hfield-ref address 'module))
			 (not (equal?
			       (hfield-ref address 'module)
			       (hfield-ref compiler 'toplevel-unit-name)))))
		  (raise
		   (list 'declaration-in-different-module
			 (cons 's-var-name var-name)
			 (cons 'module (hfield-ref (hfield-ref old-ent 'address)
						   'module)))))
		 ((and read-only?
		       (or (not (is-t-instance? binder old-type tc-class))
			   (not (is-t-instance? binder r-type tc-class))))
		  (raise 'decl-type-not-a-class))
		 ((and (not read-only?)
		       (or (not (is-t-instance? binder old-type tt-type))
			   (not (is-t-instance? binder r-type tt-type))))
		  (raise 'decl-type-not-a-type))
		 ((and read-only?
		       (not (is-t-subtype? binder r-type old-type)))
		  (raise (list 'redecl-type-mismatch
			       (cons 's-name var-name)
			       (cons 'tt-new r-type)
			       (cons 'tt-old old-type))))
		 ((and (not read-only?)
		       (not (equal-types? binder r-type old-type)))
		  (raise (list 'redecl-type-mismatch
			       (cons 's-name var-name)
			       (cons 'tt-new r-type)
			       (cons 'tt-old old-type))))
		 ((and read-only?
		       (not
			(= (length (tno-field-ref r-type 'l-all-fields))
			   (length (tno-field-ref old-type 'l-all-fields)))))
		  (raise 'decl-invalid-subtype))
		 (read-only?
		  (strong-assert (is-target-object? old-ent))
		  (let* ((address (hfield-ref old-ent 'address))
			 (to
			  (make-target-object
			   r-type
			   #t
			   (and
			    (is-t-instance? binder r-type tc-class)
			    (not (tno-field-ref r-type 'inheritable?)))
			   address
			   #f
			   #t
			   #f
			   '()))
			 (var
			  (make-normal-variable4 address r-type #f
						 read-only? volatile?
						 #t
						 to #f)))
		    (set-object1! old-ent to)
		    (make-hrecord
		     <forward-declaration>
		     tt-none
		     #t
		     #t
		     '()
		     #f
		     #f
		     #f
		     '()
		     var
		     r-type
		     #f
		     #f)))
		 (else
		  (strong-assert (is-normal-variable? old-ent))
		  (let* ((address (hfield-ref old-ent 'address))
			 (var
			  (make-normal-variable address r-type #f read-only?
						#t
						'() #f)))
		    (rebind-variable! old-ent var)
		    (make-hrecord
		     <forward-declaration>
		     tt-none
		     #t
		     #t
		     '()
		     #f
		     #f
		     #f
		     '()
		     old-ent
		     r-type
		     #f
		     #f)))))))))
     ((and read-only?
	   (not (is-t-instance? binder r-type tc-class)))
      (raise 'decl-type-not-a-class))
     ((and (not read-only?)
	   (not (is-t-instance? binder r-type tt-type)))
      (raise 'decl-type-not-a-type))
     (else
      ;; Seuraava koodi ei välttämättä toimi primitiivisille tyypeille.
      (let* ((address (compiler-alloc-loc compiler var-name #t))
	     (to
	      (if read-only?
		  (make-target-object
		   r-type
		   #t
		   (and
		    (is-t-instance? binder r-type tc-class)
		    (not (tno-field-ref r-type 'inheritable?)))
		   address
		   #f
		   #t
		   #f
		   '())
		  '()))
	     (var (make-normal-variable4 address r-type #f
					 read-only? volatile?
					 #t to #f)))		  
	  (if read-only?
	      (begin
		(add-symbol! symtbl var-name to)
		(add-public-decl! compiler to))
	      (begin
		(add-symbol! symtbl var-name var)
		(add-public-decl! compiler var)))
	  (make-hrecord
	   <forward-declaration>
	   tt-none
	   #t
	   #t
	   '()
	   #f
	   #f
	   #f
	   '()
	   var
	   r-type
	   #f
	   #f))))))


(define (create-exception-variable compiler exc-var-name)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (symbol? exc-var-name))
  (let ((address (compiler-alloc-loc compiler exc-var-name #f)))
    (make-normal-variable1
     address
     tc-object
     #f
     #t
     '())))


;; Assume that var is not read only.
(define (may-change-variable? env var-name)
  (assert (or (null? env) (hrecord-is-instance? env <environment>)))
  (assert (symbol? var-name))
  (if (null? env)
      #t
      (let ((binding (get-symbol env var-name)))
	(cond
	 ((and (is-normal-variable? binding)
	       (hfield-ref binding 'volatile?))
	  #t)
	 ;; The order of the two following tests is significant.
	 ((symbol-exists-deepest? env var-name) #t)
	 ((hrecord-is-instance? env <pure-proc-env>) #f)
	 (else (may-change-variable? (hfield-ref env 'parent) var-name))))))


(define (check-constructor-access? access modname-cur modname-cl)
  (assert (and (symbol? access) (memq access gl-access-specifiers)))
  (assert (is-module-name? modname-cur))
  (assert (is-module-name? modname-cl))
  (case access
    ((public) #t)
    ;; Testing is-module-name? ensures that modname-cl is not null.
    ((module) (or (null? modname-cl) (module-name=? modname-cur modname-cl)))
    ((hidden) #f)))


(define (parse-proc-attributes s-attr)
  (if (null? s-attr)
      ;; Default attributes: nonpure, may return, and nonstatic method
      (make-hrecord <proc-attr> #f #f #f #f #f)
      ;; A single attribute does not need to be contained in a list.
      (let ((attr-lst (if (list? s-attr) s-attr (list s-attr))))
	(cond
	 ((not (and-map? symbol? attr-lst))
	  (raise 'invalid-procedure-attribute))
	 ((not (lset<= eq? attr-lst gl-proc-attributes))
	  (raise 'invalid-procedure-attribute))
	 ((not (distinct-elements? attr-lst eq?))
	  (raise 'duplicate-proc-attribute))
	 (else
	  (let ((pure?
		 (or
		  (and (member? gl-pure attr-lst)
 		       (not (member? gl-nonpure attr-lst)))
		  (member? gl-force-pure attr-lst)))
		(force-pure? (member? gl-force-pure attr-lst))
		(always-returns?
		 (and (member? gl-always-returns attr-lst)
		      (not (member? gl-never-returns attr-lst))
		      (not (member? gl-may-return attr-lst))))
		(never-returns?
		 (and (member? gl-never-returns attr-lst)
		      (not (member? gl-always-returns attr-lst))
		      (not (member? gl-may-return attr-lst))))
		;; (static-method? (member? gl-static-method attr-lst)))
		(static-method? #f))
	    (if (or
		 (and (not pure?) force-pure?)
		 (and always-returns? never-returns?))
		(raise 'inconsistent-proc-attributes)
		(make-hrecord <proc-attr>
			      pure? force-pure? always-returns? never-returns?
			      static-method?))))))))


(define (add-method-decl! compiler gen-proc mt)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (is-target-object? mt))
  (hfield-set! compiler 'method-decls
	       (cons (cons (cons gen-proc mt) #f)
		     (hfield-ref compiler 'method-decls))))


(set! add-method-decl-fwd! add-method-decl!)


(define (mark-method-decl! compiler genproc mt)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (is-target-object? mt))
  (let* ((l-method-decls (hfield-ref compiler 'method-decls))
	 (p (assoc (cons genproc mt) l-method-decls equal-pairs?)))
    (if p (set-cdr! p #t))))


(define (bind-object! compiler symtbl s-name to-decl to-value type)
  (assert (or (null? to-value) (is-target-object? to-value)))
  (assert (or (null? to-decl) (is-target-object? to-decl)))
  (assert (or (null? to-decl) (hfield-ref to-decl 'incomplete?)))
  (let* ((binder (compiler-get-binder compiler))
	 (to2
	  ;; If to-value is null we know only the type
	  ;; and address of the variable and we set
	  ;; al-field-values to #f.
	  (if (not-null? to-value)
	      to-value
	      (make-unknown-object
	       type
	       (is-final-class? binder type))))
	 (address (if (not-null? to-decl)
		      (hfield-ref to-decl 'address) 
		      (compiler-alloc-loc compiler s-name #t)))
	 (to-new (make-object-with-address
		  to2 address))
	 (variable
	  (make-normal-variable
	   address
	   type
	   (hfield-ref to2 'exact-type?)
	   #t
	   #f
	   to2
	   #f)))
    (if (not-null? to-decl)
	(set-object! to-decl to-new))
    ;; We bind the variable name to an object.
    (if (not (get-symbol symtbl s-name))
	(add-symbol! symtbl s-name to-new))
    variable))


(define (check-toplevel toplevel?)
  (if (not toplevel?) (raise 'illegal-toplevel-form)))


(define (is-legal-value0? compiler address)
  (or
   (null? address)
   (and (memq (hfield-ref compiler 'unit-type)
	      '(proper-program script))
	(let ((module (hfield-ref address 'module)))
	  (and (not-null? module)
	       (not (equal?
		     module
		     (hfield-ref compiler 'toplevel-unit-name))))))
   (let ((module (hfield-ref address 'module)))
     (and (not-null? module)
	  (member? module
		   (hfield-ref compiler 'l-prelinked-bodies))))))


(define (is-legal-value-object? compiler x)
  (if (and (is-target-object? x) (hfield-ref x 'incomplete?))
      (is-legal-value0? compiler (hfield-ref x 'address))
      #t))

   
(define (is-legal-value-ref? compiler x)
  (if (hrecord-is-instance? x <variable-reference>)
      (let ((var (hfield-ref x 'variable)))
	(if (hfield-ref var 'forward-decl?)
	    (is-legal-value0? compiler (hfield-ref var 'address))
	    #t))
      #t))
