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


;; Common procedure utilities for the compiler and the linker


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


(define translate-uniform-list-type-expression-fwd '())

(define translate-tuple-type-with-tail-fwd '())

(define join-tuple-types-fwd '())

(define contains-type-modifiers-fwd? '())

(define bind-type-vars3-fwd '())

(define gl-ctr9 0)


(define-hrecord-type <procedure-arg-list> ()
  arg-list-type
  impl-arg-types
  arg-descs)


(define (do-bind-loop bind tvars iter-var subexprs iter-expr)
  (assert (list? tvars))
  (check-bindings tvars)
  (assert (is-t-type-variable? iter-var))
  (assert (and (list? subexprs)
	       (or (null? subexprs)
		   (and-map? is-target-object? subexprs))))
  (let ((results '())
	(inst '()))
    (do ((subexprs-cur subexprs (cdr subexprs-cur)))
	((null? subexprs-cur))
      (let* ((cur-type (car subexprs-cur))
	     (new-tvars
	      (cons
	       (cons iter-var cur-type)
	       tvars))
	     (br (bind new-tvars iter-expr))
	     (cur-res (car br))
	     (cur-inst (cdr br)))

	;; TBR
	(dwl4 "bound type:")
	(dwl4 (debug-get-string cur-res))

	(set! results (append results (list cur-res)))
	(set! inst (append inst cur-inst))))
    (cons results inst)))


(define (handle-splice-expression binder type)
;;  (assert (is-binder? binder))
  (assert (is-t-splice? type))
  (let ((component (tno-field-ref type 'type-component)))
    (assert (not-null? component))
    (if (contains-type-modifiers-fwd? component)
	type
	(cond
	 ((list? component)
	  (apply make-tuple-type-fwd component))
	 ((is-tuple-type-fwd? binder component)
	  component)
	 (else
	  (dvar1-set! type)
	  (raise 'invalid-splice-expression))))))
	;; (cond
	;;  ((list? component) component)
	;;  ((is-tuple-type-fwd? binder component)
	;;   (tuple-type->list-reject-cycles-fwd component))
	;;  (else (raise 'invalid-splice-expression))))))
	;; (let ((component1
	;;        (cond
	;; 	((list? component) component)
	;; 	((is-tuple-type-fwd? binder component)
	;; 	 (tuple-type->list-reject-cycles-fwd component))
	;; 	(else (raise 'invalid-splice-expression)))))
	;;   (strong-assert (and (list? component1) (= (length component1) 1)))
	;;   (if (or (list? component1)
	;; 	  (is-t-type-list? component1)
	;; 	  (is-tuple-type-fwd? binder component1))
	;;       component1
	;;       type)))))


(define (handle-tuples type)
  (if (is-tuple-type0-fwd? type)
      (tuple-type->list-reject-cycles-fwd type)
      type))


(define (construct-type-repr binder type)
  (assert (is-binder? binder))
  (assert (is-target-object? type))
  (let ((result
	 (cond
	  ((entity-is-none1? binder type)
	   tt-none)
	  ((is-t-type-list? type)
	   (construct-type-list-repr binder type))
	  ((is-t-type-loop? type)
	   (construct-type-loop-repr binder type))
	  ((is-t-type-join? type)
	   (construct-type-join-repr binder type))
	  ((is-t-rest? type)
	   (raise 'invalid-use-of-rest-expr))
	  ((is-t-splice? type)
	   (handle-splice-expression binder type))
	  (else
	   (list type)))))
    (dwl4 "construct-type-repr EXIT")
    result))


(define (construct-normal-type-list-repr lst)
  (strong-assert (not (or-map? is-t-rest? lst)))
  ;; Checking is-type-list? is not needed if we trust that
  ;; type lists are properly simplified before calling this
  ;; procedure.
  ;; ---
  ;; (if (and-map? (lambda (item)
  ;; 		  (not (and
  ;; 			(is-splice-expression? item)
  ;; 			(not (or
  ;; 			      (is-type-list?
  ;; 			       (hfield-ref item 'component-type))
  ;; 			      (is-tuple-type-fwd?
  ;; 			       (hfield-ref item 'component-type)))))))
  ;; 		lst)
  (cond
   ((and-map? (lambda (item)
		(not (and
		      (is-t-splice? item)
		      (not
		       (is-tuple-type0-fwd?
			(tno-field-ref item 'type-component))))))
	      lst)
    (let* ((lst2
	    (apply append
		   (map (lambda (item)
			  (if (is-t-splice? item)
			      (let ((component
				     (tno-field-ref item 'type-component)))
				;; The next test should not fail because
				;; of the and-map? test.
				(if (is-tuple-type0-fwd? component)
				    (tuple-type->list-reject-cycles-fwd
				     component)
				    (raise 'corrupted-splice)))
			      (list item)))
			lst)))
	   (result
	    (if (contains-type-modifiers-fwd? lst2)
		(make-type-list-object lst2)
		(apply make-tuple-type-fwd lst2))))
      result))
   ;; We should also handle the situation where there are expressions
   ;; before the splice expression in the argument list.
   ((and (= (length lst) 1)
	 (is-t-splice? (car lst)))
    (tno-field-ref (car lst) 'type-component))
   (else
    (let ((result (make-type-list-object lst)))
      result))))


(define (do-construct-type-list-repr binder types)
  (let ((result
	 (cond
	  ((null? types) tc-nil)
	  ((and
	    (is-t-rest? (last types))
	    (> (length types) 1))
	   (let ((tuple-types (drop-right types 1))
		 (tail-type (tno-field-ref (last types) 'type-component)))
	     (translate-tuple-type-with-tail-fwd
	      (construct-normal-type-list-repr tuple-types)
	      (make-tt-uniform-list tail-type))))
	  ((is-t-rest? (last types))
	   ;; Rest argument is the only argument.
	   (make-tt-uniform-list
	    (tno-field-ref (last types) 'type-component)))
	  (else
	   (construct-normal-type-list-repr types)))))
    result))
    

(define (construct-type-list-repr binder type)
  (assert (is-t-type-list? type))
  (let ((subtypes (hfield-ref type 'subtypes)))
     (do-construct-type-list-repr binder subtypes)))


(define (construct-type-loop-repr binder type)
  (assert (is-binder? binder))
  (assert (is-t-type-loop? type))
  (let* ((subtype-list0 (tno-field-ref type 'x-subtypes))
	 (subtype-list
	  (if (or (list? subtype-list0)
		  (is-tuple-type-fwd? binder subtype-list0))
	      subtype-list0
	      (construct-argument-type-repr binder
					    subtype-list0))))
    (let ((result
	   (if (is-t-type-variable? subtype-list)
	       ;; If the whole subtype list of a type loop is a type variable
	       ;; it is not processed further here.
	       type
	       (let ((subexprs
		      (cond
		       ((list? subtype-list) subtype-list)
		       ((is-t-type-list? subtype-list)
			(hfield-ref subtype-list 'subtypes))
		       ((is-tuple-type-fwd? binder subtype-list)
			(tuple-type->list-reject-cycles-fwd
			 subtype-list))
		       (else
			(raise 'invalid-type-loop)))))
		 (let ((result-types
			(car 
			 (do-bind-loop
			  (lambda (tvars repr)
			    (bind-type-vars3-fwd
			     binder
			     tvars repr))
			  '()
			  ;; Formerly hfield-ref
			  (tno-field-ref type 'tvar)
			  subexprs
			  ;; Formerly hfield-ref
			  (tno-field-ref type 'x-iter-expr)))))
		   (apply make-tuple-type-fwd
			  result-types))))))
      (dwl4 "construct-type-loop-repr EXIT")
      result)))


(define (construct-type-join-repr binder type)
  (assert (is-binder? binder))
  (assert (is-t-type-join? type))
  (let ((subtypes (tno-field-ref type 'l-subtypes)))
    (if (or
	 (is-t-type-variable? subtypes)
	 (contains-type-variables-fwd? type)
	 (and (is-t-splice? (car subtypes))
	      (is-t-type-variable? (tno-field-ref (car subtypes)
						  'type-component))))
	(begin
	  type)
	(let ((subexprs1 (map 
			  (lambda (cur-expr)
			    (handle-tuples
			     (construct-type-repr binder cur-expr)))
			  subtypes)))
	  (if (and-map? list? subexprs1)
	      (let ((subexprs2 (apply append subexprs1)))
		(strong-assert (and-map? is-tuple-type0-fwd? subexprs2))
		(let ((result
		       (apply join-tuple-types-fwd subexprs2)))
		  result))
	      type)))))


(define construct-toplevel-type-repr do-construct-type-list-repr)


(set! construct-toplevel-type-repr-fwd construct-toplevel-type-repr)


(define (construct-argument-type-repr binder type)
  (cond
   ((is-t-splice? type)
    (tno-field-ref type 'type-component))
   ((is-t-rest? type)
    (translate-uniform-list-type-expression-fwd
     binder (tno-field-ref type 'type-component)))
   (else type)))


(set! construct-argument-type-repr-fwd construct-argument-type-repr)


(define (get-impl-arg-types binder arg-descs)
  (assert (is-binder? binder))
  (map*
   (lambda (desc)
     (construct-argument-type-repr binder desc))
   arg-descs))


(define (make-argument-binding binder alloc-var name type)
  (assert (is-binder? binder))
  (assert (procedure? alloc-var))
  (assert (symbol? name))
  (assert (is-target-object? type))
  (let* ((exact-type? (and 
		       (not (is-t-type-variable? type))
		       (is-t-instance? binder type tc-class)
		       (not (tno-field-ref type 'inheritable?))))
	 (result
	  (cons
	   name
	   (make-normal-variable1
	    (alloc-var name #f)
	    type
	    exact-type?
	    #t
	    '()))))
    result))


(define (make-argument-bindings binder alloc-var names types)
  (assert (is-binder? binder))
  (assert (procedure? alloc-var))
  (assert (list? names))
  (assert (and-map? symbol? names))
  (assert (list? types))
  (assert (and-map? is-target-object? types))
  (if (= (length names) (length types))
      (map (lambda (name type)
	     (make-argument-binding binder alloc-var name type))
	   names types)
      (raise 'internal-error-compiling-procedure)))


(define (check-procedure-result-type? binder t-computed t-declared)
  (assert (is-binder? binder))
  (assert (is-target-object? t-declared))
  (assert (is-target-object? t-computed))
  (let ((decl-none? (entity-is-none1? binder t-declared)))
    (cond
     (decl-none? #t)
     ((entity-is-none1? binder t-computed) decl-none?)
     (else (is-t-subtype? binder t-computed t-declared)))))


(define (generic-find-decl binder generic method-type)
  (assert (is-binder? binder))
  (assert (is-t-gen-proc? generic))
  (assert (is-target-object? method-type))
  (let ((methods (tno-field-ref generic 'l-methods))
	(decl '()))
    (do ((cur-methods methods (cdr cur-methods)))
	((or (null? cur-methods) (not-null? decl)) decl)
      (let* ((cur-method (car cur-methods))
	     (cur-method1 (car cur-method))
	     (cur-method-type (get-entity-type cur-method1)))
	(if (hfield-ref cur-method1 'incomplete?)
	    ;; is-t-subtype? would not work here
	    (if (equal-types? binder method-type cur-method-type)
		(begin
		  (set! decl cur-method))))))))


(define (remove-list-element lst obj)
  (cond
   ((null? lst) '())
   ((eq? obj (car lst)) (cdr lst))
   (else (cons (car lst) (remove-list-element (cdr lst) obj)))))


(define (update-generic! binder generic new-methods)
  (let* ((new-method-classes
	  (map (lambda (p-method)
		 (assert (pair? p-method))
		 (get-entity-type (car p-method)))
	       new-methods))
	 (new-class (make-gen-proc-class-object new-method-classes)))
    (hfield-set! generic 'type new-class)
    (tno-field-set! generic 'l-methods new-methods)))


(define (add-new-method-to-generic! binder to-generic to-method static?)
  (assert (is-binder? binder))
  (assert (is-target-object? to-generic))
  (assert (is-target-object? to-method))
  (assert (eq? (get-object-type (get-object-type to-generic))
	       tmc-gen-proc))
  (let* ((old-methods (tno-field-ref to-generic 'l-methods))
	 (new-methods (cons (cons to-method static?) old-methods)))
    (update-generic! binder to-generic new-methods)))


(define (define-declared-method! binder generic decl method static?)
  (assert (is-binder? binder))
  (assert (is-target-object? generic))
  (assert (is-target-object? method))
  (assert (and (is-target-object? generic)
	       (eq? (get-object-type
		     (get-object-type generic))
		    tmc-gen-proc)))
  (assert (boolean? static?))
  (strong-assert (eq? static? (cdr decl)))
  (let* ((old-methods (tno-field-ref generic 'l-methods))
	 (methods0 (remove-list-element old-methods decl))
	 (new-methods (cons (cons method static?) methods0)))
    (update-generic! binder generic new-methods)))


(define (add-method-to-generic! binder generic method static?)
  (assert (is-binder? binder))
  (assert (is-target-object? generic))
  (assert (is-target-object? method))
  (assert (and (eq? (get-entity-type
		     (get-entity-type generic))
		    tmc-gen-proc)))
  (assert (boolean? static?))
  (let ((decl (generic-find-decl binder
				 generic
				 (get-entity-type method))))
    (if (null? decl)
	(begin
	  (add-new-method-to-generic! binder generic method static?)
	  method)
	(begin
	  (set-object! (car decl) method)
	  (define-declared-method! binder generic decl method static?)
	  (car decl)))))


(define (add-method-to-generic2! binder generic decl method static?)
  (assert (is-binder? binder))
  (assert (is-target-object? generic))
  (assert (or (null? decl)
	      (and (pair? decl)
		   (is-target-object? (car decl))
		   (boolean? (cdr decl)))))
  (assert (is-target-object? method))
  (if (null? decl)
      (begin
	(add-new-method-to-generic! binder generic method static?)
	method)
      (begin
	(set-object1! (car decl) method)
	(define-declared-method! binder generic decl method static?)
	(car decl))))


(define (get-method-declaration address t-method-type)
  (make-incomplete-object-with-address address t-method-type #f))


(define (is-type-oper-appl? ent)
  (or
   (is-t-type-list? ent)
   (is-t-rest? ent)
   (is-t-splice? ent)
   (is-t-type-loop? ent)
   (is-t-type-join? ent)))


(define (is-simple-arg-list? arg-descs)
  ;; The following expression is #t for an empty list.
  (not (or-map? is-type-oper-appl? arg-descs)))


(define (get-checked-prim-proc name proctype)
  (let ((address (alloc-target-prim-loc name))
	(to (make-target-object
	     proctype
	     #t #f '() #f #f
	     #f '())))
    (make-hrecord <checked-prim-proc>
		  proctype
		  #t
		  #f
		  address
		  #t
		  #t
		  #f
		  to)))


(define (make-prim-class-proc-def var target-name checked? rebind?)
  (let* ((r-type (get-entity-type var))
	 (r-proc (if checked?
		    (get-checked-prim-proc target-name r-type)
		    (get-prim-proc-expression target-name r-type))))
    (make-normal-var-def
     r-type
     var
     r-proc
     rebind?)))


(define (make-prim-class-proc-def1 var target-name checked? env-all)
  (if (not-null? var)
      (let* ((address (hfield-ref var 'address))
	     (rebind? (address-env-address-exists? env-all address))) 
	(make-prim-class-proc-def var target-name checked? rebind?))
      '()))


(define (find-none-type binder l-types l-names)
  (cond
   ((null? l-types) '())
   ((entity-is-none1? binder (car l-types)) (car l-names))
   (else (find-none-type binder (cdr l-types) (cdr l-names)))))
