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


;; Procedures and data structures for compiling letrec and letrec* expressions


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


(define-hrecord-type <letrec-env> ()
  parent
  inside-proc?
  variables)


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


(define (access-letrec-variable? letrec-env var inside-proc?)
  (assert (or (null? letrec-env)
	      (is-letrec-env? letrec-env)))
  (assert (is-normal-variable? var))
  (assert (boolean? inside-proc?))
  (if (null? letrec-env)
      #t
      (let* ((new-inside-proc?
	      (or inside-proc?
		  (hfield-ref letrec-env 'inside-proc?)))
	     (cur-vars (hfield-ref letrec-env 'variables)))
	(if (memv var cur-vars)
	    new-inside-proc?
	    (access-letrec-variable?
	     (hfield-ref letrec-env 'parent)
	     var
	     new-inside-proc?)))))


(define (make-letrec-variable compiler name type read-only? volatile?)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (symbol? name))
  (assert (is-target-object? type))
  (assert (boolean? read-only?))
  (assert (boolean? volatile?))
  ;; Note that the variable is forward declared (locally).
  ;; A letrec variable is lexical.
  (let* ((address (compiler-alloc-loc compiler name #f))
	 (exact-type? (is-final-class? (hfield-ref compiler 'binder) type))
	 (var
	  (make-normal-variable0
	   address
	   type
	   #t
	   exact-type?
	   read-only?
	   volatile?
	   #t
	   #t
	   '()
	   '()
	   #f
	   #f)))
    var))


(define (check-letrec-var-type binder var c-init-expr)
  (assert (is-binder? binder))
  (let ((declared-type (get-entity-type var))
	(actual-type (get-entity-type c-init-expr)))
    (assert (not-null? declared-type))
    (assert (not-null? actual-type))
    (if (not (is-t-subtype? binder actual-type declared-type))
      (raise (list 'letrec-var-type-mismatch
		   (cons 's-name (hfield-ref (hfield-ref var 'address)
					     'source-name))
		   (cons 'tt-actual actual-type)
		   (cons 'tt-declared declared-type))))))


(define (check-letrec-var-types binder vars c-init-exprs)
  (assert (is-binder? binder))
  (for-each (lambda (var c-init-expr)
	      (check-letrec-var-type binder var c-init-expr))
	    vars c-init-exprs))


(define (update-letrec-var! var c-init-expr read-only?)
  (assert (is-normal-variable? var))
  (assert (is-entity? c-init-expr))
  (assert (boolean? read-only?))
  (if read-only?
      (begin
	(hfield-set! var 'type
		     (get-entity-type c-init-expr))
	(hfield-set! var 'forward-decl? #f)
	(hfield-set! var 'value
		     (get-entity-value c-init-expr))
	(hfield-set! var 'value-expr
		     ;; Not sure if incomplete objects work here.
		     (if (is-target-object? c-init-expr)
			 c-init-expr
			 '()))
	(hfield-set! var 'exact-type?
		     (hfield-ref c-init-expr 'exact-type?)))
      (begin
	(hfield-set! var 'forward-decl? #f))))


(define (update-letrec-vars! vars c-init-exprs read-only?)
  (for-each
   (lambda (var c-init-expr)
     (update-letrec-var! var c-init-expr read-only?))
   vars c-init-exprs))


(define (check-letrec-vars varspecs)
  (if (not (and-map?
	    (lambda (varspec)
	      (and
	       (list? varspec)
	       (= (length varspec) 3)))
	    varspecs))
      (raise 'invalid-letrec-variable)))


(define (parse-letrec-vars compiler env varspecs read-only? volatile?)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (list? varspecs))
  (assert (boolean? read-only?))
  (check-letrec-vars varspecs)
  (let ((names (map car varspecs))
	(s-types (map cadr varspecs))
	(s-init-exprs (map caddr varspecs)))
    (let ((c-types (map (lambda (s-type)
			  (translate-expr-fwd compiler env #f s-type))
			s-types)))
      (if (and (not-null? c-types)
	       (let ((binder (compiler-get-binder compiler)))
		 (or-map?
		  (lambda (type) (entity-is-none1? binder type)) c-types)))
	  (raise 'letrec-declaration-with-none)
	  (let* ((vars (map (lambda (name c-type)
			      (make-letrec-variable compiler name c-type
						    read-only? volatile?))
			    names c-types))
		 (new-env (make-environment
			   env
			   (map cons names vars)))
		 (cur-letrec-env (hfield-ref compiler 'current-letrec-env))
		 (new-letrec-env
		  (make-hrecord <letrec-env>
				cur-letrec-env
				#f
				vars)))
	    (hfield-set! compiler 'current-letrec-env new-letrec-env)
	    (let ((c-init-exprs
		   (map* (lambda (expr s-name)
			   (set-proc-expr compiler expr 'local s-name)
			   (let ((result
				  (translate-expr-fwd compiler new-env #f
						      expr)))
			     (unset-proc-expr compiler expr)
			     result))
			 s-init-exprs names)))
	      (let ((s-name-none (find-none-type
				  (compiler-get-binder compiler)
				  (map get-entity-type c-init-exprs)
				  names)))
		(if (not-null? s-name-none)
		    (raise (list 'letrec-initializer-with-type-none
				 (cons 's-name s-name-none)))
		    (begin
		      (hfield-set! compiler 'current-letrec-env cur-letrec-env)
		      (if (not (hfield-ref compiler 'inside-param-def?))
			  (check-letrec-var-types
			   (hfield-ref compiler 'binder)
			   vars c-init-exprs))
		      (update-letrec-vars! vars c-init-exprs read-only?)
		      (list
		       (map (lambda (name var type init-expr)
			      (list
			       (make-primitive-object tc-symbol name)
			       var var type init-expr
			       gl-false))
			    names vars c-types c-init-exprs)
		       new-env))))))))))
