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


;; *** Field handling for the compiler ***


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


(define (check-field-read-access? field modname-cur modname-cl)
  (let ((read-access (tno-field-ref field 's-read-access)))
    (case read-access
      ((public) #t)
      ;; Toimiiko, jos modname-cl on nil?
      ((module) (or (null? modname-cl) (module-name=? modname-cur modname-cl)))
      ((hidden) #f))))


(define (do-translate-field-ref-appl compiler t-obj-expr t-field-name-value)
  (if (not (and (is-t-primitive-object? t-field-name-value)
		(symbol? (hfield-ref t-field-name-value 'obj-prim-contents))))
      (raise 'field-ref:invalid-field))
  (let* ((obj-type (get-entity-type t-obj-expr))
	 (binder (compiler-get-binder compiler)))
    (cond
     ;; ((is-t-param-class-instance? obj-type)
     ;;  (let* ((param-class (hfield-ref obj-type 'type))
     ;; 	     (field-name (hfield-ref t-field-name-value
     ;; 				     'obj-prim-contents))
     ;; 	     (modname-cl (tno-field-ref param-class 'module))
     ;; 	     (modname-cur (get-current-module-name compiler))
     ;; 	     (field (get-instance-field-spec obj-type field-name)))
     ;; 	  (if (eqv? field '())
     ;; 	      (raise 'nonexistent-field-1)
     ;; 	      (if (check-field-read-access? field modname-cur modname-cl)
     ;; 		  (translate-const-field-ref-param binder
     ;; 						   t-obj-expr field-name #f)
     ;; 		  (raise 'field-ref-access-violation)))))
     ((is-t-instance? binder obj-type tc-class)
      (let ((inside-param-def? (hfield-ref compiler 'inside-param-def?))
	    (type-dispatched? (hfield-ref t-obj-expr 'type-dispatched?)))
	(cond
	 ((and (not inside-param-def?) (not type-dispatched?))
	  (raise 'illegal-nondispatched-type))
	 ((not type-dispatched?)
	  (let* ((field-name (hfield-ref t-field-name-value
					 'obj-prim-contents))
		 (field (get-field-spec obj-type field-name)))
	    (assert (is-t-field? field))
	    (let ((tt-field (tno-field-ref field 'type)))
	      (assert (is-type? binder tt-field))
	      (make-hrecord
	       <field-ref-expr>
	       tt-field
	       #f
	       #f
	       '()
	       
	       (is-pure-entity? t-obj-expr)
	       #f
	       #t
	       '()
	       
	       ;; The existence of the field is checked statically.
	       (entity-always-returns? t-obj-expr)
	       (entity-never-returns? t-obj-expr)
	       #t
	       t-obj-expr
	       field-name))))
	 (else
	  (let* ((field-name (hfield-ref t-field-name-value
					 'obj-prim-contents))
		 (modname-cl (tno-field-ref obj-type 'module))
		 (modname-cur (get-current-module-name compiler))
		 (field (get-field-spec obj-type field-name)))
	    (if (eqv? field '())
		(raise (list 'field-ref:nonexistent-field
			     (cons 's-field-name field-name)))
		(if (check-field-read-access? field modname-cur modname-cl)
		    (translate-const-field-ref-fwd binder
						   t-obj-expr
						   field-name)
		    (raise 'field-ref-access-violation))))))))
     (else
      (dvar1-set! t-obj-expr)
      (raise 'field-ref:invalid-object-type)))))


(define (translate-field-ref-appl compiler proc arguments)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (is-entity? proc))
  (if (and (list? arguments)
	   (= (length arguments) 2)
	   (and-map? is-entity? arguments))
      (begin
	(check-no-none-arguments (compiler-get-binder compiler)
				 arguments 'field-ref)
	(let ((obj (car arguments))
	      (sym-field-name (cadr arguments)))
	  (do-translate-field-ref-appl compiler obj sym-field-name)))
      (raise 'field-ref:invalid-args)))


;; Olion konstruoinnissa kenttien arvot kirjoitetaan
;; suoraan kohdekoodilla, joten proseduuria field-set!
;; ei silloin tarvita.
(define (check-field-write-access? field modname-cur modname-cl)
  (let ((write-access (tno-field-ref field 's-write-access)))
    (case write-access
      ((public) #t)
      ((module) (or (null? modname-cl) (module-name=? modname-cur modname-cl)))
      ((hidden) #f))))


(define (do-translate-field-set-appl compiler t-obj-expr t-field-name-value
				     t-value)
  (if (not (and (is-t-primitive-object? t-field-name-value)
		(symbol? (hfield-ref t-field-name-value 'obj-prim-contents))))
      (raise 'field-set!:invalid-field))
  (let ((obj-type (get-entity-type t-obj-expr))
	(binder (compiler-get-binder compiler)))
    (cond
     ((is-t-instance? binder obj-type tc-class)
      (let ((inside-param-def? (hfield-ref compiler 'inside-param-def?))
	    (type-dispatched? (hfield-ref t-obj-expr 'type-dispatched?)))
	(cond
	 ((and (not inside-param-def?) (not type-dispatched?))
	  (raise 'illegal-nondispatched-type))
	 ((not type-dispatched?)
	  (let ((field-name (hfield-ref t-field-name-value
					'obj-prim-contents)))
	    (make-hrecord
	     <field-set-expr>
	     tc-object
	     #f
	     #f
	     '()
	     
	     (and (is-pure-entity? t-obj-expr) (is-pure-entity? t-value))
	     #f
	     #t
	     '()

	     ;; The existence of the field is checked statically.
	     (and (entity-always-returns? t-obj-expr)
		  (entity-always-returns? t-value))
	     (or (entity-never-returns? t-obj-expr)
		 (entity-never-returns? t-value))
	     #t
	     t-obj-expr
	     field-name
	     t-value)))
	 (else
	  (let* ((field-name (hfield-ref t-field-name-value
					 'obj-prim-contents))
		 (modname-cl (tno-field-ref obj-type 'module))
		 (modname-cur (get-current-module-name compiler))
		 (field (get-field-spec obj-type field-name)))
	    (if (eqv? field '())
		(raise (list 'field-set!:nonexistent-field
			     (cons 's-field-name field-name)))
		(if (check-field-write-access?
		     field modname-cur modname-cl)
		    (translate-const-field-set-fwd binder t-obj-expr field-name
						   t-value #t
						   inside-param-def?)
		    (raise 'field-set-access-violation))))))))
     ;; ((is-t-param-class-instance? obj-type)
     ;;  (let* ((param-class (hfield-ref obj-type 'param-class))
     ;; 	     (field-name (hfield-ref t-field-name-value
     ;; 				       'contents))
     ;; 	     (modname-cl (tno-field-ref param-class 'module))
     ;; 	     (modname-cur (get-current-module-name compiler))
     ;; 	     (field (get-instance-field-spec param-class field-name)))
     ;; 	(if (check-field-write-access?
     ;; 	     field modname-cur modname-cl)
     ;; 	    (translate-const-field-set binder t-obj-expr field-name
     ;; 				       t-value #f)
     ;; 	    (raise 'field-set-access-violation))))
     (else (raise 'field-set:invalid-object-type)))))


(define (translate-field-set-appl compiler proc arguments)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (is-entity? proc))
  (if (and (list? arguments)
	   (= (length arguments) 3)
	   (and-map? is-entity? arguments))
      (begin
	(check-no-none-arguments (compiler-get-binder compiler)
				 arguments 'field-set!)
	(let ((t-obj-expr (car arguments))
	      (t-field-expr (cadr arguments))
	      (t-value-expr (caddr arguments)))
	  (do-translate-field-set-appl compiler t-obj-expr t-field-expr
				       t-value-expr)))
      (raise 'field-set!:invalid-args)))

