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


;; *** Handling cyclic objects ***


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


(define gl-flag2? #f)
(define gl-ctr12 0)


(define cycle-fields
  (list
   (make-field 'address tc-object 'public 'hidden #f '())
   (make-field 'object tc-object 'public 'hidden #f '())))


(define tc-cycle
  (make-builtin-target-class '<cycle>
			     tc-object cycle-fields #f #t #f 'public))


(define is-t-cycle? (make-t-predicate0 tc-cycle))


(define (make-cycle address obj)
  (assert (or (null? address) (is-address? address)))
  (assert (is-type0? obj))
  (make-target-object
   tc-cycle
   #f
   #f
   '()
   #f
   #f
   (list (cons 'address address)
	 (cons 'object obj))
   '()))


(define (detect-cycles binder expr ht-cycles lst-visited)
  (assert (is-binder? binder))
  (assert (hash-table? ht-cycles))
  (assert (list? lst-visited))
  
  ;; (if gl-flag16?
  ;;     (begin
  ;; 	(dwi "det ")
  ;; 	(dwc gl-counter12)
  ;; 	(dwc " ")
  ;; 	(dwc gl-indent)
  ;; 	(dwc " ")
  ;; 	(if (hrecord? expr)
  ;; 	    (dwc (hrecord-type-name-of expr))
  ;; 	    (dwc "?"))
  ;; 	(if (is-target-object? expr)
  ;; 	    (begin
  ;; 	      (dwc " ")
  ;; 	      (dwc (target-object-as-string expr))))
  ;; 	(dwc " ")
  ;; 	(dwc (hashq expr 10000000))
  ;; 	(dwli-newline)))
	
  (let ((old-indent gl-indent))
    (set! gl-indent (+ gl-indent 1))
    (let ((cycle (hashq-ref ht-cycles expr)))
      (cond
       ((not (eqv? cycle #f)) '())
       ((null? expr) '())
       ((eqv? expr tc-class) '())
       ((memq expr lst-visited)
	(let* ((alloc-var (hfield-ref binder 'allocate-variable))
	       (address (alloc-var 'cycle-1 #f))
	       (obj (make-incomplete-object-with-address address tc-object #f))
	       (cycle (make-cycle address obj)))
	  (dwli2 "cycle HEP")
	  (hashq-set! ht-cycles expr cycle)))
       ((pair? expr)
       	(let ((lst-new-visited (cons expr lst-visited)))
       	  (detect-cycles binder (car expr) ht-cycles lst-new-visited)
       	  (detect-cycles binder (cdr expr) ht-cycles lst-new-visited)))
       ((is-tc-pair? expr)
       	(let ((lst-new-visited (cons expr lst-visited)))
       	  (detect-cycles binder (get-pair-first-type expr) ht-cycles
       			 lst-new-visited)
       	  (detect-cycles binder (get-pair-second-type expr) ht-cycles
       			 lst-new-visited)))
       ((and
	 (not (is-t-primitive-object? expr))
	 (is-known-object? expr)
       	 (is-tc-pair? (get-entity-type expr)))
       	(let ((lst-new-visited (cons expr lst-visited)))
       	  (detect-cycles binder (tno-field-ref expr 'first) ht-cycles
       			 lst-new-visited)
       	  (detect-cycles binder (tno-field-ref expr 'second) ht-cycles
       			 lst-new-visited)))
       ((is-normal-variable? expr) '())
       ((hrecord-is-instance? expr <proc-appl>)
	(let* ((lst-new-visited (cons expr lst-visited))
	       (det (lambda (expr1) (detect-cycles binder expr1 ht-cycles
						   lst-new-visited))))
	  (det (hfield-ref expr 'type))
	  (det (hfield-ref expr 'proc))
	  (for-each det (hfield-ref expr 'arglist))
	  (for-each det (hfield-ref expr 'params))
	  (for-each det (hfield-ref expr 'static-arg-types))))
       ((is-t-param-class-instance? expr)
       	(let* ((lst-new-visited (cons expr lst-visited))
       	       (det (lambda (expr1) (detect-cycles binder expr1 ht-cycles
       						   lst-new-visited))))
       	  (det (tno-field-ref expr 'cl-superclass))
       	  (for-each det
       	  	    (map (lambda (fld) (tno-field-ref fld 'type))
       	  		 (tno-field-ref expr 'l-all-fields)))
       	  (for-each det
		    (tno-field-ref expr 'l-tvar-values))))
       ;; Subclasses of <variable-definition> are not handled here.
       ((hrecord-type=? (hrecord-type-of expr) <variable-definition>)
       	(let ((lst-new-visited (cons expr lst-visited)))
	  (detect-cycles binder (get-entity-type expr) ht-cycles
			 lst-new-visited)
	  (detect-cycles binder (hfield-ref expr 'type-decl) ht-cycles
			 lst-new-visited)
	  (detect-cycles binder (hfield-ref expr 'value-expr) ht-cycles
			 lst-new-visited)))
       ((hrecord-is-instance? expr <procedure-expression>)
	(let* ((lst-new-visited (cons expr lst-visited))
	       (det (lambda (expr1) (detect-cycles binder expr1 ht-cycles
       						   lst-new-visited)))
	       (lst-arg-types (map get-entity-type
				   (hfield-ref expr 'arg-variables))))
	  (det (hfield-ref expr 'type))
	  (for-each det (hfield-ref expr 'arg-descs))
	  (for-each det lst-arg-types)
	  (det (hfield-ref expr 'result-type))
	  (det (hfield-ref expr 'body))))
       (else
	(let* ((lst-subexprs (get-subexpressions expr))
	       (lst-new-visited (cons expr lst-visited)))
	  (detect-cycles binder (hfield-ref expr 'type) ht-cycles
			 lst-new-visited)
	  (for-each (lambda (expr1) (detect-cycles binder expr1 ht-cycles
						   lst-new-visited))
		    lst-subexprs))))
      (set! gl-indent old-indent))))


(define (make-cycle-object obj)
  (assert (is-target-object? obj))
  (make-incomplete-object (get-expr-type obj) #f))


(define (update-cycle-object! sgt element)
  (assert (is-target-object? sgt))
  (assert (is-target-object? element))
  (set-object1! sgt element)
  (hfield-set! sgt 'address
	       (hfield-ref element 'address)))

